diff options
Diffstat (limited to 'plugins/Libs/kol.pas')
| -rw-r--r-- | plugins/Libs/kol.pas | 61873 |
1 files changed, 61873 insertions, 0 deletions
diff --git a/plugins/Libs/kol.pas b/plugins/Libs/kol.pas new file mode 100644 index 0000000000..74d97b7a85 --- /dev/null +++ b/plugins/Libs/kol.pas @@ -0,0 +1,61873 @@ +//[START OF KOL.pas]
+{****************************************************************
+
+ KKKKK KKKKK OOOOOOOOO LLLLL
+ KKKKK KKKKK OOOOOOOOOOOOO LLLLL
+ KKKKK KKKKK OOOOO OOOOO LLLLL
+ KKKKK KKKKK OOOOO OOOOO LLLLL
+ KKKKKKKKKK OOOOO OOOOO LLLLL
+ KKKKK KKKKK OOOOO OOOOO LLLLL
+ KKKKK KKKKK OOOOO OOOOO LLLLL
+ KKKKK KKKKK OOOOOOOOOOOOO LLLLLLLLLLLLL
+ KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL
+
+ Key Objects Library (C) 2000 by Vladimir Kladov.
+
+****************************************************************
+* VERSION 3.18
+****************************************************************
+
+ 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
+ executables of size about 10 times smaller. But this does not mean that
+ KOL is less power then the VCL - perhaps just the opposite...
+
+ KOL is provided free with the source code.
+ Copyright (C) Vladimir Kladov, 2000-2011.
+
+ 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.
+
+****************************************************************}
+
+{$I KOLDEF.inc}
+
+{$IFDEF x64}
+ {$DEFINE PAS_ONLY}
+{$ENDIF}
+{$IFDEF PAS_ONLY}
+ {$DEFINE PAS_VERSION}
+{$ENDIF}
+
+{$IFDEF EXTERNAL_KOLDEFS}
+ {$INCLUDE PROJECT_KOL_DEFS.INC}
+{$ENDIF}
+{$IFDEF EXTERNAL_DEFINES}
+ {$INCLUDE EXTERNAL_DEFINES.INC}
+{$ENDIF EXTERNAL_DEFINES}
+
+ {$DEFINE GDI}
+
+{$UNDEF LIN} {$UNDEF WIN} {$UNDEF GDI}
+{$IFDEF LINUX}
+ {$DEFINE UNIX}
+ {$DEFINE LIN}
+ {$DEFINE PAS_VERSION}
+ {$DEFINE NOT_USE_RICHEDIT}
+ {$IFNDEF GTK}
+ {$IFNDEF XQT}
+ {$DEFINE GTK} // it is also possible to define GTK as a project option
+ {$ENDIF XQT} // even for Windows system
+ {$ENDIF GTK}
+{$ELSE} // to exploit GTK under Win32 rather then native GDI
+ {$DEFINE WIN}
+ {$DEFINE GDI}
+{$ENDIF}
+
+ {$IFDEF GTK} {$UNDEF GDI} {$DEFINE _X_}
+ {$DEFINE NOT_USE_RICHEDIT}
+ {$ENDIF}
+//{$IFDEF Q_T} {$UNDEF GDI} {$DEFINE _X_} {$ENDIF}
+
+{$IFDEF WIN} {$IFDEF GDI}
+ {$DEFINE WIN_GDI}
+{$ENDIF GDI} {$ENDIF WIN}
+
+{.$INCLUDE delphidef.inc}
+
+{$IFDEF WIN_GDI}
+ //test
+{$ENDIF WIN_GDI}
+{$IFDEF LIN}
+ //test
+{$ENDIF LIN}
+
+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:
+|<br>
+ - to create objects dynamically, use P<objname> instead of
+ T<objname> to allocate a pointer for dynamically created
+ object instance;
+|<br>
+ - remember, that constructors of objects can not be virtual.
+ Override procedure Init instead in your own derived objects;
+|<br>
+ - rather then call constructors of objects, call global procedures
+ New<objname> (e.g. NewLabel). If not, first (for virtualally
+ created objects) call New( ); then call constructor Create
+ (which calls Init) - but this is possible only if the constructor
+ is overriden by a new one.
+|<br>
+ - 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 )" inplace of "C as TSomeClassType".
+|<br>
+|<hr>
+ 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; ]
+|<hr>
+|&U= <a href="#%0">%0</a><br>
+|&B=<a href="%1.htm">%0</a><br>
+|&C=<a href="%1.htm">%0</a>
+| <table border=1 cellpadding=6 width=100%>
+| <colgroup valign=top span=2>
+| <tr>
+| <td> objects </td> <td> functions by category </td>
+| </tr>
+| <td>
+ <C _TObj> <B TObj>
+ <C TList> <C TListEx> <C TStrList> <B TStrListEx>
+ <C TTree> <C TDirList> <C TIniFile> <C TCabFile>
+ <B TStream>
+ <B TControl>
+ <C TGraphicTool> <C TCanvas> <C TImageList> <C TIcon> <C TBitmap>
+ <C TGif> <C TGifDecoder> <B TJpeg>
+ <C TTimer> <C TThread> <C TTrayIcon> <C TDirChange> <B TMediaPlayer>
+ <C TMenu> <C TOpenSaveDialog> <C TOpenDirDialog> <B TColorDialog>
+ <C TAction> <B TActionList>
+ <B Exception>
+| </td>
+| <td>
+|<a href="kol_pas.htm#visual_objects_constructors">
+ Visual objects constructing functions
+|</a><br><br>
+ <U Working with null-terminated and ansi strings>
+ <U Small bit arrays (max 32 bits in array)>
+ <U Arithmetics, geometry and other utility functions>
+ <U Data sorting (quicksort implementation)>
+ <U String to number and number to string conversions>
+ <U 64-bit integer numbers>
+ <U Floating point numbers>
+ <U Date and time handling>
+ <U File and directory routines>
+ <U System functions and working with windows>
+ <U Text in clipboard operations>
+ <U Wrappers to registry API functions>
+| </td>
+| </table>
+
+ Following conditional symbols can be used in a project
+ (Project | Options | Directories/Conditional Defines)
+ to change code generated a bit. There are following:
+|<pre>
+
+ 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
+ characters in a semicolon-separated list of included
+ options). This symbol allows to exceed this restriction:
+ you place your defines in an included file
+ EXTERNAL_DEFINES.INC, located in your project directory.
+ Since this is a normal pascal source, use usual Pascal
+ syntax: add a directive (*$DEFINE symbol*) for each
+ symbol you want, and you can decorate it with usual
+ comments if necessary.
+ ENABLE_DEPRECATED - some old declaration made "deprecated" and moved to
+ KOL_deprecated.inc. This symbol provides including
+ such declarations into KOL.pas and makes it available
+ again.
+ DISABLE_DEPRECATED - (default) - disables deprecated declaration.
+ WIN - (default) - version for Windows.
+ LINUX - version for Linux (only PAS_VERSION) -- not yet ready
+ When not defined, symbol WIN is defined automatically.
+ LINUX_USE_HOME_STARTFDIR - in Linux app, HOME directory of the user will be
+ returned by GetStartDir function.
+ GTK - version for GTK (Linux or Win32) -- not yet ready
+ XQT - version for QT (Linux or Win32) -- not yet ready
+ FPC - Free Pascal version. KOL can be used with such compiler
+ to create Win32 applications. To create Win-CE
+ applications (with FPC compiler)), use the separate
+ version of KOL specially designed for it.
+ INPACKAGE - version for Mirror Classes Library package (design-time
+ 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.
+ PARANOIA - to force short versions of asm instructions (for D5
+ and below, D6 and higher use those instructions always).
+ 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 perameter > 15
+ (o) .... other see in code
+ SMALLER_CODE - like smallest code, but fuctionality 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 redircted 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_KOLMATH - Only for _X_ (GTK + Linux): to prevent referencing
+ KOLmath in uses. This makes method TCanvas.Arc
+ unavailable, but the application become smaller.
+ 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 recource in qutations).
+ 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.
+ USE_MHTOOLTIP - to use KOLMHTOOLTIP.pas (actually it is not a separate
+ unit but a set of portions of code included into KOL.pas
+ in different places). This unit provides tooltips (hints)
+ for arbitrary controls which appear when mouse is over
+ such controls.
+ USE_GRUSH - to use ToGRush.pas unit, which provides automatic
+ redirection of the most cintrols creation functions
+ to the KOLGRushControls.pas.
+ (USE_CONSTRUCTORS - to use constructors like in VCL. Note: this option is
+ not carefully tested!)
+ TLIST_FAST - very fast implementation of TList (for coast of some
+ additional code).
+ DFLT_TLIST_NOUSE_BLOCKS - for TLIST_FAST: by default, do not make all TList
+ objects using new (fast) algoritms, but only those of
+ TList objects, which property UseBlocks was set to
+ TRUE after creating it.
+ STREAM_LARGE64 - turns on support of streams (and files) of size larger
+ then 4 Gbytes. Data type Int64 used for parameters of
+ the most of methods and functions in such case. (Note:
+ Int64 was introduced since Delphi5, so in earlier Delphi
+ versions using this symbol is not possible).
+ STREAM_COMPAT - still STREAM_LARGE64 appeared (in v2.84), most of
+ methods and functions declarations became incompatible
+ with earlier created extensions. This symbol provides
+ compatibility for such extensions, but it desables
+ using large streams.
+ OLD_STREAM_CAPACITY - to use elder TStream.SetCapacity algorithm (it did not
+ make Capacity smaller than already achieved, but in
+ newer version, Capacity can be set to a smaller value,
+ and for memory streams, rest of memory is freeing in
+ such case).
+ OLD_MEMSTREAMS_SETSIZE - to use elder TStream.SetSize for memory streams. In
+ a new version, setting new size also changes Capacity
+ to the same value (in earlier case, a value for
+ Capacity property was calculated to become a bit
+ greater then a value set for Size property).
+ OLD_COMPAT - to use symbol ';' as a file list separator (all operations
+ using DoFileOp function such as DeleteFile2Recycle and
+ CopyMoveFiles).
+ 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.
+ 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.
+ BITBTN_DISABLEDGLYPH2 - to restore old behaviour of multi-glyph bitbtn, when
+ index 2 was used to represent the button in disabled
+ state, and glyph with index 1 was used forpressed dtate.
+ Now by default index 1 corresponds to the disabled state,
+ and index 2 to the pressed state, i.e. these are swapped.
+ ESC_CLOSE_DIALOGS - to allow closing all dialogs with ESCAPE.
+ KEY_PREVIEW - form also receive WM_KEYDOWN (OnKeyDown event fired)
+ SUPPORT_ONDEADCHAR - to support OnKeyDeadChar event in responce to
+ WM_DEADCHAR, WM_SYSDEADCHAR
+ OpenSaveDialog_Extended - to allow using custom extensions for OpenSaveDialog.
+ AUTO_CONTEXT_HELP - to use automatic respond to WM_CONTEXTMENU to call
+ context help.
+ NOT_FIX_CURINDEX - to use old version of TControl.SetItems, which could
+ lead to loose CurIndex value (e.g. for Combobox)
+ 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
+ only two forms are visible at a time (the main form and
+ the active modal form).
+ NEW_MODAL - to use extended modalness.
+ 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.
+ 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
+ controls of the toolbar control, but when with this option
+ is turned on it is impossible to have neighbour controls
+ on a form correctly aligned. This last disadvantage is
+ not important if a toolbar is always placed on a separate
+ panel-like control as a child.
+ Note: this option has no effect for Win9x, still use of
+ it under Win9x can crash the application!!!
+ TOOLBAR_DOT_NOAUTOSIZE_BUTTON - this option forces prefix dot character in
+ button caption to be treated as an instruction to
+ remove TBSTYLE_AUTOSIZE from the button style. Actually,
+ this feature not necessary still custom button size can
+ be set even if such style is on for a button.
+ 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
+ RICHEDIT_XPBORDER - provide correct drawing rich edit control border with
+ XP themes.
+ GRAPHCTL_XPSTYLES - to use XP themed Visual styles for drawing graphic
+ controls. This does not affect windowed controls
+ which visual style is controlled by the manifest.
+ This option also turns on RICHEDIT_XPBORDER option.
+ GRAPHCTL_HOTTRACK - to use hot-tracking also together with XP themed
+ graphic controls (otherwise only static XP themed
+ view is provided). Also, turn this option on if you
+ want to handle OnMouseEnter and OnMouseLeabe events
+ for graphic controls.
+ NEW_OPEN_DIR_STYLE_EX - to use new code for TOpenDirDialog, which provides
+ correct working of the dialog with an option
+ odNewDialogStyle set (even in Windows 9x system).
+ HTMLHELP_NOTOP - when Html help is called, its window become a child of
+ the desktop, not application (in such case it is not
+ closed together with the application, and it is apper
+ not on top of the application).
+ ICON_DIFF_WH - to support icons having Width <> Height
+ ICONLOAD_PRESERVEBMPS - when an icon is loaded, its bitmap and mask are
+ extracted and in case when such symbol is defined,
+ these one or two bitmaps are preserved until TIcon
+ object is destroyed.
+ LOADEX - to use TBitmap.LoadFromStreamEx while loading icon
+ from a stream or a file.
+ USE_OLDCONVERT2MASK - to use elder Convert2Mask method (newer is more correct).
+ FIX_TRANSPBMPPALETTE - for TBitmap.StretchDrawMasked, bitmaps with PixelFormat
+ = pf4bit or pf8bit are first converted (in a temporary
+ TBitmap object) to pf32bit, and then are drawn. This
+ fixes problems with palette usage for such DIB bitmaps.
+ FILL_BROKEN_BITMAP - TBitmap.LoadFromStreamEx: broken bitmaps rest of
+ scanlines are be filled with zeroes (usually black color)
+ rather then left containing trash memory bits.
+ AUTO_REPLACE_CLEARTYPE- to replace automatically CLEARTYPE_QUALITY fonts
+ with ANTIALIASED_QUALITY when running under elder
+ Windows version than XP.
+ FORCE_ALTERNATEFILENAME- TDirList.ScanDirectoryFORCE_ALTERNATEFILENAME - forced
+ using an alternate file path and filename for unicode
+ 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)
+ SBOX_OLDPOS - to use elder formulas to calculate scroll box positions
+ (just for compatibility with very old apps using it).
+ OLD_REFCOUNT - to prevent using new RefInc / RefDec behaviour
+ (new style of using RefCount 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?).
+ SCROLL_OLD - for compatibility with the old applications using
+ TScrollBar: there was another method of adjusting
+ SBMax and SBPageSize: SBMax should be corrected to
+ (nMaxItems-1-SBPageSize).
+ FILE_EXISTS_EX - to use more correct (but a bit large code in FileExists functon)
+ USE_AUTOFREE4CONTROLS - (default) - from 2.40, most of control sub-objects are
+ destroying using Add2AutoFree (smaller code).
+ NOT_USE_AUTOFREE4CONTROLS - this option returns to previous behaviour (just to
+ compare code size). Will be deprecated in future.
+ Ignored when UNION_FIELDS is used (by default)
+ 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 otpion to
+ prevent any functionality of WndProcTransparent after
+ AppletTerminated is set to true.
+ STOPTIMER_AFTER_APPLETTERMINATED - use this symbol to prevent timer event
+ firing after setting AppletTerminated to TRUE.
+ TIMER_APPLETWND - to use Applet window to handle WM_TIMER events
+ (otherwise special single invisible window is created
+ to handle such events).
+ SUPPORT_LONG_TIMER - LINUX only: set this option if TTimer.Interval can be
+ set to a value greater then 1,800,000 (30 minutes).
+ 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
+ (program really crashes when the object is
+ attempted to destroy more then once and in most
+ cases when a destroyed object is accessed after the
+ destruction).
+ DEBUG_MCK - specially designed to debug Mirror Classes Kit.
+ DEBUG_OBJKIND - for each TControl object kind a reference to PChar
+ with object kind name is stored in the structure of
+ the object (field fObjKind).
+ DEBUG - other debugging.
+ EXTERNAL_DEFINES - if count of options necessary to set is very large
+ Delphi ignores past of those. To avoid this problem,
+ set only this option in Project's options, and place
+ all other options to ExternalDefines.inc file as a
+ sequence of {$DEFINE ... directives.
+ But note, such file should be located in a
+ project directory, but not in the directory where KOL.pas
+ is located. This is enough to provide different sets
+ of defines for each project.
+ ---- from version 3.00, following symbols are added:
+ USE_FLAGS - to compress boolean flags used (about 6 bytes instead
+ 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.
+ 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
+ to dummy event handlers at create, so checking if the handler
+ 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).
+ |</pre>
+}
+{= K.O.L - ключевая библиотека объектов. (C) Кладов Владимир, 2000-2007.
+}
+
+{$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
+{$T-} // not typed @-operator
+//{$D+}
+//______________________________________________________________________________
+//
+//{$DEFINE INPACKAGE} // Uncomment this line while rebuild MCK package
+// for Delphi3 only, then restore the comment mark!!!!!!!!!!!!!!!!!!!!
+//______________________________________________________________________________
+
+{$IFDEF INPACKAGE} // use this symbol in packages requiring kol.pas
+ {$WARNINGS OFF}
+ //{$DEFINE NOT_USE_AUTOFREE4CONTROLS}
+ {$DEFINE PAS_VERSION}
+ {$UNDEF ASM_VERSION}
+ {$UNDEF ASM_UNICODE}
+ {$IFDEF _D2009orHigher}
+ {$DEFINE UNICODE_CTRLS}
+ {$ENDIF}
+{$ENDIF}
+{$IFDEF _D7orHigher}
+ {$WARN UNSAFE_TYPE OFF} // Too many such warnings in Delphi7
+ {$WARN UNSAFE_CODE OFF}
+ {$WARN UNSAFE_CAST OFF}
+{$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}
+
+{$IFNDEF NOT_UNION_FIELDS}
+ {$DEFINE UNION_FIELDS}
+{$ENDIF}
+
+{$IFDEF UNION_FIELDS}
+ {$UNDEF NOT_USE_AUTOFREE4CONTROLS}
+{$ENDIF}
+
+{$IFNDEF NOT_USE_AUTOFREE4CONTROLS}
+ {$DEFINE USE_AUTOFREE4CONTROLS}
+ {$DEFINE USE_AUTOFREE4CHILDREN}
+{$ENDIF}
+
+{$IFDEF SMALLEST_CODE}
+ {$DEFINE NOT_UNLOAD_RICHEDITLIB}
+ {$DEFINE SMALLER_CODE}
+ {$DEFINE CREATE_VISIBLE}
+{$ELSE}
+ {$IFnDEF SPEED_NORMAL}
+ {$DEFINE SPEED_FASTER}
+ {$ENDIF}
+{$ENDIF}
+{$IFDEF _D2}
+ {$UNDEF SPEED_FASTER}
+{$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}
+
+//{$DEFINE DEBUG_GDIOBJECTS}
+//{$DEFINE CHK_GDI}
+
+uses {$IFDEF WIN}messages, windows {$IFNDEF NOT_USE_RICHEDIT}, RichEdit {$ENDIF}{$ENDIF WIN}
+ {$IFDEF LIN}, Libc, Xlib{$ENDIF}
+ {$IFDEF GTK}, Glib2 , Gdk2, Gtk2, pango {$ENDIF GTK}
+ {$IFDEF CHK_GDI}, ChkGdi {$ENDIF};
+
+{$IFDEF LIN}
+ {$DEFINE global_declare} {$I KOL_Linux.inc} {$UNDEF global_declare}
+////type HDC = TGC; // from Xlib (temporary definition?)
+{$ENDIF LIN}
+
+var
+ AppTheming: Boolean;
+{$IFDEF DEBUG_GDIOBJECTS}
+var
+ BrushCount: Integer;
+ FontCount: Integer;
+ PenCount: Integer;
+{$ENDIF}
+
+{$IFDEF _D2009orHigher}
+type KOLWideString = UnicodeString;
+{$ELSE}
+{$IFDEF _D3orHigher}
+type KOLWideString = WideString;
+{$ENDIF}
+{$ENDIF}
+
+{$IFDEF UNICODE_CTRLS}
+ {$IFDEF _D2}
+ {$ERROR 'Delphi 2 cannot compile with UNICODE_CTRLS defined!'}
+ {$ENDIF}
+const
+ SizeOfKOLChar = SizeOf(WideChar);
+
+ type
+ KOLString = KOLWideString;
+ KOL_String = type KOLWideString;
+ KOLChar = type WideChar;
+ PKOLChar = PWideChar;
+ PKOL_Char = type PWideChar;
+{$ELSE}
+const
+ SizeOfKOLChar = SizeOf(AnsiChar);
+
+ type
+ KOLString = AnsiString;
+ KOL_String = type AnsiString;
+ KOLChar = type AnsiChar;
+ PKOLChar = PAnsiChar;
+ PKOL_Char = type PAnsiChar;
+ {$IFDEF ASM_VERSION}
+ {$IFNDEF ASM_NOUNICODE}
+ {$DEFINE ASM_UNICODE}
+ {$ENDIF}
+ {$UNDEF PAS_VERSION}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFNDEF ASM_VERSION}
+ {$DEFINE PAS_VERSION}
+{$ENDIF ASM_VERSION}
+
+{$IFDEF PAS_VERSION}
+ {$UNDEF ASM_VERSION}
+ {$UNDEF ASM_UNICODE}
+ {$UNDEF ASM_TLIST}
+{$ENDIF}
+
+{BCB++}(*type DWORD = Windows.DWORD;*){--BCB}
+
+{$IFDEF WIN}
+//{_#IF [DELPHI]}
+ {$INCLUDE delphicommctrl.inc}
+ {$IFNDEF FPC}
+ {$IFDEF UNICODE_CTRLS}
+ {$DEFINE interface_part} {$I KOL_unicode.inc} {$UNDEF interface_part}
+ {$ELSE} // ANSI_CTRLS
+ {$DEFINE interface_part} {$I KOL_ansi.inc} {$UNDEF interface_part}
+ {$ENDIF UNICODE_CTRLS}
+ {$ENDIF}
+//{_#ENDIF}
+{$ENDIF WIN}
+
+type
+ _TObj = object
+ {* auxiliary object type. See TObj. }
+ protected
+ procedure Init; virtual;
+ {* Is called from a constructor to initialize created object instance
+ filling its fields with 0. Can be overriden in descendant objects
+ to add another initialization code there. (Main reason of intending
+ is what constructors can not be virtual in poor objects). }
+ {= Вызывается для инициализации объекта. }
+ public
+ function VmtAddr: Pointer;
+ {* Returns addres of virtual methods table of object. ? }
+ {= возвращает адрес таблицы виртуальных методов (VMT). ? }
+ end;
+
+ PObj = ^TObj;
+ {* }
+
+ PList = ^TList;
+ {* }
+
+ PPointerList = ^TPointerList;
+ TPointerList = array[0..{$IFDEF _DXE2orHigher} 65536
+ {$ELSE} MaxInt div 4 - 1 {$ENDIF}] of Pointer;
+
+ TObjectMethod = procedure of object;
+ {* }
+ TOnEvent = procedure( Sender: PObj ) of object;
+ {* This type of event is the most common - event handler when called can
+ know only what object was a sender of this call. Replaces good known
+ VCL TNotifyEvent event type. }
+
+ TOnEventMoving = procedure( Sender: PObj; P: PRect ) of object;
+
+{ ---------------------------------------------------------------------
+ TObj - base object to derive all others
+---------------------------------------------------------------------- }
+//[TObj DEFINITION]
+ TObj = object( _TObj )
+ {* Prototype for all objects of KOL. All its methods are important to
+ implement objects in a manner similar to Delphi TObject class. }
+ {= Базовый класс для всех прочих объектов KOL. }
+ protected
+ {$IFDEF DEBUG_OBJKIND}
+ fObjKind: PChar;
+ {$ENDIF}
+ fRefCount: Integer;
+ fOnDestroy: TOnEvent;
+ {$IFDEF OLD_REFCOUNT}
+ procedure DoDestroy;
+ {$ENDIF}
+ protected
+ fAutoFree: PList;
+ {* Is called from a constructor to initialize created object instance
+ filling its fields with 0. Can be overriden in descendant objects
+ to add another initialization code there. (Main reason of intending
+ is what constructors can not be virtual in poor objects). }
+ {= Вызывается для инициализации объекта. }
+ fTag: DWORD;
+ {* Custom data. }
+ public
+ destructor Destroy; virtual;
+ {* Disposes memory, allocated to an object. Does not release huge strings,
+ dynamic arrays and so on. Such memory should be freeing in overriden
+ destructor. }
+ {= Освобождает память, выделенную для объекта. Не освобождает память, выделенную
+ для строк, динамичиских массивов и т.п. Такая память должна быть освобождена
+ в переопределенном деструкторе объекта. }
+ {$IFnDEF NIL_EVENTS}
+ //procedure Init; virtual;
+ {* Can be overriden in descendant objects
+ to add initialization code there. (Main reason of intending
+ is what constructors can not be virtual in poor objects). }
+ {$ENDIF NIL_EVENTS}
+ procedure Final;
+ {* It is called in destructor to perform OnDestroy event call and to
+ released objects, added to fAutoFree list. }
+ public
+ procedure RefInc;
+ {* See comments below. }
+ {= См. RefDec ниже. }
+ function RefDec: Integer;
+ {* Decrements reference count. If it is becoming <0, and Free
+ method was already called, object is (self-) destroyed. Otherwise,
+ Free method does not destroy object, but only sets flag
+ "Free was called".
+ |<br>
+ Use RefInc..RefDec to provide a block of code, where
+ object can not be destroyed by call of Free method.
+ This makes code more safe from intersecting flows of processing,
+ where some code want to destroy object, but others suppose that it
+ is yet existing.
+ |<br>
+ If You want to release object at the end of block RefInc..RefDec,
+ do it immediately BEFORE call of last RefDec (to avoid situation,
+ when object is released in result of RefDec, and attempt to
+ destroy it follow leads to AV exception).
+ |<br>
+ Actually, this "function" is a procedure and does not return
+ any sensible value. It is declared as a function for internal
+ needs (to avoid creating separate code for Free method)
+ }
+ {= Уменьшает счетчик использования. Если в результате счетчик становится
+ < 0, и метод Free уже был вызван, объект (само-) разрушается. Иначе,
+ метод Free не разрушает объект, а только устанавливает флаг "Free был
+ вызван".
+ |<br>
+ Используйте RefInc..RefDec для предотвращения разрушения объекта на
+ некотором участке кода (если есть такая необходимость).
+ |<br>
+ Если нужно убить (временный) объект вместе с последним RefDec, сделайте
+ вызов Free немедленно ПЕРЕД последним RefDec. }
+ property RefCount: Integer read fRefCount;
+ {* }
+ {$IFDEF OLD_FREE}
+ procedure Free;
+ {$ELSE NEW_FREE}
+ property Free: Integer read RefDec;
+ {* 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. }
+
+ constructor Create;
+ {* Constructor. Do not call it. Instead, use New<objectname> function
+ call for certain object, e.g., NewLabel( AParent, 'caption' ); }
+ {= Конструктор. Не следует вызывать его. Для конструирования объектов,
+ вызывайте соответствующую глобальную функцию New<имя-объекта>. Например,
+ NewLabel( MyForm, 'Метка№1' ); }
+ class function AncestorOfObject( Obj: Pointer ): Boolean;
+ {* Is intended to replace 'is' operator, which is not applicable to objects. }
+ function VmtAddr: Pointer;
+ {* Returns addres of virtual methods table of object. }
+ {= возвращает алрес таблицы виртуальных методов (VMT). }
+ property OnDestroy: TOnEvent read fOnDestroy write fOnDestroy;
+ {* This event is provided for any KOL object, so You can provide your own
+ OnDestroy event for it. }
+ {= Данное событие обеспечивается для всех объектов KOL. Позволяет сделать
+ что-нибудь в связи с разрушением объекта. }
+ procedure Add2AutoFree( Obj: PObj );
+ {* Adds an object to the list of objects, destroyed automatically
+ when the object is destroyed. Do not add here child controls of
+ the TControl (these are destroyed by another way). Only non-control
+ objects, which are not destroyed automatically, should be added here. }
+ procedure Add2AutoFreeEx( Proc: TObjectMethod );
+ {* Adds an event handler to the list of events, called in destructor.
+ This method is mainly for internal use, and allows to auto-destroy
+ VCL components, located on KOL form at design time (in MCK project). }
+ procedure RemoveFromAutoFree( Obj: PObj );
+ {* Removes an object from auto-free list }
+ procedure RemoveFromAutoFreeEx( Proc: TObjectMethod );
+ {* Removes a procedure from auto-free list }
+ property Tag: DWORD read fTag write fTag;
+ {* Custom data field. }
+ protected
+ {$IFDEF USE_NAMES}
+ fName: AnsiString;
+ fNamedObjList: Plist;
+ fOwnerObj: PObj;
+ {$ENDIF}
+ public
+ {$IFDEF USE_NAMES}
+ procedure SetName( NewOwnerObj: PObj; NewName: AnsiString);
+ property Name: Ansistring read FName;
+
+ property NamedObjList : PList read fNamedObjList;
+ property OwnerObj: PObj read FOwnerObj;
+ function FindObj(const ObjName: Ansistring): PObj;
+ {$ENDIF}
+ end;
+
+{ ---------------------------------------------------------------------
+ TList - object to implement list of pointers (or dwords)
+---------------------------------------------------------------------- }
+ TList = object( TObj )
+ {* Simple list of pointers. It is used in KOL instead of standard VCL
+ TList to store any kind data (or pointers to these ones). Can be created
+ calling function NewList. }
+ {= Простой список указателей. }
+ protected
+ fItems: PPointerList;
+ fCount: Integer;
+ fCapacity: Integer;
+ fAddBy: Integer;
+ procedure SetCount(const Value: Integer);
+ procedure SetAddBy(Value: Integer);
+ destructor Destroy; virtual;
+ {* Destroys list, freeing memory, allocated for pointers. Programmer
+ is resposible for destroying of data, referenced by the pointers. }
+ procedure SetCapacity( Value: Integer );
+ function Get( Idx: Integer ): Pointer;
+ procedure Put( Idx: Integer; Value: Pointer );
+ {$IFDEF USE_CONSTRUCTORS}
+ procedure Init; virtual;
+ {$ENDIF}
+ protected
+ {$IFDEF TLIST_FAST}
+ fBlockList: PList;
+ fLastKnownBlockIdx: Integer;
+ fLastKnownCountBefore: Integer;
+ fUseBlocks: Boolean;
+ fNotOptimized: Boolean;
+ {$ENDIF}
+ public
+ procedure Clear;
+ {* Makes Count equal to 0. Not responsible for freeing (or destroying)
+ data, referenced by released pointers. }
+ procedure Add( Value: Pointer );
+ {* Adds pointer to the end of list, increasing Count by one. }
+ procedure Insert( Idx: Integer; Value: Pointer );
+ {* Inserts pointer before given item. Returns Idx, i.e. index of
+ inserted item in the list. Indeces of items, located after insertion
+ point, are increasing. To add item to the end of list, pass Count
+ as index parameter. To insert item before first item, pass 0 there. }
+ function IndexOf( Value: Pointer ): Integer;
+ {* Searches first (from start) item pointer with given value and returns
+ its index (zero-based) if found. If not found, returns -1. }
+ procedure Delete( Idx: Integer );
+ {* Deletes given (by index) pointer item from the list, shifting all
+ follow item indeces up by one. }
+ procedure DeleteRange( Idx, Len: Integer );
+ {* Deletes Len items starting from Idx. }
+ procedure Remove( Value: Pointer );
+ {* Removes first entry of a Value in the list. }
+ property Count: Integer read fCount write SetCount;
+ {* Returns count of items in the list. It is possible to delete a number
+ of items at the end of the list, keeping only first Count items alive,
+ assigning new value to Count property (less then Count it is). }
+ property Capacity: Integer read fCapacity write SetCapacity;
+ {* Returns number of pointers which could be stored in the list
+ without reallocating of memory. It is possible change this value
+ for optimize usage of the list (for minimize number of reallocating
+ memory operations). }
+ property Items[ Idx: Integer ]: Pointer read Get write Put; default;
+ {* Provides access (read and write) to items of the list. Please note,
+ that TList is not responsible for freeing memory, referenced by stored
+ pointers. }
+ function Last: Pointer;
+ {* Returns the last item (or nil, if the list is empty). }
+ procedure Swap( Idx1, Idx2: Integer );
+ {* Swaps two items in list directly (fast, but without testing of
+ index bounds). }
+ procedure MoveItem( OldIdx, NewIdx: Integer );
+ {* Moves item to new position. Pass NewIdx >= Count to move item
+ after the last one. }
+ procedure Release;
+ {* Especially for lists of pointers to dynamically allocated memory.
+ Releases all pointed memory blocks and destroys object itself. }
+ procedure ReleaseObjects;
+ {* Especially for a list of objects derived from TObj.
+ Calls Free for every of the object in the list, and then calls
+ Free for the object itself. }
+ property AddBy: Integer read fAddBy write SetAddBy;
+ {* Value to increment capacity when new items are added or inserted
+ and capacity need to be increased. }
+ property DataMemory: PPointerList read fItems;
+ {* Raw data memory. Can be used for direct access to items of a list.
+ Do not use it for TLIST_FAST ! }
+ procedure Assign( SrcList: PList );
+ {* Copies all source list items. }
+ {$IFDEF _D4orHigher}
+ procedure AddItems( const AItems: array of Pointer );
+ {* Adds a list of items given by a dynamic array. }
+ {$ENDIF}
+ function ItemAddress( Idx: Integer ): Pointer;
+ {* Returns an address of memory occupying by the item with index Idx.
+ (If the item is a pointer, returned value is a pointer to a pointer).
+ Item with index requested must exist. }
+ {$IFDEF TLIST_FAST}
+ property UseBlocks: Boolean read fUseBlocks write fUseBlocks;
+ {$ENDIF}
+ procedure OptimizeForRead;
+ end;
+
+function NewList: PList;
+{* Returns pointer to newly created TList object. Use it instead usual
+ TList.Create as it is done in VCL or XCL. }
+
+{$IFDEF _D4orHigher}
+function NewListInit( const AItems: array of Pointer ): PList;
+{* Creates a list filling it initially with certain Items. }
+{$ENDIF}
+
+{$IFNDEF TLIST_FAST}
+{$IFNDEF PAS_ONLY}
+procedure FastIncNum2Elements( List: TList; FromIdx, Count, Value: Integer );
+{* Very fast adds Value to List elements from List[FromIdx] to List[FromIdx+Count-1].
+ Given elements must exist. Count must be > 0. }
+{$ENDIF}
+{$ENDIF}
+
+procedure Free_And_Nil( var Obj );
+{* Obj.Free and Obj := nil, where Obj *MUST* be TObj or its descendant
+ (TControl, TMenu, etc.) This procedure is not compatible with VCL's
+ FreeAndNil, which works with TObject, since this it has another name. }
+
+{$IFDEF WIN_GDI}
+{ ------------------------------- threads ------------------------------------ }
+
+const
+ ABOVE_NORMAL_PRIORITY_CLASS = $8000; // only for Windows 2K
+ BELOW_NORMAL_PRIORITY_CLASS = $4000; // and higher !
+
+type
+ PThread = ^TThread;
+
+ TThreadMethod = procedure of object;
+ TThreadMethodEx = procedure( Sender: PThread; Param: Pointer ) of object;
+
+ TOnThreadExecute = function(Sender: PThread): Integer of object;
+ {* Event to be called when Execute method is called for TThread }
+
+{ ---------------------------------------------------------------------
+ TThread object
+---------------------------------------------------------------------- }
+ TThread = object(TObj)
+ private
+ function GetPriorityBoost: Boolean;
+ procedure SetPriorityBoost(const Value: Boolean);
+ {* Thread object. It is possible not to derive Your own thread-based
+ object, but instead create thread Suspended and assign event
+ OnExecute. To create, use one of NewThread of NewThreadEx functions,
+ or derive Your own descendant object and write creation function
+ (or constructor) for it.
+ |<br><br>
+ Aknowledgements. Originally class ZThread was developed for XCL:
+ |<br> * By: Tim Slusher : junior@nlcomm.com
+ |<br> * Home: http://www.nlcomm.com/~junior
+ }
+ protected
+ FSuspended,
+ FTerminated: Boolean;
+ FHandle: THandle;
+ FThreadId: DWORD;
+ FOnSuspend: TObjectMethod;
+ FOnResume: TOnEvent;
+ FData : Pointer;
+ FOnExecute : TOnThreadExecute;
+ FMethod: TThreadMethod;
+ FMethodEx: TThreadMethodEx;
+ F_AutoFree: Boolean;
+ FPriority: Integer;
+ function GetPriorityCls: Integer;
+ function GetThrdPriority: Integer;
+ procedure SetPriorityCls(Value: Integer);
+ procedure SetThrdPriority(Value: Integer);
+ procedure Init; virtual;
+ destructor Destroy; virtual;
+ {* }
+ public
+ {$IFDEF PSEUDO_THREADS}
+ FPrtyCls: Integer;
+ DoNotWakeUntil: DWORD;
+ AllThreads: PList; // only for MainThread
+ CurrentThread: PThread;
+ StackBottom: Pointer; // except for MainThread
+ CurStackPos: Pointer;
+ Stack_Empty: Boolean;
+ procedure SwitchToThread( T: PThread ); // methods of MainThread
+ procedure NextThread;
+ {$ENDIF}
+ public
+ FResult: Integer;
+ function Execute: integer; virtual;
+ {* Executes thread. Do not call this method from another thread! (Even do
+ not call this method at all!) Instead, use Resume.
+ |<br>
+ Note also that in contrast to VCL, it is not necessary to create your
+ own descendant object from TThread and override Execute method. In KOL,
+ it is sufficient to create an instance of TThread object (see NewThread,
+ NewThreadEx, NewThreadAutoFree functions) and assign OnExecute event
+ handler for it. }
+ procedure Resume;
+ {* Continues executing. It is necessary to make call for every
+ nested Suspend. }
+ procedure Suspend;
+ {* Suspends thread until it will be resumed. Can be called from another
+ thread or from the thread itself. }
+ procedure Terminate;
+ {* Terminates thread. }
+ function WaitFor: Integer;
+ {* Waits (infinitively) until thead will be finished. }
+ function WaitForTime( T: DWORD ): Integer;
+ {* Waits (T milliseconds) until thead will be finished. }
+
+ property Handle: THandle read FHandle;
+ {* Thread handle. It is created immediately when object is created
+ (using NewThread). }
+ property Suspended: Boolean read FSuspended;
+ {* True, if suspended. }
+ property Terminated: Boolean read FTerminated;
+ {* True, if terminated. }
+ property ThreadId: DWORD read FThreadId;
+ {* Thread id. }
+ property PriorityClass: Integer read GetPriorityCls write SetPriorityCls;
+ {* Thread priority class. One of following values: HIGH_PRIORITY_CLASS,
+ IDLE_PRIORITY_CLASS, NORMAL_PRIORITY_CLASS, REALTIME_PRIORITY_CLASS. }
+ property ThreadPriority: Integer read GetThrdPriority write SetThrdPriority;
+ {* Thread priority value. One of following values: THREAD_PRIORITY_ABOVE_NORMAL,
+ THREAD_PRIORITY_BELOW_NORMAL, THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_IDLE,
+ THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_TIME_CRITICAL. }
+ property Data : Pointer read FData write FData;
+ {* Custom data pointer. Use it for Youe own purpose. }
+
+ property OnExecute: TOnThreadExecute read FOnExecute write FOnExecute;
+ {* Is called, when Execute is starting. }
+ property OnSuspend: TObjectMethod read FOnSuspend write FOnSuspend;
+ {* Is called, when Suspend is performed. }
+ property OnResume: TOnEvent read FOnResume write FOnResume;
+ {* Is called, when resumed. }
+ procedure Synchronize( Method: TThreadMethod );
+ {* Call it to execute given method in main thread context. Applet variable
+ must exist for that time. }
+ procedure SynchronizeEx( Method: TThreadMethodEx; Param: Pointer );
+ {* Call it to execute given method in main thread context, with a given
+ parameter. Applet variable must exist for that time. Param must not be nil. }
+ {$IFDEF USE_CONSTRUCTORS}
+ constructor ThreadCreate;
+ constructor ThreadCreateEx( const Proc: TOnThreadExecute );
+ {$ENDIF USE_CONSTRUCTORS}
+
+ property AutoFree: Boolean read F_AutoFree write F_AutoFree;
+ {* Set this property to true to provide automatic destroying of thread
+ object when its executing is finished. }
+ property PriorityBoost: Boolean read GetPriorityBoost write SetPriorityBoost;
+ {* By default, priority boost is enabled for all threads. }
+ end;
+
+function NewThread: PThread;
+{* Creates thread object (always suspended). After creating, set event
+ OnExecute and perform Resume operation. }
+
+function NewThreadEx( const Proc: TOnThreadExecute ): PThread; stdcall;
+{* Creates thread object, assigns Proc to its OnExecute event and runs
+ it. }
+
+function NewThreadAutoFree( const Proc: TOnThreadExecute ): PThread;
+{* Creates thread object similar to NewThreadEx, but freeing automatically
+ when executing of such thread finished. Be sure that a thread is resumed
+ at least to provide its object keeper freeing. }
+
+{$IFDEF PSEUDO_THREADS}
+var MainThread: PThread;
+ PseudoThreadStackSize: DWORD = 1024 * 1024;
+ CreatingMainThread: Boolean;
+
+function WaitForSingleObject( hHandle: THandle; dwMilliseconds: DWORD ): DWORD; stdcall;
+function WaitForMultipleObjects( nCount: DWORD;
+ lpHandles: PHandle; fWaitAll: BOOL; dwMilliseconds: DWORD ): DWORD; stdcall;
+procedure Sleep( n: DWORD );
+{$ENDIF}
+
+{ ----------------------------------- streams -------------------------------- }
+
+{$ENDIF WIN_GDI}
+type
+ TMoveMethod = ( spBegin, spCurrent, spEnd );
+{$IFDEF WIN_GDI}
+type
+ {$IFDEF STREAM_LARGE64}
+ TStrmSize = Int64;
+ TStrmMove = Int64;
+ {$UNDEF ASM_STREAM}
+ {$UNDEF STREAM_COMPAT}
+ {$ELSE}
+ TStrmSize = DWORD;
+ TStrmMove = Integer;
+ {$IFDEF ASM_VERSION}
+ {$IFNDEF ASM_NOSTREAM}
+ {$DEFINE ASM_STREAM}
+ {$ENDIF}
+ {$ENDIF}
+ {$ENDIF}
+
+ PStream = ^TStream;
+
+ PStreamMethods = ^TStreamMethods;
+ TStreamMethods = Packed Record
+ fSeek: function( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod ): TStrmSize;
+ fGetSiz: function( Strm: PStream ): TStrmSize;
+ fSetSiz: procedure( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Value: TStrmSize );
+ fRead: function( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+ fWrite: function( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+ fClose: procedure( Strm: PStream );
+ fCustom: Pointer;
+ fWait: procedure( Strm: PStream );
+ end;
+
+ TStreamData = Packed Record
+ fHandle: THandle;
+ fCapacity, fSize, fPosition: TStrmSize;
+ fThread: PThread;
+ CASE Integer OF
+ 2: (
+ fStream1,
+ fStream2: PStream;
+ );
+ 3: (
+ fBaseStream: PStream;
+ fFromPos: TStrmSize;
+ );
+ 4: (
+ fBlkSize: Integer;
+ fBlocks: PList;
+ fJustWrittenBlkAddress: Pointer;
+ );
+ end;
+
+{ ---------------------------------------------------------------------
+ TStream - streaming objects incapsulation
+---------------------------------------------------------------------- }
+ TStream = object(TObj)
+ {* Simple stream object. Can be opened for file, or as memory stream (see
+ NewReadFileStream, NewWriteFileStream, NewMemoryStream, etc.). And, another
+ type of streaming object can be derived (without inheriting new object
+ type, just by writing another New...Stream method, which calls
+ _NewStream and pass methods record to it). }
+ protected
+ fPMethods: PStreamMethods;
+ fMethods: TStreamMethods;
+ fMemory: Pointer;
+ fData: TStreamData;
+ fParam1, fParam2: TStrmMove; // parameters to use in thread
+ fOnChangePos: TOnEvent;
+ function GetCapacity: TStrmSize;
+ procedure SetCapacity(const Value: TStrmSize);
+ function DoAsyncRead( Sender: PThread ): Integer;
+ function DoAsyncWrite( Sender: PThread ): Integer;
+ function DoAsyncSeek( Sender: PThread ): Integer;
+ protected
+ function GetFileStreamHandle: THandle;
+ procedure SetPosition(const Value: TStrmSize);
+ function GetPosition: TStrmSize;
+ function GetSize: TStrmSize;
+ procedure SetSize(const NewSize: TStrmSize);
+ destructor Destroy; virtual;
+ public
+ function Read(var Buffer; const Count: TStrmSize): TStrmSize;
+ {* Reads Count bytes from a stream. Returns number of bytes read. }
+ function Seek({$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize;
+ {* Allows to change current position or to obtain it. Property
+ Position uses this method both for get and set position. }
+ function Write(var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize;
+ {* Writes Count bytes from Buffer, starting from current position
+ in a stream. Returns how much bytes are written. }
+ function WriteVal( Value: DWORD; Count: DWORD ): DWORD;
+ {* Writes maximum 4 bytes of Value to a stream. Allows writing constants
+ easier than via Write. }
+ function WriteStr( S: AnsiString ): DWORD;
+ {* Writes string to the stream, not including ending #0. Exactly
+ Length( S ) characters are written. }
+ function WriteStrZ( S: AnsiString ): DWORD;
+ {* Writes string, adding #0. Number of bytes written is returned. }
+ {$IFDEF _D3orHigher}
+ function WriteWStrZ( S: KOLWideString ): DWORD;
+ {* Writes string, adding #0. Number of bytes written is returned. }
+ {$ENDIF}
+ function ReadStrZ: AnsiString;
+ {* Reads string, finished by #0. After reading, current position in
+ the stream is set to the byte, follows #0. }
+ {$IFDEF _D3orHigher}
+ function ReadWStrZ: KOLWideString;
+ {* Reads string, finished by #0. After reading, current position in
+ the stream is set to the byte, follows #0. }
+ {$ENDIF}
+ function ReadStr: AnsiString;
+ {* Reads string, finished by #13, #10 or #13#10 symbols. Terminating symbols
+ #13 and/or #10 are not added to the end of returned string though
+ stream positioned follow it. }
+ function ReadStrLen( Len: Integer ): AnsiString;
+ {* Reads string of the given length Len. }
+ function WriteStrEx(S: AnsiString): DWord;
+ {* Writes string S to stream, also saving its size for future use by
+ ReadStrEx* functions. Returns number of actually written characters. }
+ function ReadStrExVar(var S: AnsiString): DWord;
+ {* Reads string from stream and assigns it to S.
+ Returns number of actually read characters.
+ Note:
+ String must be written by using WriteStrEx function.
+ Return value is count of characters READ, not the length of string. }
+ function ReadStrEx: AnsiString;
+ {* Reads string from stream and returns it. }
+ function WriteStrPas( S: AnsiString ): DWORD;
+ {* Writes a string in Pascal short string format - 1 byte length, then string
+ itself without trailing #0 char. S parameter length should not exceed 255
+ chars, rest chars are truncated while writing. Total amount of bytes
+ written is returned. }
+ function ReadStrPas: AnsiString;
+ {* Reads 1 byte from a stream, then treat it as a length of following string
+ which is read and returned. A purpose of this function is reading strings
+ written using WriteStrPas. }
+ property Size: TStrmSize read GetSize write SetSize;
+ {* Returns stream size. For some custom streams, can be slow
+ operation, or even always return undefined value (-1 recommended). }
+ property Position: TStrmSize read GetPosition write SetPosition;
+ {* Current position. }
+
+ property Memory: Pointer read fMemory;
+ {* Only for memory stream. }
+ property Handle: THandle read GetFileStreamHandle;
+ {* Only for file stream. It is possible to check that Handle <>
+ INVALID_HANDLE_VALUE to ensure that file stream is created OK. }
+
+ //---------- for asynchronous operations (using thread - not tested):
+ procedure SeekAsync(MoveTo: TStrmMove; MoveMethod: TMoveMethod);
+ {* Changes current position asynchronously. To wait for finishing the
+ operation, use method Wait. }
+ procedure ReadAsync(var Buffer; Count: DWord);
+ {* Reads Count bytes from a stream asynchronously. To wait finishing the
+ operation, use method Wait. }
+ procedure WriteAsync(var Buffer; Count: DWord);
+ {* Writes Count bytes from Buffer, starting from current position
+ in a stream - asynchronously. To wait finishing the operation,
+ use method Wait. }
+ function Busy: Boolean;
+ {* Returns TRUE until finishing the last asynchronous operation
+ started by calling SeekAsync, ReadAsync, WriteAsync methods. }
+ procedure Wait;
+ {* Waits for finishing the last asynchronous operation. }
+
+ property Methods: PStreamMethods read fPMethods;
+ {* Pointer to TStreamMethods record. Useful to implement custom-defined
+ streams, which can access its fCustom field, or even to change
+ methods when necessary. }
+ property Data: TStreamData read fData;
+ {* Pointer to TStreamData record. Useful to implement custom-defined
+ streams, which can access Data fields directly when implemented. }
+
+ property Capacity: TStrmSize read GetCapacity write SetCapacity;
+ {* Amound of memory allocated for data (MemoryStream). }
+
+ procedure SaveToFile( const Filename: KOLString; const Start, CountSave: TStrmSize );
+ {* }
+
+ property OnChangePos: TOnEvent read fOnChangePos write fOnChangePos;
+ {* To allow using this event, create stream with special constructing
+ function like NewMemoryStreamWithEvent or NewReadFileStreamWithEvent,
+ or replace reading / writing methods to certain supporting OnChangePos
+ event. }
+ end;
+
+function _NewStream( const StreamMethods: TStreamMethods ): PStream;
+{* Use this method only to define your own stream type. See also declared
+ below (in KOL.pas) methods used to implement standard KOL streams. You can use it in
+ your code to create streams, which are partially based on standard
+ methods. }
+
+// Methods below are declared here to simplify creating your
+// own streams with some methods standard and some non-standard
+// together:
+function SeekFileStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+function GetSizeFileStream( Strm: PStream ): TStrmSize;
+function ReadFileStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+function ReadFileStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+var ReadFileStreamProc: function( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize
+ = ReadFileStream;
+
+function WriteFileStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+function WriteFileStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+function WriteFileStreamEOF( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+function WriteFileStreamEOFWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+procedure CloseFileStream( Strm: PStream );
+function SeekMemStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+function SeekMemStreamWithEvent( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+function GetSizeMemStream( Strm: PStream ): TStrmSize;
+
+var CapacityMask: DWORD = $4000 - 1; // must be 2**n-1
+procedure SetSizeMemStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize );
+function ReadMemStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+function ReadMemStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+function WriteMemStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+function WriteMemStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+procedure CloseMemStream( Strm: PStream );
+procedure SetSizeFileStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize );
+
+function ReadMemBlkStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+function SeekMemBlkStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+function WriteMemBlkStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+procedure ResizeMemBlkStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize );
+procedure FreeMemBlkStream( Strm: PStream );
+
+function SeekConcatStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+function GetSizeConcatStream( Strm: PStream ): TStrmSize;
+procedure SetSizeConcatStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize );
+function ReadConcatStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+function WriteConcatStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+procedure CloseConcatStream( Strm: PStream );
+
+function SeekSubStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+function GetSizeSubStream( Strm: PStream ): TStrmSize;
+procedure SetSizeSubStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize );
+function ReadSubStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+function WriteSubStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+procedure CloseSubStream( Strm: PStream );
+
+procedure DummyCloseStream( Strm: PStream );
+
+function DummyReadWrite( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+procedure DummySetSize( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Value: TStrmSize );
+procedure DummyStreamProc(Strm: PStream);
+
+function NewFileStream( const FileName: KOLString; Options: DWORD ): PStream;
+{* Creates file stream for read and write. Exact set of open attributes
+ should be passed through Options parameter (see FileCreate where those
+ flags are listed). }
+
+function NewFileStreamWithEvent( const FileName: KOLString; Options: DWORD ): PStream;
+{* Creates file stream for read and write. Exact set of open attributes
+ should be passed through Options parameter (see FileCreate where those
+ flags are listed). Also, resulting stream is supporting OnChangePos event. }
+
+function NewReadFileStream( const FileName: KOLString ): PStream;
+{* Creates file stream for read only. }
+
+function NewReadFileStreamWithEvent( const FileName: KOLString ): PStream;
+{* Creates file stream for read only, supporting OnChangePos event. }
+
+function NewWriteFileStream( const FileName: KOLString ): PStream;
+{* Creates file stream for write only. Truncating of file (if needed)
+ is provided automatically. }
+
+function NewWriteFileStreamWithEvent( const FileName: KOLString ): PStream;
+{* Creates file stream for write only. Truncating of file (if needed)
+ is provided automatically. Created stream supports OnChangePos event. }
+
+function NewReadWriteFileStream( const FileName: KOLString ): PStream;
+{* Creates stream for read and write file. To truncate file, if it is
+ necessary, change Size property. }
+
+{$IFDEF _D3orHigher}
+function NewReadFileStreamW( const FileName: KOLWideString ): PStream;
+{* Creates file stream for read only. }
+
+function NewWriteFileStreamW( const FileName: KOLWideString ): PStream;
+{* Creates file stream for write only. Truncating of file (if needed)
+ is provided automatically. }
+
+function NewReadWriteFileStreamW( const FileName: KOLWideString ): PStream;
+{* Creates stream for read and write file. To truncate file, if it is
+ necessary, change Size property. }
+{$ENDIF}
+
+function NewExFileStream( F: HFile ): PStream;
+{* Creates read only stream to read from opened file or pipe from the current
+ position.
+ When stream is destroyed, file handle still not closed (your code should do
+ this) and file position is not changed (after the last read operation). }
+
+function NewMemoryStream: PStream;
+{* Creates memory stream (read and write). }
+
+function NewMemoryStreamWithEvent: PStream;
+{* Creates memory stream (read and write). Created stream support OnChangePos
+ event. }
+
+function NewExMemoryStream( ExistingMem: Pointer; Size: DWORD ): PStream;
+{* Creates memory stream on base of existing memory. It is not possible
+ to write out of top bound given by Size (i.e. memory can not be resized,
+ or reallocated. When stream object is destroyed this memory is not freed. }
+
+function NewMemBlkStream( BlkSize: Integer ): PStream;
+{* Creates memory stream which consists from blocks of given size. Contrary to
+ a memory stream, contents of the blocks stream should not be accessed
+ directly via fMemory but therefore it is possible to access its parts by
+ portions written to blocks still those were written contigously. To do so,
+ get an address of just written portion for further usage via field
+ fJustWrittenBlkAddress. It is guarantee that blocks of memory allocated
+ during write process never are relocated until destruction the stream. }
+
+function NewMemBlkStream_WriteOnly( BlkSize: Integer ): PStream;
+{* Same as NewMemoryStream}
+
+function NewConcatStream( Stream1, Stream2: PStream ): PStream;
+{* Creates a stream which is a concatenation of two source stream. After
+ the call, both source streams are belonging to the resulting stream and these
+ will be destroyed together with the resulting stream. (So forget about it).
+
+ After the call, first stream will not be changed in size via methods of
+ concatenated stream (and it is not recommended to use further Stream1 and
+ Stream2 methods too). But Stream2 can still be increased, if it allows doing
+ so when some data are appended or Size of resulting stream is changed (but
+ not less then Stream1.Size).
+
+ Nature and physical location of Stream1 and Stream2 are not important and
+ can be absolutely different. But it is supposed that both streams are not
+ compressed and its Size is known always and Seek operation is valid.
+
+ This function accepts recursive (multi-level) usage: resulting concatenation
+ stream can be used as a left or right parameter to create another concatenation
+ stream later, so it is possible to build a tree of streams concatenated,
+ concatenating this way several different streams and use it as a single
+ data streaming object.
+}
+
+function NewSubStream( BaseStream: PStream; const FromPos, Size: TStrmSize ): PStream;
+{* Creates a stream which is a subpart of BaseStream passes, starting from
+ FromPos and with given Size. Like in function NewConcatStream, passes
+ BaseStream become owned by newly created sub-stream object, and will be
+ destroyed automatically together with a sub-stream.
+
+ If you want to provide more long life time for a base stream (e.g. if you
+ plan to use it after a sub-stream based on it is destroyed), use method
+ RefInc for base stream once to prevent it from destroying when the sub-stream
+ is destroyed.
+
+ Note: be careful and avoid direct calling methods and properties of the base
+ stream, while you have a sub-stream created on base it, since the sub-stream
+ actually redirects all the requests to the parent base stream.
+
+ Sub-stream accepts setting Size to greater value later, and if some data
+ are written to it, it is written actually to the base stream, and when it
+ is written beyond the end position, this will increase size of the base
+ stream too (and if it is a file stream, this also will increase size of the
+ file on which the base stream was created).
+
+ This function accepts recursive (multi-level) usage: it is possible to create
+ later another sub-stream on base of existing sub-stream, still it is actully
+ can be treated as usual stream.
+}
+
+function Stream2Stream( Dst, Src: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+{* Copies Count (or less, if the rest of Src is not sufficiently long)
+ bytes from Src to Dst, but with optimizing in cases, when Src or/and
+ Dst are memory streams (intermediate buffer is not allocated). }
+function Stream2StreamEx( Dst, Src: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+{* Copies Count bytes from Src to Dst, but without any optimization.
+ Unlike Stream2Stream function, it can be applied to very large streams.
+ See also Stream2StreamExBufSz. }
+function Stream2StreamExBufSz( Dst, Src: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize; BufSz: DWORD ): TStrmSize;
+{* Copies Count bytes from Src to Dst using buffer of given size, but without
+ other optimizations.
+ Unlike Stream2Stream function, it can be applied to very large streams }
+function Resource2Stream( DestStrm : PStream; Inst : HInst;
+ ResName : PKOLChar; ResType : PKOLChar ): Integer;
+{* Loads given resource to DestStrm. Useful for non-standard
+ resources to load it into memory (use memory stream for such
+ purpose). Use one of following resource types to pass as ResType:
+ |<pre>
+RT_ACCELERATOR Accelerator table
+RT_ANICURSOR Animated cursor
+RT_ANIICON Animated icon
+RT_BITMAP Bitmap resource
+RT_CURSOR Hardware-dependent cursor resource
+RT_DIALOG Dialog box
+RT_FONT Font resource
+RT_FONTDIR Font directory resource
+RT_GROUP_CURSOR Hardware-independent cursor resource
+RT_GROUP_ICON Hardware-independent icon resource
+RT_ICON Hardware-dependent icon resource
+RT_MENU Menu resource
+RT_MESSAGETABLE Message-table entry
+RT_RCDATA Application-defined resource (raw data)
+RT_STRING String-table entry
+RT_VERSION Version resource
+ |</pre>
+ |<br>For example:
+ !var MemStrm: PStream;
+ ! JpgObj: PJpeg;
+ !......
+ ! MemStrm := NewMemoryStream;
+ ! JpgObj := NewJpeg;
+ !......
+ ! Resource2Stream( MemStrm, hInstance, 'MYJPEG', RT_RCDATA );
+ ! MemStrm.Position := 0;
+ ! JpgObj.LoadFromStream( MemStrm );
+ ! MemStrm.Free;
+ !......
+ }
+{$ENDIF WIN_GDI}
+
+{ ------------------------- string list objects ------------------------------ }
+
+type
+ TCompareStrListFun = function( const S1, S2: PAnsiChar ): Integer;
+ TCompareEvent = function (const Data: Pointer; const e1,e2 : Dword) : Integer;
+ {* Event type to define comparison function between two elements of an array.
+ This event handler must return negative or positive value (correspondently
+ for cases e1<e2 and e2>e2), or 0 if items are equal. Items are enumerated
+ from 0 to uNElem. }
+ TSwapEvent = procedure (const Data : Pointer; const e1,e2 : Dword);
+ {* Event type to define swap procedure which is swapping two elements of the
+ sorting data. }
+ TCompareArrayEvent = function(e1,e2 : DWord) : Integer;
+ {* 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
+ itselves. }
+
+ PStrList = ^TStrList;
+{ ---------------------------------------------------------------------
+ TStrList - string list
+---------------------------------------------------------------------- }
+ TStrList = object(TObj)
+ {* Easy string list implementation (non-visual, just to store
+ string data). It is well improved and has very high performance
+ allowing to work fast with huge text files (more then megabyte
+ of text data).
+ |
+ Please note that #0 charaster if stored in string lines, will cut it
+ preventing reading the rest of a line. Be careful, if your data
+ contain such characters. }
+ protected
+ procedure Init; virtual;
+ protected
+ fList: PList;
+ fCount: Integer;
+ fCaseSensitiveSort: Boolean;
+ fAnsiSort: Boolean;
+ fTextBuf: PAnsiChar;
+ fTextSiz: DWORD;
+ fCompareStrListFun: TCompareStrListFun;
+ function GetPChars(Idx: Integer): PAnsiChar;
+ //procedure AddTextBuf( Src: PAnsiChar; Len: DWORD );
+ protected
+ function Get(Idx: integer): Ansistring;
+ function GetTextStr: Ansistring;
+ procedure Put(Idx: integer; const Value: Ansistring);
+ procedure SetTextStr(const Value: Ansistring);
+ destructor Destroy; virtual;
+ protected
+ // by Dod:
+ procedure SetValue(const AName, Value: Ansistring);
+ function GetValue(const AName: Ansistring): Ansistring;
+ public
+ // by Dod:
+ function IndexOfName(AName: Ansistring): Integer;
+ {* by Dod. Returns index of line starting like Name=... }
+ function IndexOfName_NoCase(AName: Ansistring): Integer;
+ property Values[const AName: Ansistring]: Ansistring read GetValue write SetValue;
+ {* by Dod. Returns right side of a line starting like Name=... }
+ public
+ function Add(const S: Ansistring): integer;
+ {* Adds a string to list. }
+ procedure AddStrings(Strings: PStrList);
+ {* Merges string list with given one. Very fast - more preferrable to
+ use than any loop with calling Add method. }
+ procedure Assign(Strings: PStrList);
+ {* Fills string list with strings from other one. The same as AddStrings,
+ but Clear is called first. }
+ procedure Clear;
+ {* Makes string list empty. }
+ procedure Delete(Idx: integer);
+ {* Deletes string with given index (it *must* exist). }
+ procedure DeleteLast;
+ {* Deletes the last string (it *must* exist). }
+ function IndexOf(const S: AnsiString): integer;
+ {* Returns index of first string, equal to given one. }
+ function IndexOf_NoCase(const S: Ansistring): integer;
+ {* Returns index of first string, equal to given one (while comparing it
+ without case sensitivity). }
+ function IndexOfStrL_NoCase( Str: PAnsiChar; L: Integer ): integer;
+ {* Returns index of first string, equal to given one (while comparing it
+ without case sensitivity). }
+ function Find(const S: AnsiString; var Index: Integer): Boolean;
+ {* Returns Index of the string, equal or greater to given pattern, but
+ works only for sorted TStrList object. Returns TRUE if exact string found,
+ otherwise nearest (greater then a pattern) string index is returned,
+ and the result is FALSE. And in such _case Index is returned negated
+ when the S string is less then the string found. }
+ 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. }
+ procedure Insert(Idx: integer; const S: Ansistring);
+ {* Inserts string before one with given index. }
+ procedure Move(CurIndex, NewIndex: integer);
+ {* Moves string to another location. }
+ procedure SetText(const S: Ansistring; Append2List: Boolean);
+ {* Allows to set strings of string list from given string (in which
+ strings are separated by $0D,$0A or $0D characters). Text must not
+ contain #0 characters. Works very fast. This method is used in
+ all others, working with text arrays (LoadFromFile, MergeFromFile,
+ Assign, AddStrings). }
+ procedure SetUnixText( const S: AnsiString; Append2List: Boolean );
+ {* Allows to assign UNIX-style text (with #10 as string separator). }
+ property Count: integer read fCount;
+ {* Number of strings in a string list. }
+ property Items[Idx: integer]: Ansistring read Get write Put; default;
+ {* Strings array items. If item does not exist, empty string is returned.
+ But for assign to property, string with given index *must* exist. }
+ property ItemPtrs[ Idx: Integer ]: PAnsiChar read GetPChars;
+ {* Fast access to item strings as PChars. }
+ function Last: AnsiString;
+ {* Last item (or '', if string list is empty). }
+ property Text: Ansistring read GetTextStr write SetTextStr;
+ {* Content of string list as a single string (where strings are separated
+ by characters $0D,$0A). }
+ procedure Swap( Idx1, Idx2 : Integer );
+ {* Swaps to strings with given indeces. }
+ procedure Sort( CaseSensitive: Boolean );
+ {* Call it to sort string list. }
+ procedure AnsiSort( CaseSensitive: Boolean );
+ {* Call it to sort ANSI string list. }
+ procedure SortEx(const CompareFun: TCompareEvent); // by Dufa
+ {* Call it to sort via your own compare procedure }
+ 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 LineName[ Idx: Integer ]: Ansistring read GetLineName write SetLineName;
+ property LineValue[ Idx: Integer ]: Ansistring read GetLineValue write SetLineValue;
+ property NameDelimiter: AnsiChar read fNameDelim write fNameDelim;
+ function Join( const sep: AnsiString ): AnsiString;
+ {* by Sergey Shishmintzev }
+ {$IFDEF WIN_GDI}
+ function LoadFromFile(const FileName: KOLString): Boolean;
+ {* Loads string list from a file. (If file does not exist, nothing
+ happens). Very fast even for huge text files. }
+ procedure LoadFromStream(Stream: PStream; Append2List: Boolean);
+ {* Loads string list from a stream (from current position to the end of
+ a stream). Very fast even for huge text. }
+ procedure MergeFromFile(const FileName: KOLString);
+ {* Merges string list with strings in a file. Fast. }
+ function SaveToFile(const FileName: KOLString): Boolean;
+ {* Stores string list to a file. }
+ procedure SaveToStream(Stream: PStream);
+ {* Saves string list to a stream (from current position). }
+ function AppendToFile(const FileName: KOLString): Boolean;
+ {* Appends strings of string list to the end of a file. }
+ {$ENDIF WIN_GDI}
+ procedure OptimizeForRead;
+ end;
+
+var DefaultNameDelimiter: AnsiChar = '=';
+ ThsSeparator: KOLChar = ',';
+
+function NewStrList: PStrList;
+{* Creates string list object. }
+
+{$IFNDEF _FPC}
+function WStrLen( W: PWideChar ): Integer;
+{* Returns Length of null-terminated Unicode string. }
+
+{$IFDEF _D3orHigher}
+function UTF8_2KOLWideString( const s: AnsiString ): KOLWideString;
+{$ENDIF}
+{$ENDIF _FPC}
+
+type
+ PStrListEx = ^TStrListEx;
+
+ TStrListEx = object( TStrList )
+ {* Extended string list object. Has additional capability to associate
+ numbers or objects with string list items. }
+ protected
+ FObjects: PList;
+ function GetObjects(Idx: Integer): DWORD;
+ function GetObjectCount: Integer;
+ procedure SetObjects(Idx: Integer; const Value: DWORD);
+ procedure Init; virtual;
+ procedure ProvideObjCapacity( NewCap: Integer );
+ public
+ destructor Destroy; virtual;
+ {* }
+ property Objects[ Idx: Integer ]: DWORD read GetObjects write SetObjects;
+ {* Objects are just 32-bit values. You can treat and use it as pointers to
+ any other data in the memory. But it is your task to free allocated
+ memory in such case therefore.
+ |<br>
+ If the last item of a string list is deleted vis DeleteLast method (but
+ not via Delete method), it's object still is preserved. As well, it is
+ possible to set Objects[idx] for idx >= Count.
+ To get know object's count, rather then strings count, use ObjectCount
+ property. }
+ property ObjectCount: Integer read GetObjectCount;
+ {* Returns number of objects available. This value can differ from Count
+ after some operations: objects are stored in the independant list and
+ only synchronization is provided while using methods Delete, Insert,
+ Add, AddObject, InsertObject while changing the list. }
+ procedure AddStrings(Strings: PStrListEx);
+ {* Merges string list with given one. Very fast - more preferrable to
+ use than any loop with calling Add method. }
+ procedure Assign(Strings: PStrListEx);
+ {* Fills string list with strings from other one. The same as AddStrings,
+ but Clear is called first. }
+ procedure Clear;
+ {* Makes string list empty. }
+ procedure Delete(Idx: integer);
+ {* Deletes string with given index (it *must* exist). }
+ procedure DeleteLast;
+ {* Deletes the last string and correspondent object in the list. }
+ procedure Move(CurIndex, NewIndex: integer);
+ {* Moves string to another location. }
+ procedure Swap( Idx1, Idx2 : Integer );
+ {* Swaps to strings with given indeces. }
+ procedure Sort( CaseSensitive: Boolean );
+ {* Call it to sort string list. }
+ procedure AnsiSort( CaseSensitive: Boolean );
+ {* Call it to sort ANSI string list. }
+ function LastObj: DWORD;
+ {* Object assotiated with the last string. }
+ function AddObject( const S: AnsiString; Obj: DWORD ): Integer;
+ {* Adds a string and associates given number with it. Index of the item added
+ is returned. }
+ procedure InsertObject( Before: Integer; const S: AnsiString; Obj: DWORD );
+ {* Inserts a string together with object associated. }
+ function IndexOfObj( Obj: Pointer ): Integer;
+ {* Returns an index of a string associated with the object passed as a
+ parameter. If there are no such strings, -1 is returned. }
+ procedure OptimizeForRead;
+ end;
+
+function NewStrListEx: PStrListEx;
+{* Creates extended string list object. }
+
+{$IFNDEF _FPC}
+procedure WStrCopy( Dest, Src: PWideChar );
+{* Copies null-terminated Unicode string (terminated null also copied). }
+procedure WStrLCopy( Dest, Src: PWideChar; MaxLen: Integer );
+{* Copies null-terminated Unicode string (terminated null also copied). }
+function WStrCmp( W1, W2: PWideChar ): Integer;
+{* Compares two null-terminated Unicode strings. }
+{$IFDEF _D3orHigher}
+function WStrCmp_NoCase( W1, W2: PWideChar ): Integer;
+{* Compares two null-terminated Unicode strings. }
+{$ENDIF}
+{$ENDIF _FPC}
+
+{$IFDEF WIN_GDI}
+{$IFNDEF _D2} //------------------ WideString is not supported in D2 -----------
+
+type
+ PWStrList = ^TWstrList;
+ {* }
+ TWStrList = object( TObj )
+ {* String list to store Unicode (null-terminated) strings. }
+ protected
+ function GetCount: Integer;
+ function GetItems(Idx: Integer): KOLWideString;
+ procedure SetItems(Idx: Integer; const Value: KOLWideString);
+ function GetPtrs(Idx: Integer): PWideChar;
+ function GetText: KOLWideString;
+ protected
+ fList: PList;
+ fText: PWideChar;
+ fTextBufSz: Integer;
+ fTmp1, fTmp2: KOLWideString;
+ procedure Init; virtual;
+ public
+ procedure SetText(const Value: KOLWideString);
+ {* See also TStrList.SetText }
+ destructor Destroy; virtual;
+ {* }
+ procedure Clear;
+ {* See also TStrList.Clear }
+ property Items[ Idx: Integer ]: KOLWideString read GetItems write SetItems;
+ {* See also TStrList.Items }
+ property ItemPtrs[ Idx: Integer ]: PWideChar read GetPtrs;
+ {* See also TStrList.ItemPtrs }
+ property Count: Integer read GetCount;
+ {* See also TStrList.Count }
+ function Add( const W: KOLWideString ): Integer;
+ {* See also TStrList.Add }
+ procedure Insert( Idx: Integer; const W: KOLWideString );
+ {* See also TStrList.Insert }
+ procedure Delete( Idx: Integer );
+ {* See also TStrList.Delete }
+ property Text: KOLWideString read GetText write SetText;
+ {* See also TStrList.Text }
+ procedure AddWStrings( WL: PWStrList );
+ {* See also TStrList.AddStrings }
+ procedure Assign( WL: PWStrList );
+ {* See also TStrList.Assign }
+ function LoadFromFile( const Filename: KOLString ): Boolean;
+ {* See also TStrList.LoadFromFile }
+ procedure LoadFromStream( Strm: PStream; AppendToList: Boolean );
+ {* See also TStrList.LoadFromStream }
+ function MergeFromFile( const Filename: KOLString ): Boolean;
+ {* See also TStrList.MergeFromFile }
+ procedure MergeFromStream( Strm: PStream );
+ {* See also TStrList.MergeFromStream }
+ function SaveToFile( const Filename: KOLString ): Boolean;
+ {* See also TStrList.SaveToFile }
+ procedure SaveToStream( Strm: PStream );
+ {* See also TStrList.SaveToStream }
+ function AppendToFile( const Filename: KOLString ): Boolean;
+ {* See also TStrList.AppendToFile }
+ procedure Swap( Idx1, Idx2: Integer );
+ {* See also TStrList.Swap }
+ procedure Sort( CaseSensitive: Boolean );
+ {* See also TStrList.Sort }
+ procedure Move( IdxOld, IdxNew: Integer );
+ {* See also TStrList.Move }
+ function IndexOf( const s: KOLWideString ): Integer;
+ {* }
+ function IndexOf_NoCase( const s: KOLWideString ): Integer;
+ {* }
+ function Last: KOLWideString;
+ {* }
+ procedure Put(Idx: integer; const Value: KOLWideString);
+ {* +azsd for TBButton }
+ protected // by Alexander Pravdin:
+ fNameDelim: WideChar;
+ function GetLineName( Idx: Integer ): KOLWideString;
+ procedure SetLineName( Idx: Integer; const NV: KOLWideString );
+ function GetLineValue(Idx: Integer): KOLWideString;
+ procedure SetLineValue(Idx: Integer; const Value: KOLWideString);
+ public
+ property LineName[ Idx: Integer ]: KOLWideString read GetLineName write SetLineName;
+ property LineValue[ Idx: Integer ]: KOLWideString read GetLineValue write SetLineValue;
+ property NameDelimiter: WideChar read fNameDelim write fNameDelim;
+ procedure OptimizeForRead;
+ protected // ++++++++++++++ by rdnks
+ procedure SetValue(const AName, Value: KOLWideString);
+ function GetValue(const AName: KOLWideString): KOLWideString;
+ public
+ function IndexOfName(AName: KOLWideString): Integer;
+ property Values[const AName: KOLWideString]: KOLWideString read GetValue write SetValue;
+ end;
+
+ PWStrListEx = ^TWStrListEx;
+
+ TWStrListEx = object( TWStrList )
+ {* Extended Unicode string list (with Objects). }
+ protected
+ function GetObjects(Idx: Integer): DWORD;
+ procedure SetObjects(Idx: Integer; const Value: DWORD);
+ procedure ProvideObjectsCapacity( NewCap: Integer );
+ protected
+ fObjects: PList;
+ procedure Init; virtual;
+ public
+ destructor Destroy; virtual;
+ {* }
+ property Objects[ Idx: Integer ]: DWORD read GetObjects write SetObjects;
+ {* }
+ procedure AddWStrings( WL: PWStrListEx );
+ {* }
+ procedure Assign( WL: PWStrListEx );
+ {* }
+ procedure Clear;
+ {* }
+ procedure Delete( Idx: Integer );
+ {* }
+ procedure Move( IdxOld, IdxNew: Integer );
+ {* }
+ procedure Swap( Idx1, Idx2: Integer );
+ {* See also TStrList.Swap }
+ procedure Sort( CaseSensitive: Boolean );
+ {* See also TStrList.Sort }
+ function AddObject( const S: KOLWideString; Obj: DWORD ): Integer;
+ {* Adds a string and associates given number with it. Index of the item added
+ is returned. }
+ procedure InsertObject( Before: Integer; const S: KOLWideString; Obj: DWORD );
+ {* Inserts a string together with object associated. }
+ function IndexOfObj( Obj: Pointer ): Integer;
+ {* Returns an index of a string associated with the object passed as a
+ parameter. If there are no such strings, -1 is returned. }
+ procedure OptimizeForRead;
+ end;
+
+function NewWStrList: PWStrList;
+{* Creates new TWStrList object and returns a pointer to it. }
+
+function NewWStrListEx: PWStrListEx;
+{* Creates new TWStrListEx objects and returns a pointer to it. }
+
+{$ENDIF not _D2}
+{$ENDIF WIN_GDI}
+
+{$IFDEF UNICODE_CTRLS}
+{$IFNDEF _D2}
+type TKOLStrList = TWStrList;
+ PKOLStrList = PWStrList;
+ TKOLStrListEx = TWStrListEx;
+ PKOLStrListEx = PWStrListEx;
+{$ELSE}
+type TKOLStrList = TStrList;
+ PKOLStrList = PStrList;
+ TKOLStrListEx = TStrListEx;
+ PKOLStrListEx = PStrListEx;
+{$ENDIF}
+{$ELSE}
+type TKOLStrList = TStrList;
+ PKOLStrList = PStrList;
+ TKOLStrListEx = TStrListEx;
+ PKOLStrListEx = PStrListEx;
+{$ENDIF}
+
+function NewKOLStrList: PKOLStrList;
+function NewKOLStrListEx: PKOLStrListEx;
+
+{$IFDEF WIN}
+function GetFileList(const dir: KOLString): PKOLStrList;
+{* By Alexander Shakhaylo. Returns list of file names of the given directory. }
+{$ENDIF WIN}
+
+////////////////////////////////////////////////////////////////////////////////
+// GRAPHIC OBJECTS //
+////////////////////////////////////////////////////////////////////////////////
+{
+ It is very important, that the most of code, implementing graphic objets
+ from this section, is included into executable ONLY if really accessed in your
+ project directly (e.g., if Font or Brush properies of a control are accessed
+ or changed).
+}
+type
+ TColor = Integer;
+const
+ clScrollBar = TColor(COLOR_SCROLLBAR or $80000000);
+ clBackground = TColor(COLOR_BACKGROUND or $80000000);
+ clActiveCaption = TColor(COLOR_ACTIVECAPTION or $80000000);
+ clInactiveCaption = TColor(COLOR_INACTIVECAPTION or $80000000);
+ clMenu = TColor(COLOR_MENU or $80000000);
+ clWindow = TColor(COLOR_WINDOW or $80000000);
+ clWindowFrame = TColor(COLOR_WINDOWFRAME or $80000000);
+ clMenuText = TColor(COLOR_MENUTEXT or $80000000);
+ clWindowText = TColor(COLOR_WINDOWTEXT or $80000000);
+ clCaptionText = TColor(COLOR_CAPTIONTEXT or $80000000);
+ clActiveBorder = TColor(COLOR_ACTIVEBORDER or $80000000);
+ clInactiveBorder = TColor(COLOR_INACTIVEBORDER or $80000000);
+ clAppWorkSpace = TColor(COLOR_APPWORKSPACE or $80000000);
+ clHighlight = TColor(COLOR_HIGHLIGHT or $80000000);
+ clHighlightText = TColor(COLOR_HIGHLIGHTTEXT or $80000000);
+ clBtnFace = TColor(COLOR_BTNFACE or $80000000);
+ clBtnShadow = TColor(COLOR_BTNSHADOW or $80000000);
+ clGrayText = TColor(COLOR_GRAYTEXT or $80000000);
+ clGreyText = TColor(COLOR_GRAYTEXT or $80000000);
+ clBtnText = TColor(COLOR_BTNTEXT or $80000000);
+ clInactiveCaptionText = TColor(COLOR_INACTIVECAPTIONTEXT or $80000000);
+ clBtnHighlight = TColor(COLOR_BTNHIGHLIGHT or $80000000);
+ cl3DDkShadow = TColor(COLOR_3DDKSHADOW or $80000000);
+ cl3DLight = TColor(COLOR_3DLIGHT or $80000000);
+ clInfoText = TColor(COLOR_INFOTEXT or $80000000);
+ clInfoBk = TColor(COLOR_INFOBK or $80000000);
+
+ clBlack = TColor($000000);
+ clMaroon = TColor($000080);
+ clGreen = TColor($008000);
+ clOlive = TColor($008080);
+ clNavy = TColor($800000);
+ clPurple = TColor($800080);
+ clTeal = TColor($808000);
+ clGray = TColor($808080);
+ clGrey = TColor($808080);
+ clSilver = TColor($C0C0C0);
+ clRed = TColor($0000FF);
+ clLime = TColor($00FF00);
+ clYellow = TColor($00FFFF);
+ clBlue = TColor($FF0000);
+ clFuchsia = TColor($FF00FF);
+ clAqua = TColor($FFFF00);
+ clLtGray = TColor($C0C0C0);
+ clLtGrey = TColor($C0C0C0);
+ clDkGray = TColor($808080);
+ clDkGrey = TColor($808080);
+ clWhite = TColor($FFFFFF);
+ clNone = TColor($1FFFFFFF);
+ clDefault = TColor($20000000);
+
+ clMoneyGreen = TColor($C0DCC0);
+ clSkyBlue = TColor($F0CAA6);
+ clCream = TColor($F0FBFF);
+ clMedGray = TColor($A4A0A0);
+ clMedGrey = TColor($A4A0A0);
+ clOrange = TColor( $3399FF );
+ clBrown = TColor( $505080 );
+ clDkBrown = TColor( $282840 );
+
+ clGRushHiLight = TColor( $F3706C );
+ clGRushLighten = TColor( $F1EEDF );
+ clGRushLight = TColor( $e1cebf );
+ clGRushNormal = TColor( $D1beaf );
+ clGRushMedium = TColor( $b6bFc6 );
+ clGRushDark = TColor( $9EACB4 );
+
+const
+ go_Color = 0;
+ go_FontHeight = 4;
+ go_FontWidth = 8;
+ go_FontEscapement = 12;
+ go_FontOrientation = 16;
+ go_FontWeight = 20;
+ go_FontItalic = 24;
+ go_FontUnderline = 25;
+ go_FontStrikeOut = 26;
+ go_FontCharSet = 27;
+ go_FontOutPrecision = 28;
+ go_FontClipPrecision = 29;
+ go_FontQuality = 30;
+ go_FontPitch = 31;
+ go_FontName = 32;
+ go_BrushBitmap = 4;
+ go_BrushStyle = 8;
+ go_BrushLineColor = 9;
+ go_PenBrushBitmap = 4;
+ go_PenBrushStyle = 8;
+ go_PenStyle = 9;
+ go_PenWidth = 10;
+ go_PenMode = 14;
+ go_PenGeometric = 15;
+ go_PenEndCap = 16;
+ go_PenJoin = 17;
+
+type
+ TGraphicToolType = ( gttBrush, gttFont, gttPen );
+ {* Graphic object types, mainly for internal use. }
+
+ PGraphicTool = ^TGraphicTool;
+ {* }
+ TOnGraphicChange = procedure ( Sender: PGraphicTool ) of object;
+ {* An event mainly for internal use. }
+
+ TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,
+ bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);
+ {* Available brush styles. }
+
+ TFontStyles = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
+ {* Available font styles. }
+ TFontStyle = set of TFontStyles;
+ {* Font style is representing as a set of XFontStyles. }
+ TFontPitch = (fpDefault, fpFixed, fpVariable);
+ {* Availabe font pitch values. }
+ TFontName = type string;
+ {* Font name is represented as a string. }
+ TFontCharset = 0..255;
+ {* Font charset is represented by number from 0 to 255. }
+ TFontQuality = (fqDefault, fqDraft, fqProof, fqNonAntialiased, fqAntialiased
+ , fqClearType);
+ {* Font quality. }
+
+ TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear,
+ psInsideFrame);
+ {* Available pen styles. For more info see Delphi or Win32 help files. }
+ TPenMode = (pmBlack, pmNotMerge, pmMaskNotPen, pmNotCopy, pmMaskPenNot,
+ pmNot, pmXor, pmNotMask, pmMask, pmNotXor, pmNop, pmMergePenNot,
+ pmCopy, pmMergeNotPen, pmMerge, pmWhite);
+ {* Available pen modes. For more info see Delphi or Win32 help files. }
+ TPenEndCap = (pecRound, pecSquare, pecFlat);
+ {* Avalable (for geometric pen) end cap styles. }
+ TPenJoin = (pjRound, pjBevel, pjMiter);
+ {* Available (for geometric pen) join styles. }
+
+ TGDIFont = packed record
+ Height: Integer;
+ Width: Integer;
+ Escapement: Integer;
+ Orientation: Integer;
+ Weight: Integer;
+ Italic: Boolean;
+ Underline: Boolean;
+ StrikeOut: Boolean;
+ CharSet: TFontCharset;
+ OutPrecision: Byte;
+ ClipPrecision: Byte;
+ Quality: TFontQuality;
+ Pitch: TFontPitch;
+ Name: array[0..LF_FACESIZE - 1] of KOLChar;
+ end;
+
+ TGDIBrush = packed record
+ Bitmap: HBitmap;
+ Style: TBrushStyle;
+ LineColor: TColor;
+ end;
+
+ TGDIPen = packed record
+ BrushBitmap: HBitmap;
+ BrushStyle: TBrushStyle;
+ Style: TPenStyle;
+ Width: Integer;
+ Mode: TPenMode;
+ Geometric: Boolean;
+ EndCap: TPenEndCap;
+ Join: TPenJoin;
+ end;
+
+ TGDIToolData = packed record
+ Color: TColor;
+ case Integer of
+ 1: (Font: TGDIFont);
+ 2: (Pen: TGDIPen);
+ 3: (Brush: TGDIBrush);
+ end;
+
+ TNewGraphicTool = function: PGraphicTool;
+
+{ ---------------------------------------------------------------------
+ TGraphicTool - object to implement GDI-tools (brush, pen, font)
+---------------------------------------------------------------------- }
+ TGraphicTool = object( TObj )
+ {* Incapsulates all GDI objects: Pen, Brush and Font. }
+ protected
+ fType: TGraphicToolType;
+ {$IFDEF GDI}
+ fHandle: THandle;
+ fParentGDITool: PGraphicTool;
+ {$ENDIF GDI}
+ fColorRGB: TColor;
+ fOnGTChange: TOnGraphicChange;
+ fData: TGDIToolData;
+ fNewProc: TNewGraphicTool;
+ {$IFDEF GDI}
+ fMakeHandleProc: function( Self_: PGraphicTool ): THandle;
+ {$ENDIF GDI}
+ procedure SetInt( const Index: Integer; Value: Integer );
+ function GetInt( const Index: Integer ): Integer;
+ procedure SetColor( Value: TColor );
+ {$IFDEF GDI}
+ function GetBrushBitmap: HBitmap; // for BCB only
+ procedure SetBrushBitmap(const Value: HBitmap);
+ function GetBrushStyle: TBrushStyle; // for BCB only
+ {$ENDIF GDI}
+ procedure SetBrushStyle(const Value: TBrushStyle);
+ function GetFontName: KOLString;
+ procedure SetFontName(const Value: KOLString);
+ function GetFontStyle: TFontStyle;
+ procedure SetFontStyle(const Value: TFontStyle);
+ function GetFontWeight: Integer; // for BCB only
+ procedure SetFontWeight(const Value: Integer);
+ {$IFDEF GDI}
+ function GetFontCharset: TFontCharset; // for BCB only
+ procedure SetFontCharset(const Value: TFontCharset);
+ function GetFontQuality: TFontQuality; // for BCB only
+ procedure SetFontQuality(const Value: TFontQuality);
+ function GetFontOrientation: Integer; // for BCB only
+ procedure SetFontOrientation(Value: Integer);
+ function GetFontPitch: TFontPitch; // for BCB only
+ procedure SetFontPitch(const Value: TFontPitch);
+ function GetPenMode: TPenMode; // for BCB only
+ procedure SetPenMode(const Value: TPenMode);
+ function GetPenStyle: TPenStyle; // for BCB only
+ procedure SetPenStyle(const Value: TPenStyle);
+ function GetGeometricPen: Boolean; // for BCB only
+ procedure SetGeometricPen(const Value: Boolean);
+ function GetPenEndCap: TPenEndCap; // for BCB only
+ procedure SetPenEndCap(const Value: TPenEndCap);
+ function GetPenJoin: TPenJoin; // for BCB only
+ procedure SetPenJoin(const Value: TPenJoin);
+ procedure SetLogFontStruct(const Value: TLogFont);
+ function GetLogFontStruct: TLogFont;
+ {$ENDIF GDI}
+ protected
+ procedure Changed;
+ {* }
+ {$IFDEF GDI}
+ function GetHandle: THandle;
+ {* }
+ {$ENDIF GDI}
+ protected
+ {$IFDEF _X_}
+ {$IFDEF GTK}
+ fPangoFontDesc: PPangoFontDescription;
+ FUNCTION GetPangoFontDesc: PPangoFontDescription;
+ {$ENDIF GTK}
+ {$ENDIF _X_}
+ public
+ destructor Destroy; virtual;
+ {* }
+ {$IFDEF _X_}
+ {$IFDEF GTK}
+ PROPERTY FontHandle: PPangoFontDescription read GetPangoFontDesc;
+ {$ENDIF GTK}
+ {$ENDIF _X_}
+ {$IFDEF GDI}
+ property Handle: THandle read GetHandle;
+ {* Every time, when accessed, real GDI object is created (if it is
+ not yet created). So, to prevent creating of the handle, use
+ HandleAllocated instead of comparing Handle with value 0. }
+ function HandleAllocated: Boolean;
+ {* Returns True, if handle is allocated (i.e., if real GDI
+ objet is created. }
+ {$ENDIF GDI}
+ property OnChange: TOnGraphicChange read fOnGTChange write fOnGTChange;
+ {* Called, when object is changed. }
+ {$IFDEF GDI}
+ function ReleaseHandle: THANDLE;
+ {* Returns Handle value (if allocated), releasing it from the
+ object (so, it is no more knows about this handle and its
+ HandleAllocated function returns False. }
+ {$ENDIF GDI}
+ property Color: TColor {index go_Color} read fData.Color write SetColor;
+ {* Color is the most common property for all Pen, Brush and
+ Font objects, so it is placed in its common for all of them. }
+ function Assign( Value: PGraphicTool ): PGraphicTool;
+ {* Assigns properties of the same (only) type graphic object,
+ excluding Handle. If assigning is really leading to change
+ object, procedure Changed is called. }
+ {$IFDEF GDI}
+ procedure AssignHandle( NewHandle: THANDLE );
+ {* Assigns value to Handle property. }
+
+ property BrushBitmap: HBitmap read {-BCB-}fData.Brush.Bitmap{+BCB+}
+ {BCB++}(*GetBrushBitmap*){--BCB}
+ write SetBrushBitmap;
+ {* Brush bitmap. For more info about using brush bitmap,
+ see Delphi or Win32 help files. }
+ {$ENDIF GDI}
+ property BrushStyle: TBrushStyle read {-BCB-}fData.Brush.Style{+BCB+}
+ {BCB++}(*GetBrushStyle*){--BCB}
+ write SetBrushStyle;
+ {$IFDEF GDI}
+ {* Brush style. }
+ property BrushLineColor: TColor index go_BrushLineColor
+ {$IFDEF F_P}
+ read GetInt
+ {$ELSE DELPHI}
+ read {-BCB-}fData.Brush.LineColor{+BCB+}
+ {BCB++}(*GetInt*){--BCB}
+ {$ENDIF F_P/DELPHI}
+ write SetInt;
+ {* Brush line color, used to represent lines in hatched brush. Default value is clBlack. }
+
+ {$ENDIF GDI}
+ property FontHeight: Integer index go_FontHeight
+ {$IFDEF F_P}
+ read GetInt
+ {$ELSE DELPHI}
+ read {-BCB-}fData.Font.Height{+BCB+}
+ {BCB++}(*GetInt*){--BCB}
+ {$ENDIF F_P/DELPHI}
+ write SetInt;
+ {* Font height. Value 0 (default) says to use system default value,
+ negative values are to represent font height in "points", positive
+ - in pixels. In XCL usually positive values (if not 0) are used to
+ make appearance independent from different local settings. }
+ {$IFDEF GDI}
+ property FontWidth: Integer index go_FontWidth
+ {$IFDEF F_P}
+ read GetInt
+ {$ELSE DELPHI}
+ read {-BCB-}fData.Font.Width{+BCB+}
+ {BCB++}(*GetInt*){--BCB}
+ {$ENDIF F_P/DELPHI}
+ write SetInt;
+ {* Font width in logical units. If FontWidth = 0, then as it is said
+ in Win32.hlp, "the aspect ratio of the device is matched against the
+ digitization aspect ratio of the available fonts to find the closest match,
+ determined by the absolute value of the difference." }
+ property FontPitch: TFontPitch read {-BCB-}fData.Font.Pitch{+BCB+}
+ {BCB++}(*GetFontPitch*){--BCB}
+ write SetFontPitch;
+ {* Font pitch. Change it very rare. }
+ {$ENDIF GDI}
+ property FontStyle: TFontStyle read GetFontStyle write SetFontStyle;
+ {* Very useful property to control text appearance. }
+ {$IFDEF GDI}
+ property FontCharset: TFontCharset read {-BCB-}fData.Font.Charset{+BCB+}
+ {BCB++}(*GetFontCharset*){--BCB}
+ write SetFontCharset;
+ {* Do not change it if You do not know what You do. }
+ property FontQuality: TFontQuality read {-BCB-}fData.Font.Quality{+BCB+}
+ {BCB++}(*GetFontQuality*){--BCB}
+ write SetFontQuality;
+ {* Font quality. }
+ property FontOrientation: Integer read {-BCB-}fData.Font.Orientation{+BCB+}
+ {BCB++}(*GetFontOrientation*){--BCB}
+ write SetFontOrientation;
+ {* It is possible to rotate text in XCL just by changing this
+ property of a font (tenths of degree, i.e. value 900 represents
+ 90 degree - text written from bottom to top). }
+ {$ENDIF GDI}
+ property FontWeight: Integer read {-BCB-}fData.Font.Weight{+BCB+}
+ {BCB++}(*GetFontWeight*){--BCB}
+ write SetFontWeight;
+ {* Additional font weight for bold fonts (must be 0..1000). When set to
+ value <> 0, fsBold is added to FontStyle. And otherwise, when set to 0,
+ fsBold is removed from FontStyle. Value 700 corresponds to Bold,
+ 400 to Normal. }
+ property FontName: KOLString read GetFontName write SetFontName;
+ {* Font face name. }
+ {$IFDEF GDI}
+ function IsFontTrueType: Boolean;
+ {* Returns True, if font is True Type. Requires of creating of a Handle,
+ if it is not yet created. }
+
+ property PenWidth: Integer index go_PenWidth
+ {$IFDEF F_P}
+ read GetInt
+ {$ELSE DELPHI}
+ read {-BCB-}fData.Pen.Width{+BCB+}
+ {BCB++}(*GetInt*){--BCB}
+ {$ENDIF F_P/DELPHI}
+ write SetInt;
+ {* Value 0 means default pen width. }
+ property PenStyle: TPenStyle read {-BCB-}fData.Pen.Style{+BCB+}
+ {BCB++}(*GetPenStyle*){--BCB}
+ write SetPenStyle;
+ {* Pen style. }
+ property PenMode: TPenMode read {-BCB-}fData.Pen.Mode{+BCB+}
+ {BCB++}(*GetPenMode*){--BCB}
+ write SetPenMode;
+ {* Pen mode. }
+
+ property GeometricPen: Boolean read {-BCB-}fData.Pen.Geometric{+BCB+}
+ {BCB++}(*GetGeometricPen*){--BCB}
+ write SetGeometricPen;
+ {* True if Pen is geometric. Note, that under Win95/98 only pen styles
+ psSolid, psNull, psInsideFrame are supported by OS. }
+ property PenBrushStyle: TBrushStyle read {-BCB-}fData.Pen.BrushStyle{+BCB+}
+ {BCB++}(*GetBrushStyle*){--BCB}
+ write SetBrushStyle;
+ {* Brush style for hatched geometric pen. }
+ property PenBrushBitmap: HBitmap read {-BCB-}fData.Pen.BrushBitmap{+BCB+}
+ {BCB++}(*GetBrushBitmap*){--BCB}
+ write SetBrushBitmap;
+ {* Brush bitmap for geometric pen (if assigned Pen is functioning as
+ its style = BS_PATTERN, regadless of PenBrushStyle value). }
+ property PenEndCap: TPenEndCap read {-BCB-}fData.Pen.EndCap{+BCB+}
+ {BCB++}(*GetPenEndCap*){--BCB}
+ write SetPenEndCap;
+ {* Pen end cap mode - for GeometricPen only. }
+ property PenJoin: TPenJoin read {-BCB-}fData.Pen.Join{+BCB+}
+ {BCB++}(*GetPenJoin*){--BCB}
+ write SetPenJoin;
+ {* Pen join mode - for GeometricPen only. }
+ property LogFontStruct: TLogFont read GetLogFontStruct write SetLogFontStruct;
+ {* by Alex Pravdin: a property to change all font structure items at once. }
+ {$ENDIF GDI}
+ end;
+
+function Color2RGB( Color: TColor ): TColor;
+{* Function to get RGB color from system color. Parameter can be also RGB
+ color, in that case result is just equal to a parameter. }
+function RGB2BGR( Color: TColor ): TColor;
+{* Converts RGB color to BGR }
+{$IFDEF GTK}
+FUNCTION Color2GDKColor( Color: TColor ): TGdkColor;
+{$ENDIF GTK}
+function ColorsMix( Color1, Color2: TColor ): TColor;
+{* Returns color, which RGB components are build as an (approximate)
+ arithmetic mean of correspondent RGB components of both source
+ colors (these both are first converted from system to RGB, and
+ result is always RGB color). Please note: this function is fast,
+ but can be not too exact. }
+{$IFDEF WIN_GDI}
+function Color2RGBQuad( Color: TColor ): TRGBQuad;
+{* Converts color to RGB, used to represent RGB values in palette entries
+ (actually swaps R and B bytes). }
+function Color2Color16( Color: TColor ): WORD;
+{* Converts Color to RGB, packed to word (as it is used in format pf16bit). }
+function Color2Color15( Color: TColor ): WORD;
+{* Converts Color to RGB, packed to word (as it is used in format pf15bit). }
+
+var // New TFont instances are intialized with the values in this structure:
+ DefFont: TGDIFont = (
+ Height: 0;
+ Width: 0;
+ Escapement: 0;
+ Orientation: 0;
+ Weight: 0;
+ Italic: FALSE;
+ Underline: FALSE;
+ StrikeOut: FALSE;
+ CharSet: 1;
+ OutPrecision: 0;
+ ClipPrecision: 0;
+ Quality: fqDefault;
+ Pitch: fpDefault;
+ {$IFDEF UNICODE_CTRLS}
+ Name: ( 'T', 'a', 'h', 'o', 'm', 'a',
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0 );
+ {$ELSE}
+ Name: 'System';
+ {$ENDIF}
+ );
+ DefFontColor: TColor = clWindowText;
+ {* Default font color. }
+
+ GlobalGraphics_UseFontOrient: Boolean;
+ {* Global flag. If stays False (default), Orientation property of Font
+ objects is ignored. This flag is set to True automatically in
+ RotateFonts add-on. }
+
+{$ENDIF WIN_GDI}
+
+function NewFont: PGraphicTool;
+{* Creates and returns font graphic tool object. }
+function NewBrush: PGraphicTool;
+{* Creates and returns new brush object. }
+function NewPen: PGraphicTool;
+{* Creates and returns new pen object. }
+
+{ ------------------------------ TCanvas object ------------------------------ }
+const
+ HandleValid = 1;
+ PenValid = 2;
+ BrushValid = 4;
+ FontValid = 8;
+ ChangingCanvas = 16;
+
+{$IFDEF WIN_GDI}
+type
+ TFillStyle = (fsSurface, fsBorder);
+ {* Available filling styles. For more info see Win32 or Delphi help files. }
+ TFillMode = (fmAlternate, fmWinding);
+ {* Available filling modes. For more info see Win32 or Delphi help files. }
+ TCopyMode = Integer;
+ {* Available copying modes are following:
+ | cmBlackness<br>
+ | cmDstInvert<br>
+ | cmMergeCopy<br>
+ | cmMergePaint<br>
+ | cmNotSrcCopy<br>
+ | cmNotSrcErase<br>
+ | cmPatCopy<br>
+ | cmPatInvert<br>
+ | cmPatPaint<br>
+ | cmSrcAnd<br>
+ | cmSrcCopy<br>
+ | cmSrcErase<br>
+ | cmSrcInvert<br>
+ | cmSrcPaint<br>
+ | cmWhiteness<br>
+ Also it is possible to use any other available ROP2 modes. For more info,
+ see Win32 help files. }
+
+const
+ cmBlackness = BLACKNESS;
+ cmDstInvert = DSTINVERT;
+ cmMergeCopy = MERGECOPY;
+ cmMergePaint = MERGEPAINT;
+ cmNotSrcCopy = NOTSRCCOPY;
+ cmNotSrcErase = NOTSRCERASE;
+ cmPatCopy = PATCOPY;
+ cmPatInvert = PATINVERT;
+ cmPatPaint = PATPAINT;
+ cmSrcAnd = SRCAND;
+ cmSrcCopy = SRCCOPY;
+ cmSrcErase = SRCERASE;
+ cmSrcInvert = SRCINVERT;
+ cmSrcPaint = SRCPAINT;
+ cmWhiteness = WHITENESS;
+
+{$ENDIF WIN_GDI}
+type
+ {$IFDEF _X_}
+ {$IFDEF GTK}
+ HDC = PGdkGC;
+ {$ENDIF GTK}
+ {$ENDIF _X_}
+ PCanvas = ^TCanvas;
+ {* }
+ TOnGetHandle = function( Canvas: PCanvas ): HDC of object;
+ {* For internal use mainly. }
+ TOnTextArea = procedure( Sender: PCanvas; var Size : TSize; var P0 : TPoint );
+ {* Event to calculate actual area, occupying by a text. It is used
+ to optionally extend calculating of TextArea taking into considaration
+ font Orientation property. }
+
+{ ---------------------------------------------------------------------
+ TCanvas - high-level drawing helper object
+----------------------------------------------------------------------- }
+ TCanvas = object( TObj )
+ {* Very similar to VCL's TCanvas object. But with some changes, specific
+ for KOL: there is no necessary to use canvases in all applications.
+ And graphic tools objects are not created with canvas, but only
+ if really accessed in program. (Actually, even if paint box used,
+ only programmer decides, if to implement painting using Canvas or
+ to call low level API drawing functions working directly with DC).
+ Therefore TCanvas has some powerful extensions: rotated text support,
+ geometric pen support - just by changing correspondent properties
+ of certain graphic tool objects (Font.FontOrientation, Pen.GeometricPen).
+ See also additional Font properties (Font.FontWeight, Font.FontQuality,
+ etc. }
+ protected
+ fOwnerControl: Pointer; //PControl;
+ {$IFDEF _X_}
+ {$IFDEF GTK}
+ fDrawable: PGdkDrawable;
+ fTmpColor: PGdkColor;
+ {$ENDIF GTK}
+ {$ENDIF _X_}
+ fHandle : HDC;
+ fPenPos : TPoint;
+ fState : Byte;
+ fBrush, fPen: PGraphicTool;
+ fFont : PGraphicTool; // order is important for ASM version
+ {$IFDEF GDI}
+ fCopyMode : TCopyMode;
+ fOnChangeCanvas: TOnEvent;
+ {$ENDIF GDI}
+ fOnGetHandle: TOnGetHandle;
+ {$IFDEF _X_}
+ {$IFDEF GTK}
+ fSavedState: TGdkGCValues;
+ PROCEDURE SaveState;
+ PROCEDURE RestoreState;
+ {$ENDIF GTK}
+ {$ENDIF _X_}
+ {$IFDEF GDI}
+ procedure SetHandle( Value : HDC );
+ {$ENDIF GDI}
+ procedure SetPenPos( const Value : TPoint );
+ {$IFDEF GDI}
+ procedure CreatePen;
+ procedure CreateBrush;
+ procedure CreateFont;
+ procedure Changing;
+ {$ENDIF GDI}
+ procedure ObjectChanged( Sender : PGraphicTool );
+ function GetBrush: PGraphicTool;
+ function GetFont: PGraphicTool;
+ function GetPen: PGraphicTool;
+ function GetHandle: HDC;
+ procedure AssignChangeEvents;
+ {$IFDEF GDI}
+ function GetPixels(X, Y: Integer): TColor;
+ procedure SetPixels(X, Y: Integer; const Value: TColor);
+ protected
+ fIsPaintDC : Boolean;
+ {* TRUE, if DC obtained during current WM_PAINT (or WM_ERASEBKGND?)
+ processing for a control. This affects a way how Handle is released. }
+ fIsAlienDC: Boolean;
+ {* TRUE if Canvas was created on base of existing DC, so DC is not
+ beloning to the Canvas and should not be deleted when the Canvas object
+ is destroyed. }
+ destructor Destroy; virtual;
+ {* }
+ {$ENDIF GDI}
+ property OnGetHandle: TOnGetHandle read fOnGetHandle write fOnGetHandle;
+ {* For internal use only. }
+ {$IFDEF GDI}
+ {$ENDIF GDI}
+ public
+ property Handle : HDC read GetHandle {$IFDEF GDI} write SetHandle {$ENDIF GDI};
+ {* GDI device context object handle. Never created by
+ Canvas itself (to use Canvas with memory bitmaps,
+ always create DC by yourself and assign it to the
+ Handle property of Canvas object, or use property
+ Canvas of a bitmap). }
+ property PenPos : TPoint read FPenPos write SetPenPos;
+ {* Position of a pen. }
+ property Pen : PGraphicTool read GetPen;
+ {* Pen of Canvas object. Do not change its Pen.OnChange event value. }
+ property Brush : PGraphicTool read GetBrush;
+ {* Brush of Canvas object. Do not change its Brush.OnChange event value. }
+ property Font : PGraphicTool read GetFont;
+ {* Font of Canvas object. Do not change its Font.OnChange event value. }
+ procedure OffsetAndRotate( Xoff, Yoff: Integer; Angle: Double );
+ {* Transforms world coordinates so that Xoff and Yoff become the
+ coordinates of the origin (0,0) and all further drawing is done
+ rotated around that point by the Angle (which is given in radians) }
+ {$IFNDEF NOT_USE_KOLMATH} // if using KOLmath disabled, Arc becomes unavailable
+ procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;
+ {* Draws arc. For more info, see Delphi TCanvas help. }
+ {$ENDIF NOT_USE_KOLMATH}
+ {$IFDEF GDI}
+ procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;
+ {* Draws chord. For more info, see Delphi TCanvas help. }
+ procedure DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
+ {* Draws rectangle to represent focused visual object.
+ For more info, see Delphi TCanvas help. }
+ procedure Ellipse(X1, Y1, X2, Y2: Integer);
+ {* Draws an ellipse. For more info, see Delphi TCanvas help. }
+ {$ENDIF GDI}
+ procedure FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
+ {* Fills rectangle. For more info, see Delphi TCanvas help. }
+ {$IFDEF GDI}
+ procedure FillRgn( const Rgn : HRgn );
+ {* Fills region. For more info, see Delphi TCanvas help. }
+ procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle);
+ {* Fills a figure with givien color, floodfilling its surface.
+ For more info, see Delphi TCanvas help. }
+ procedure FrameRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
+ {* Draws a rectangle using Brush settings (color, etc.).
+ For more info, see Delphi TCanvas help. }
+ {$ENDIF GDI}
+ procedure MoveTo( X, Y : Integer );
+ {* Moves current PenPos to a new position.
+ For more info, see Delphi TCanvas help. }
+ procedure LineTo( X, Y : Integer );
+ {* Draws a line from current PenPos up to new position.
+ For more info, see Delphi TCanvas help. }
+ {$IFDEF GDI}
+ procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;
+ {* Draws a pie. For more info, see Delphi TCanvas help. }
+ procedure Polygon(const Points: array of TPoint);
+ {* Draws a polygon. For more info, see Delphi TCanvas help. }
+ procedure Polyline(const Points: array of TPoint);
+ {* Draws a bound for polygon. For more info, see Delphi TCanvas help. }
+ procedure Rectangle(X1, Y1, X2, Y2: Integer);
+ {* Draws a rectangle using current Pen and/or Brush.
+ For more info, see Delphi TCanvas help. }
+ procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
+ {* Draws a rounded rectangle. For more info, see Delphi TCanvas help. }
+ {$ENDIF GDI}
+ procedure TextOutA(X, Y: Integer; const Text: AnsiString); stdcall;
+ {* Draws an ANSI text. For more info, see Delphi TCanvas help. }
+ procedure TextOut(X, Y: Integer; const Text: KOLString); stdcall;
+ {* Draws a text. For more info, see Delphi TCanvas help. }
+ procedure ExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; const Text: AnsiString;
+ const Spacing: array of Integer );
+ {* }
+ procedure TextRect(const Rect: TRect; X, Y: Integer; const Text: Ansistring);
+ {* Draws a text, clipping output into given rectangle.
+ For more info, see Delphi TCanvas help. }
+ {$IFDEF GDI}
+ procedure DrawText(Text: AnsiString; var Rect:TRect; Flags:DWord);
+ {* }
+ {$ENDIF GDI}
+ function TextExtent(const Text: KOLString): TSize;
+ {* Calculates size of a Text, using current Font settings.
+ Does not need in Handle for Canvas object (if it is not
+ yet allocated, temporary device context is created and used. }
+ procedure TextArea( const Text : KOLString; var Sz : TSize; var P0 : TPoint );
+ {* Calculates size and starting point to output Text,
+ taking into considaration all Font attributes, including
+ Orientation (only if GlobalGraphics_UseFontOrient flag
+ is set to True, i.e. if rotated fonts are used).
+ Like for TextExtent, does not need in Handle (and if this
+ last is not yet allocated/assigned, temporary device context
+ is created and used). }
+ {$IFDEF _D3orHigher}
+ procedure WTextArea( const Text : KOLWideString; var Sz : TSize; var P0 : TPoint );
+ {* Calculates size and starting point to output Text,
+ taking into considaration all Font attributes, including
+ Orientation (only if GlobalGraphics_UseFontOrient flag
+ is set to True, i.e. if rotated fonts are used).
+ Like for TextExtent, does not need in Handle (and if this
+ last is not yet allocated/assigned, temporary device context
+ is created and used). }
+ {$ENDIF _D3orHigher}
+ function TextWidth(const Text: KOLString): Integer;
+ {* Calculates text width (using TextArea). }
+ function TextHeight(const Text: KOLString): Integer;
+ {* Calculates text height (using TextArea). }
+ {$IFDEF GDI}
+ function ClipRect: TRect;
+ {* returns ClipBox. by Dmitry Zharov. }
+
+ {$IFNDEF _FPC}
+ {$IFNDEF _D2} //------- KOLWideString not supported in D2
+ procedure WTextOut(X, Y: Integer; const WText: KOLWideString); stdcall;
+ {* Draws a Unicode text. }
+ procedure WExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect;
+ const WText: KOLWideString; const Spacing: array of Integer );
+ {* }
+ procedure WDrawText(WText: KOLWideString; var Rect:TRect; Flags:DWord);
+ {* }
+ procedure WTextRect(const Rect: TRect; X, Y: Integer;
+ const WText: KOLWideString);
+ {* Draws a Unicode text, clipping output into given rectangle. }
+ function WTextExtent( const WText: KOLWideString ): TSize;
+ {* Calculates Unicode text width and height. }
+ function WTextWidth( const WText: KOLWideString ): Integer;
+ {* Calculates Unicode text width. }
+ function WTextHeight( const WText: KOLWideString ): Integer;
+ {* Calculates Unicode text height. }
+ {$ENDIF _D2}
+ {$ENDIF _FPC}
+
+ property ModeCopy : TCopyMode read fCopyMode write fCopyMode;
+ {* Current copy mode. Is used in CopyRect method. }
+ procedure CopyRect( const DstRect : TRect; SrcCanvas : PCanvas; const SrcRect : TRect );
+ {* Copyes a rectangle from source to destination, using StretchBlt. }
+ property OnChange: TOnEvent read fOnChangeCanvas write fOnChangeCanvas;
+ {* }
+ function Assign( SrcCanvas : PCanvas ) : Boolean;
+ {* }
+ {$ENDIF GDI}
+ {$IFDEF _X_}
+ protected // for _X_ case, RequiredState is protected yet (???)
+ procedure ForeBack(fg_color, bk_color: TColor); // install colors just before drawing
+ {$ENDIF _X_}
+ {$IFDEF GDI}
+ function RequiredState( ReqState : DWORD ): HDC; stdcall;// public now
+ {* It is possible to call this method before using Handle property
+ to pass it into API calls - to provide valid combinations of
+ pen, brush and font, selected into device context. This method
+ can not provide valid Handle - You always must create it by
+ yourself and assign to TCanvas.Handle property manually.
+ To optimize assembler version, returns Handle value. }
+ public
+ {$ENDIF GDI}
+ procedure DeselectHandles;
+ {* Call this method to deselect all graphic tool objects from the canvas. }
+ {$IFDEF GDI}
+ property Pixels[ X, Y: Integer ]: TColor read GetPixels write SetPixels;
+ {* Obvious. }
+ {$ENDIF GDI}
+ end;
+
+function NewCanvas( DC: HDC ): PCanvas;
+{* Use to construct Canvas on base of memory DC. }
+
+procedure DummyObjProc( Sender: PObj );
+
+var
+ GlobalCanvas_OnTextArea : Pointer = @DummyObjProc;
+ {* Global event to extend Canvas with possible add-ons, applied
+ when rotated fonts are used only (to take into consideration
+ Font.Orientation property in TextArea method). }
+
+{$IFDEF WIN_GDI}
+
+{ ------------------------------ Image list object --------------------------- }
+
+type
+ TImageListColors = (ilcColor,ilcColor4,ilcColor8,ilcColor16,
+ ilcColor24,ilcColor32,ilcColorDDB,ilcDefault);
+ {* ImageList color schemes available. }
+
+ TDrawingStyles = ( dsBlend25, dsBlend50, dsMask, dsTransparent );
+ {* ImageList drawing styles available. }
+ TDrawingStyle = Set of TDrawingStyles;
+ {* Style of drawing is a combination of all available drawing styles. }
+
+ TImageType = (itBitmap,itIcon,itCursor);
+ {* ImageList types available. }
+
+ PImageList = ^TImageList;
+ {* }
+
+ TImgLOVrlayIdx = 1..15;
+
+{ ---------------------------------------------------------------------
+ TImageList - images container
+----------------------------------------------------------------------- }
+ TImageList = object( TObj )
+ private
+ fOverlayIdx: Integer;
+ {* ImageList incapsulation. }
+ protected
+ FHandle: THandle;
+ FControl: Pointer; // PControl;
+ fPrev, fNext: PImageList;
+ FColors: TImageListColors;
+ FMasked: Boolean;
+ FImgWidth: Integer;
+ FImgHeight: Integer;
+ FDrawingStyle: TDrawingStyle;
+ FBlendColor: TColor;
+ fBkColor: TColor;
+ FAllocBy: Integer;
+ FShareImages: Boolean;
+ FOverlay: array[ TImgLOVrlayIdx ] of Integer;
+ function HandleNeeded : Boolean;
+ procedure SetColors(const Value: TImageListColors);
+ procedure SetMasked(const Value: Boolean);
+ procedure SetImgWidth(const Value: Integer);
+ procedure SetImgHeight(const Value: Integer);
+ function GetCount: Integer;
+ function GetBkColor: TColor;
+ procedure SetBkColor(const Value: TColor);
+ function GetBitmap: HBitmap;
+ function GetMask: HBitmap;
+ function GetDrawStyle : DWord;
+ procedure SetAllocBy(const Value: Integer);
+ function GetHandle: THandle;
+ function GetOverlay(Idx: TImgLOVrlayIdx): Integer;
+ procedure SetOverlay(Idx: TImgLOVrlayIdx; const Value: Integer);
+ protected
+ procedure SetHandle(const Value: THandle);
+ {*}
+ public
+ destructor Destroy; virtual;
+ {*}
+ property Handle : THandle read GetHandle write SetHandle;
+ {* Handle of ImageList object. }
+ property ShareImages : Boolean read FShareImages write FShareImages;
+ {* True if images are shared between processes (it is set to True,
+ if its Handle is assigned to given value, which is a handle of
+ already existing ImageList object). }
+ property Colors : TImageListColors read FColors write SetColors;
+ {* Colors used to represent images. }
+ property Masked : Boolean read FMasked write SetMasked;
+ {* True, if mask is used. It is set to True, if first added image
+ is icon, e.g. }
+ property ImgWidth : Integer read FImgWidth write SetImgWidth;
+ {* Width of every image in list. If change, ImageList is cleared. }
+ property ImgHeight : Integer read FImgHeight write SetImgHeight;
+ {* Height of every image in list. If change, ImageList is cleared. }
+ property Count : Integer read GetCount;
+ {* Number of images in list. }
+ property AllocBy : Integer read FAllocBy write SetAllocBy;
+ {* Allocation factor. Default is 1. Set it to size of ImageList if this
+ value is known - to optimize speed of allocation. }
+ property BkColor : TColor read GetBkColor write SetBkColor;
+ {* Background color. }
+ property BlendColor : TColor read FBlendColor write FBlendColor;
+ {* Blend color. }
+
+ property Bitmap : HBitmap read GetBitmap;
+ {* Bitmap, containing all ImageList images (tiled horizontally). }
+ property Mask : HBitmap read GetMask;
+ {* Monochrome bitmap, containing masks for all images in list (if not
+ Masked, always returns nil). }
+ function ImgRect( Idx : Integer ) : TRect;
+ {* Rectangle occupied of given image in ImageList. }
+
+ function Add( Bmp, Msk : HBitmap ) : Integer;
+ {* Adds bitmap and given mask to ImageList. }
+ function AddMasked( Bmp : HBitmap; Color : TColor ) : Integer;
+ {* Adds bitmap to ImageList, using given color to create mask. }
+ function AddIcon( Ico : HIcon ) : Integer;
+ {* Adds icon to ImageList (always masked). }
+ procedure Delete( Idx : Integer );
+ {* Deletes given image from ImageList. }
+ procedure Clear;
+ {* Makes ImageList empty. }
+ function Replace( Idx : Integer; Bmp, Msk : HBitmap ) : Boolean;
+ {* Replaces given (by index) image with bitmap and its mask with mask bitmap. }
+ function ReplaceIcon( Idx : Integer; Ico : HIcon ) : Boolean;
+ {* Replaces given (by index) image with an icon. }
+ function Merge( Idx : Integer; ImgList2 : PImageList; Idx2 : Integer; X, Y : Integer )
+ : PImageList;
+ {* Merges two ImageList objects, returns resulting ImageList. }
+ function ExtractIcon( Idx : Integer ) : HIcon;
+ {* Extracts icon by index. }
+ function ExtractIconEx( Idx : Integer ) : HIcon;
+ {* Extracts icon (is created using current drawing style). }
+
+ property DrawingStyle : TDrawingStyle read FDrawingStyle write FDrawingStyle;
+ {* Drawing style. }
+ procedure Draw( Idx : Integer; DC : HDC; X, Y : Integer );
+ {* Draws given (by index) image from ImageList onto passed Device Context. }
+ procedure StretchDraw( Idx : Integer; DC : HDC; const Rect : TRect );
+ {* Draws given image with stratching. }
+
+ function LoadBitmap( ResourceName : PKOLChar; TranspColor : TColor ) : Boolean;
+ {* Loads ImageList from resource. }
+ //function LoadIcon( ResourceName : PAnsiChar ) : Boolean;
+ //function LoadCursor( ResourceName : PAnsiChar ) : Boolean;
+ function LoadFromFile( FileName : PKOLChar; TranspColor : TColor; ImgType : TImageType ) : Boolean;
+ {* Loads ImageList from file. }
+ function LoadSystemIcons( SmallIcons : Boolean ) : Boolean;
+ {* Assigns ImageList to system icons list (big or small). }
+
+ property Overlay[ Idx: TImgLOVrlayIdx ]: Integer read GetOverlay write SetOverlay;
+ {* Overlay images for image list (images, used as overlay images to draw over
+ other images from the image list). These overalay images can be used in
+ listview and treeview as overlaying images (up to four masks at the same
+ time). }
+ property OverlayIdx: Integer read fOverlayIdx write fOverlayIdx;
+ {* Set this value to 1..15 to draw images overlayed (using Draw or DrawEx). }
+ {$IFDEF USE_CONSTRUCTORS}
+ constructor CreateImageList( POwner: Pointer );
+ {$ENDIF USE_CONSTRUCTORS}
+ end;
+
+const
+ CLR_NONE = $FFFFFFFF;
+ CLR_DEFAULT = $FF000000;
+
+type
+ HImageList = THandle;
+
+const
+ ILC_MASK = $0001;
+ ILC_COLOR = $00FE;
+ ILC_COLORDDB = $00FE;
+ ILC_COLOR4 = $0004;
+ ILC_COLOR8 = $0008;
+ ILC_COLOR16 = $0010;
+ ILC_COLOR24 = $0018;
+ ILC_COLOR32 = $0020;
+ ILC_PALETTE = $0800;
+
+const
+ ILD_NORMAL = $0000;
+ ILD_TRANSPARENT = $0001;
+ ILD_MASK = $0010;
+ ILD_IMAGE = $0020;
+ ILD_BLEND25 = $0002;
+ ILD_BLEND50 = $0004;
+ ILD_OVERLAYMASK = $0F00;
+
+const
+ ILD_SELECTED = ILD_BLEND50;
+ ILD_FOCUS = ILD_BLEND25;
+ ILD_BLEND = ILD_BLEND50;
+ CLR_HILIGHT = CLR_DEFAULT;
+
+function ImageList_Create(CX, CY: Integer; Flags: UINT;
+ Initial, Grow: Integer): HImageList; stdcall;
+function ImageList_Destroy(ImageList: HImageList): Bool; stdcall;
+function ImageList_GetImageCount(ImageList: HImageList): Integer; stdcall;
+function ImageList_SetImageCount(ImageList: HImageList; Count: Integer): Integer; stdcall;
+function ImageList_Add(ImageList: HImageList; Image, Mask: HBitmap): Integer; stdcall;
+function ImageList_ReplaceIcon(ImageList: HImageList; Index: Integer;
+ Icon: HIcon): Integer; stdcall;
+function ImageList_SetBkColor(ImageList: HImageList; ClrBk: TColorRef): TColorRef; stdcall;
+function ImageList_GetBkColor(ImageList: HImageList): TColorRef; stdcall;
+function ImageList_SetOverlayImage(ImageList: HImageList; Image: Integer;
+ Overlay: Integer): Bool; stdcall;
+
+function ImageList_AddIcon(ImageList: HImageList; Icon: HIcon): Integer;
+
+function Index2OverlayMask(Index: Integer): Integer;
+
+function ImageList_Draw(ImageList: HImageList; Index: Integer;
+ Dest: HDC; X, Y: Integer; Style: UINT): Bool; stdcall;
+
+function ImageList_Replace(ImageList: HImageList; Index: Integer;
+ Image, Mask: HBitmap): Bool; stdcall;
+function ImageList_AddMasked(ImageList: HImageList; Image: HBitmap;
+ Mask: TColorRef): Integer; stdcall;
+function ImageList_DrawEx(ImageList: HImageList; Index: Integer;
+ Dest: HDC; X, Y, DX, DY: Integer; Bk, Fg: TColorRef; Style: Cardinal): Bool; stdcall;
+function ImageList_Remove(ImageList: HImageList; Index: Integer): Bool; stdcall;
+function ImageList_GetIcon(ImageList: HImageList; Index: Integer;
+ Flags: Cardinal): HIcon; stdcall;
+{$IFDEF UNICODE_CTRLS}
+function ImageList_LoadImage(Instance: THandle; Bmp: PWideChar; CX, Grow: Integer;
+ Mask: TColorRef; pType, Flags: Cardinal): HImageList; stdcall;
+{$ELSE}
+function ImageList_LoadImage(Instance: THandle; Bmp: PAnsiChar; CX, Grow: Integer;
+ Mask: TColorRef; pType, Flags: Cardinal): HImageList; stdcall;
+{$ENDIF}
+function ImageList_BeginDrag(ImageList: HImageList; Track: Integer;
+ XHotSpot, YHotSpot: Integer): Bool; stdcall;
+function ImageList_EndDrag: Bool; stdcall;
+function ImageList_DragEnter(LockWnd: HWnd; X, Y: Integer): Bool; stdcall;
+function ImageList_DragLeave(LockWnd: HWnd): Bool; stdcall;
+function ImageList_DragMove(X, Y: Integer): Bool; stdcall;
+function ImageList_SetDragCursorImage(ImageList: HImageList; Drag: Integer;
+ XHotSpot, YHotSpot: Integer): Bool; stdcall;
+function ImageList_DragShowNolock(Show: Bool): Bool; stdcall;
+function ImageList_GetDragImage(Point, HotSpot: PPoint): HImageList; stdcall;
+
+{ macros }
+procedure ImageList_RemoveAll(ImageList: HImageList); stdcall;
+function ImageList_ExtractIcon(Instance: THandle; ImageList: HImageList;
+ Image: Integer): HIcon; stdcall;
+function ImageList_LoadBitmap(Instance: THandle; Bmp: PKOLChar;
+ CX, Grow: Integer; MasK: TColorRef): HImageList; stdcall;
+
+type
+ PImageInfo = ^TImageInfo;
+ TImageInfo = packed record
+ hbmImage: HBitmap;
+ hbmMask: HBitmap;
+ Unused1: Integer;
+ Unused2: Integer;
+ rcImage: TRect;
+ end;
+
+function ImageList_GetIconSize(ImageList: HImageList; var CX, CY: Integer): Bool; stdcall;
+function ImageList_SetIconSize(ImageList: HImageList; CX, CY: Integer): Bool; stdcall;
+function ImageList_GetImageInfo(ImageList: HImageList; Index: Integer;
+ var ImageInfo: TImageInfo): Bool; stdcall;
+function ImageList_Merge(ImageList1: HImageList; Index1: Integer;
+ ImageList2: HImageList; Index2: Integer; DX, DY: Integer)://Bool - ERROR IN VCL
+ HImageList; stdcall;
+
+function LoadBmp( Instance: Integer; Rsrc: PKOLChar; MasterObj: PObj ): HBitmap;
+function LoadBmp32( Instance: Integer; Rsrc: PKOLChar; MasterObj: PObj ): HBitmap;
+
+type
+ tagBitmap = Windows.TBitmap;
+
+ TPixelFormat = ( pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit,
+ pf32bit, pfCustom );
+ {* Available pixel formats. }
+ TBitmapHandleType = ( bmDIB, bmDDB );
+ {* Available bitmap handle types. }
+
+ PBitmap = ^TBitmap;
+{ ----------------------------------------------------------------------
+ TBitmap - bitmap image
+----------------------------------------------------------------------- }
+ TBitmap = object( TObj )
+ {* Bitmap incapsulation object. }
+ protected
+ fHeight: Integer;
+ fWidth: Integer;
+ fHandle: HBitmap;
+ fCanvas: PCanvas;
+ fScanLineSize: Integer;
+ fBkColor: TColor;
+ fApplyBkColor2Canvas: procedure( Sender: PBitmap );
+ fDetachCanvas: procedure( Sender: PBitmap );
+ fCanvasAttached : Integer;
+ fHandleType: TBitmapHandleType;
+ fDIBHeader: PBitmapInfo;
+ fDIBBits: Pointer;
+ fDIBSize: Integer;
+ fNewPixelFormat: TPixelFormat;
+ fFillWithBkColor: procedure( BmpObj: PBitmap; DC: HDC; oldW, oldH: Integer );
+ //stdcall;
+ fTransMaskBmp: PBitmap;
+ fTransColor: TColor;
+ fGetDIBPixels: function( Bmp: PBitmap; X, Y: Integer ): TColor;
+ fSetDIBPixels: procedure( Bmp: PBitmap; X, Y: Integer; Value: TColor );
+ fScanLine0: PByte;
+ fScanLineDelta: Integer;
+ fPixelMask: DWORD;
+ fPixelsPerByteMask: Integer;
+ fBytesPerPixel: Integer;
+ fDIBAutoFree: Boolean;
+ procedure SetHeight(const Value: Integer);
+ procedure SetWidth(const Value: Integer);
+ function GetEmpty: Boolean;
+ function GetHandle: HBitmap;
+ function GetHandleAllocated: Boolean;
+ procedure SetHandle(const Value: HBitmap);
+ procedure SetPixelFormat(Value: TPixelFormat);
+ procedure FormatChanged;
+ function GetCanvas: PCanvas;
+ procedure CanvasChanged( Sender: PObj );
+ function GetScanLine(Y: Integer): Pointer;
+ function GetScanLineSize: Integer;
+ procedure ClearData;
+ procedure ClearTransImage;
+ procedure SetBkColor(const Value: TColor);
+ function GetDIBPalEntries(Idx: Integer): TColor;
+ function GetDIBPalEntryCount: Integer;
+ procedure SetDIBPalEntries(Idx: Integer; const Value: TColor);
+ procedure SetHandleType(const Value: TBitmapHandleType);
+ function GetPixelFormat: TPixelFormat;
+ function GetPixels(X, Y: Integer): TColor;
+ procedure SetPixels(X, Y: Integer; const Value: TColor);
+ function GetDIBPixels(X, Y: Integer): TColor;
+ procedure SetDIBPixels(X, Y: Integer; const Value: TColor);
+ function GetBoundsRect: TRect;
+ protected
+ destructor Destroy; virtual;
+ public
+ property Width: Integer read fWidth write SetWidth;
+ {* Width of bitmap. To make code smaller, avoid changing Width or Height
+ after bitmap is created (using NewBitmap) or after it is loaded from
+ file, stream of resource. }
+ property Height: Integer read fHeight write SetHeight;
+ {* Height of bitmap. To make code smaller, avoid changing Width or Height
+ after bitmap is created (using NewBitmap) or after it is loaded from
+ file, stream of resource. }
+ property BoundsRect: TRect read GetBoundsRect;
+ {* Returns rectangle (0,0,Width,Height). }
+ property Empty: Boolean read GetEmpty;
+ {* Returns True if Width or Height is 0. }
+ procedure Clear;
+ {* Makes bitmap empty, setting its Width and Height to 0. }
+ procedure LoadFromFile( const Filename: KOLString );
+ {* Loads bitmap from file (LoadFromStream used). }
+ function LoadFromFileEx( const Filename: KOLString ): Boolean;
+ {* Loads bitmap from a file. If necessary, bitmap is RLE-decoded. Code given
+ by Vyacheslav A. Gavrik. }
+ procedure SaveToFile( const Filename: KOLString );
+ {* Stores bitmap to file (SaveToStream used). }
+ procedure CoreSaveToFile( const Filename: KOLString );
+ {* Stores bitmap to file (CoreSaveToStream used). }
+ procedure RLESaveToFile( const Filename: KOLString );
+ {* Stores bitmap to file (CoreSaveToStream used). }
+ procedure LoadFromStream( Strm: PStream );
+ {* Loads bitmap from stream. Follow loading, bitmap has DIB format (without
+ handle allocated). It is possible to draw DIB bitmap without creating
+ handle for it, which can economy GDI resources. }
+ function LoadFromStreamEx( Strm: PStream ): Boolean;
+ {* Loads bitmap from a stream. Difference is that RLE decoding supported.
+ Code given by Vyacheslav A. Gavrik. }
+ procedure SaveToStream( Strm: PStream );
+ {* Saves bitmap to stream. If bitmap is not DIB, it is converted to DIB
+ before saving. }
+ procedure CoreSaveToStream( Strm: PStream );
+ {* Saves bitmap to stream using CORE format with RGBTRIPLE palette and
+ with BITMAPCOREHEADER as a header.
+ If bitmap is not DIB, it is converted to DIB before saving. }
+ procedure RLESaveToStream( Strm: PStream );
+ {* Saves bitmap to stream using CORE format with RGBTRIPLE palette and
+ with BITMAPCOREHEADER as a header.
+ If bitmap is not DIB, it is converted to DIB before saving. }
+ procedure LoadFromResourceID( Inst: DWORD; ResID: Integer );
+ {* Loads bitmap from resource using integer ID of resource. To load by name,
+ use LoadFromResurceName. To load resource of application itself, pass
+ hInstance as first parameter. This method also can be used to load system
+ predefined bitmaps, if 0 is passed as Inst parameter:
+ |<pre>
+ OBM_BTNCORNERS OBM_REDUCE
+ OBM_BTSIZE OBM_REDUCED
+ OBM_CHECK OBM_RESTORE
+ OBM_CHECKBOXES OBM_RESTORED
+ OBM_CLOSE OBM_RGARROW
+ OBM_COMBO OBM_RGARROWD
+ OBM_DNARROW OBM_RGARROWI
+ OBM_DNARROWD OBM_SIZE
+ OBM_DNARROWI OBM_UPARROW
+ OBM_LFARROW OBM_UPARROWD
+ OBM_LFARROWD OBM_UPARROWI
+ OBM_LFARROWI OBM_ZOOM
+ OBM_MNARROW OBM_ZOOMD
+ |</pre> }
+ procedure LoadFromResourceName( Inst: DWORD; ResName: PKOLChar );
+ {* Loads bitmap from resurce (using passed name of bitmap resource. }
+ function Assign( SrcBmp: PBitmap ): Boolean;
+ {* Assigns bitmap from another. Returns False if not success.
+ Note: remember, that Canvas is not assigned - only bitmap image
+ is copied. And for DIB, handle is not allocating due this process. }
+ property Handle: HBitmap read GetHandle write SetHandle;
+ {* Handle of bitmap. Created whenever property accessed. To check if handle
+ is allocated (without allocating it), use HandleAllocated property. }
+ property HandleAllocated: Boolean read GetHandleAllocated;
+ {* Returns True, if Handle already allocated. }
+ function ReleaseHandle: HBitmap;
+ {* Returns Handle and releases it, so bitmap no more know about handle.
+ This method does not destroy bitmap image, but converts it into DIB.
+ Returned Handle actually is a handle of copy of original bitmap. If
+ You need not in keping it up, use Dormant method instead. }
+ procedure Dormant;
+ {* Releases handle from bitmap and destroys it. But image is not destroyed
+ and its data are preserved in DIB format. Please note, that in KOL, DIB
+ bitmaps can be drawn onto given device context without allocating of
+ handle. So, it is very useful to call Dormant preparing it using
+ Canvas drawing operations - to economy GDI resources. }
+ property HandleType: TBitmapHandleType read fHandleType write SetHandleType;
+ {* bmDIB, if DIB part of image data is filled and stored internally in
+ TBitmap object. DIB image therefore can have Handle allocated, which
+ require resources. Use HandleAllocated funtion to determine if handle
+ is allocated and Dormant method to remove it, if You want to economy
+ GDI resources. (Actually Handle needed for DIB bitmap only in case
+ when Canvas is used to draw on bitmap surface). Please note also, that
+ before saving bitmap to file or stream, it is converted to DIB. }
+ property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
+ {* Current pixel format. If format of bitmap is unknown, or bitmap is DDB,
+ value is pfDevice. Setting PixelFormat to any other format converts
+ bitmap to DIB, back to pfDevice converts bitmap to DDB again. Avoid
+ such conversations for large bitmaps or for numerous bitmaps in your
+ application to keep good performance. }
+ function BitsPerPixel: Integer;
+ {* Returns bits per pixel if possible. }
+ procedure Draw( DC: HDC; X, Y: Integer );
+ {* Draws bitmap to given device context. If bitmap is DIB, it is always
+ drawing using SetDIBitsToDevice API call, which does not require bitmap
+ handle (so, it is very sensible to call Dormant method to free correspondent
+ GDI resources). }
+ procedure StretchDraw( DC: HDC; const Rect: TRect );
+ {* Draws bitmap onto DC, stretching it to fit given rectangle Rect. }
+ procedure DrawTransparent( DC: HDC; X, Y: Integer; TranspColor: TColor );
+ {* Draws bitmap onto DC transparently, using TranspColor as transparent.
+ See function DesktopPixelFormat also. }
+ procedure StretchDrawTransparent( DC: HDC; const Rect: TRect; TranspColor: TColor );
+ {* Draws bitmap onto given rectangle of destination DC (with stretching it
+ to fit Rect) - transparently, using TranspColor as transparent.
+ See function DesktopPixelFormat also. }
+ procedure DrawMasked( DC: HDC; X, Y: Integer; Mask: HBitmap );
+ {* Draws bitmap to destination DC transparently by mask. It is possible
+ to pass as a mask handle of another TBitmap, previously converted to
+ monochrome mask using Convert2Mask method. }
+ procedure StretchDrawMasked( DC: HDC; const Rect: TRect; Mask: HBitmap );
+ {* Like DrawMasked, but with stretching image onto given rectangle. }
+ procedure Convert2Mask( TranspColor: TColor );
+ {* Converts bitmap to monochrome (mask) bitmap with TranspColor replaced
+ to clBlack and all other ones to clWhite. Such mask bitmap can be used
+ to draw original bitmap transparently, with given TranspColor as
+ transparent. (To preserve original bitmap, create new instance of
+ TBitmap and assign original bitmap to it). See also DrawTransparent and
+ StretchDrawTransparent methods. }
+ procedure Invert;
+ {* Obvious. }
+ property Canvas: PCanvas read GetCanvas;
+ {* Canvas can be used to draw onto bitmap. Whenever it is accessed, handle
+ is allocated for bitmap, if it is not yet (to make it possible
+ to select bitmap to display compatible device context). }
+ procedure RemoveCanvas;
+ {* Call this method to destroy Canvas and free GDI resources. }
+ property BkColor: TColor read fBkColor write SetBkColor;
+ {* Used to fill background for Bitmap, when its width or height is increased.
+ Although this value always synchronized with Canvas.Brush.Color, use it
+ instead if You do not use Canvas for drawing on bitmap surface. }
+ property Pixels[ X, Y: Integer ]: TColor read GetPixels write SetPixels;
+ {* Allows to obtain or change certain pixels of a bitmap. This method is
+ both for DIB and DDB bitmaps, and leads to allocate handle anyway. For
+ DIB bitmaps, it is possible to use property DIBPixels[ ] instead,
+ which is much faster and does not require in Handle. }
+ property ScanLineSize: Integer read GetScanLineSize;
+ {* Returns size of scan line in bytes. Use it to measure size of a single
+ ScanLine. To calculate increment value from first byte of ScanLine to
+ first byte of next ScanLine, use difference
+ ! Integer(ScanLine[1]-ScanLine[0])
+ (this is because bitmap can be oriented from bottom to top, so
+ step can be negative). }
+ property ScanLine[ Y: Integer ]: Pointer read GetScanLine;
+ {* Use ScanLine to access DIB bitmap pixels in memory to direct access it
+ fast. Take in attention, that for different pixel formats, different
+ bit counts are used to represent bitmap pixels. Also do not forget, that
+ for formats pf4bit and pf8bit, pixels actually are indices to palette
+ entries, and for formats pf16bit, pf24bit and pf32bit are actually
+ RGB values (for pf16bit B:5-G:6-R:5, for pf15bit B:5-G:5-R:5 (high order
+ bit not used), for pf24bit B:8-G:8-R:8, and for pf32bit high order byte
+ of TRGBQuad structure is not used). }
+ property DIBPixels[ X, Y: Integer ]: TColor read GetDIBPixels write SetDIBPixels;
+ {* Allows direct access to pixels of DIB bitmap, faster then Pixels[ ]
+ property. Access to read is slower for pf15bit, pf16bit formats (because
+ some conversation needed to translate packed RGB color to TColor). And
+ for write, operation performed most slower for pf4bit, pf8bit (searching
+ nearest color required) and fastest for pf24bit, pf32bit and pf1bit. }
+ property DIBPalEntryCount: Integer read GetDIBPalEntryCount;
+ {* Returns palette entries count for DIB image. Always returns 2 for pf1bit,
+ 16 for pf4bit, 256 for pf8bit and 0 for other pixel formats. }
+ property DIBPalEntries[ Idx: Integer ]: TColor read GetDIBPalEntries write
+ SetDIBPalEntries;
+ {* Provides direct access to DIB palette. }
+ function DIBPalNearestEntry( Color: TColor ): Integer;
+ {* Returns index of entry in DIB palette with color nearest (or matching)
+ to given one. }
+ property DIBBits: Pointer read fDIBBits;
+ {* This property is mainly for internal use. }
+ property DIBSize: Integer read fDIBSize;
+ {* Size of DIBBits array. }
+ property DIBHeader: PBitmapInfo read fDIBHeader;
+ {* This property is mainly for internal use. }
+ procedure DIBDrawRect( DC: HDC; X, Y: Integer; const R: TRect );
+ {* This procedure copies given rectangle to the target device context,
+ but only for DIB bitmap (using SetDIBBitsToDevice API call). }
+ procedure RotateRight;
+ {* Rotates bitmap right (90 degree). Bitmap must be DIB. If You definitevely
+ know format of a bitmap, use instead one of methods RotateRightMono,
+ RotateRight4bit, RotateRight8bit, RotateRight16bit or RotateRightTrueColor
+ - this will economy code. But if for most of formats such methods are
+ called, this can be more economy just to call always universal method
+ RotateRight. }
+ procedure RotateLeft;
+ {* Rotates bitmap left (90 degree). Bitmap must be DIB. If You definitevely
+ know format of a bitmap, use instead one of methods RotateLeftMono,
+ RotateLeft4bit, RotateLeft8bit, RotateLeft16bit or RotateLeftTrueColor
+ - this will economy code. But if for most of formats such methods are
+ called, this can be more economy just to call always universal method
+ RotateLeft. }
+ procedure RotateRightMono;
+ {* Rotates bitmat right, but only if bitmap is monochrome (pf1bit). }
+ procedure RotateLeftMono;
+ {* Rotates bitmap left, but only if bitmap is monochrome (pf1bit). }
+ procedure RotateRight4bit;
+ {* Rotates bitmap right, but only if PixelFormat is pf4bit. }
+ procedure RotateLeft4bit;
+ {* Rotates bitmap left, but only if PixelFormat is pf4bit. }
+ procedure RotateRight8bit;
+ {* Rotates bitmap right, but only if PixelFormat is pf8bit. }
+ procedure RotateLeft8bit;
+ {* Rotates bitmap left, but only if PixelFormat is pf8bit. }
+ procedure RotateRight16bit;
+ {* Rotates bitmap right, but only if PixelFormat is pf16bit. }
+ procedure RotateLeft16bit;
+ {* Rotates bitmap left, but only if PixelFormat is pf16bit. }
+ procedure RotateRightTrueColor;
+ {* Rotates bitmap right, but only if PixelFormat is pf24bit or pf32bit. }
+ procedure RotateLeftTrueColor;
+ {* Rotates bitmap left, but only if PixelFormat is pf24bit or pf32bit. }
+ procedure FlipVertical;
+ {* Flips bitmap vertically }
+ procedure FlipHorizontal;
+ {* Flips bitmap horizontally }
+ procedure CopyRect( const DstRect : TRect; SrcBmp : PBitmap; const SrcRect : TRect );
+ {* It is possible to use Canvas.CopyRect for such purpose, but if You
+ do not want use TCanvas, it is possible to copy rectangle from one
+ bitmap to another using this function. }
+ function CopyToClipboard: Boolean;
+ {* Copies bitmap to clipboard. }
+ function PasteFromClipboard: Boolean;
+ {* Takes CF_DIB format bitmap from clipboard and assigns it to the
+ TBitmap object. }
+ end;
+
+function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat;
+
+function NewBitmap( W, H: Integer ): PBitmap;
+{* Creates bitmap object of given size. If it is possible, do not change its
+ size (Width and Heigth) later - this can economy code a bit. See TBitmap. }
+function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap;
+{* Creates DIB bitmap object of given size and pixel format. If it is possible,
+ do not change its size (Width and Heigth) later - this can economy code a bit.
+ See TBitmap. }
+function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer;
+{* May be will be useful. }
+
+var
+ DefaultPixelFormat: TPixelFormat = pf32bit; //pf16bit;
+
+function LoadMappedBitmap( hInst: THandle; BmpResID: Integer; const Map: array of TColor )
+ : HBitmap;
+{* This function can be used to load bitmap and replace some it colors to
+ desired ones. This function especially useful when loaded by the such way
+ bitmap is used as toolbar bitmap - to replace some original colors to
+ system default colors. To use this function properly, the bitmap shoud
+ be prepared as 16-color bitmap, which uses only system colors. To do so,
+ create a new 16-color bitmap with needed dimensions in Borland Image Editor
+ and paste a bitmap image, copyed in another graphic tool, and then save it.
+ If this is not done, bitmap will not be loaded correctly! }
+function LoadMappedBitmapEx( MasterObj: PObj; hInst: THandle; BmpResName: PKOLChar;
+ const Map: array of TColor ): HBitmap;
+{* by Alex Pravdin: like LoadMappedBitmap, but much powerful. It uses
+ CreateMappedBitmapEx, so it understands any bitmap color format, including
+ pf24bit. Also, LoadMappedBitmapEx provides auto-destroying loaded resource
+ when MasterObj is destroyed. }
+function CreateMappedBitmap(Instance: THandle; Bitmap: Integer;
+ Flags: UINT; ColorMap: PColorMap; NumMaps: Integer): HBitmap; stdcall;
+{* Creates mapped bitmap replacing colors correspondently to the
+ ColorMap (each pare of colors defines color replaced and a color
+ used for replace it in the bitmap). See also CreateMappedBitmapEx. }
+function CreateMappedBitmapEx(Instance: THandle; BmpRsrcName: PKOLChar; Flags:
+ Cardinal; ColorMap: PColorMap; NumMaps: Integer): HBitmap;
+{* By Alex Pravdin.
+Creates mapped bitmap independently from bitmap color format (works
+correctly with bitmaps having format deeper than 8bit per pixel). }
+
+type
+ PIcon = ^TIcon;
+{ ----------------------------------------------------------------------
+ TIcon - icon image
+----------------------------------------------------------------------- }
+ TIcon = object( TObj )
+ {* Object type to incapsulate icon or cursor image. }
+ protected
+ {$IFDEF ICON_DIFF_WH}
+ FWidth: Integer;
+ FHeight: Integer;
+ {$ELSE}
+ FSize : Integer;
+ {$ENDIF}
+ FHandle: HIcon;
+ FShareIcon: Boolean;
+ procedure SetSize(const Value: Integer);
+ {$IFDEF ICON_DIFF_WH}
+ function GetIconSize: Integer;
+ {$ENDIF}
+ procedure SetHandle(const Value: HIcon);
+ function GetHotSpot: TPoint;
+ function GetEmpty: Boolean;
+ protected
+ destructor Destroy; virtual;
+ public
+ {$IFDEF ICONLOAD_PRESERVEBMPS}
+ ImgBmp, MskBmp : PBitmap;
+ Only_Bmp: Boolean;
+ {$ENDIF ICONLOAD_PRESERVEBMPS}
+ property Size : Integer read
+ {$IFDEF ICON_DIFF_WH}
+ GetIconSize
+ {$ELSE}
+ FSize
+ {$ENDIF}
+ write SetSize;
+ {* Icon dimension (width and/or height, which are equal to each other always). }
+ {$IFDEF ICON_DIFF_WH}
+ property Width: Integer read FWidth;
+ property Height: Integer read FHeight;
+ {$ENDIF}
+ property Handle : HIcon read FHandle write SetHandle;
+ {* Windows icon object handle. }
+ procedure SetHandleEx( NewHandle: HIcon );
+ {* Set Handle without changing Size (Width/Height). }
+ procedure Clear;
+ {* Clears icon, freeing image and allocated GDI resource (Handle). }
+ property Empty: Boolean read GetEmpty;
+ {* Returns True if icon is Empty. }
+ property ShareIcon : Boolean read FShareIcon write FShareIcon;
+ {* True, if icon object is shared and can not be deleted when TIcon object
+ is destroyed (set this flag is to True, if an icon is obtained from another
+ TIcon object, for example). }
+ property HotSpot : TPoint read GetHotSpot;
+ {* Hot spot point - for cursors. }
+ procedure Draw( DC : HDC; X, Y : Integer );
+ {* Draws icon onto given device context. Icon always is drawn transparently
+ using its transparency mask (stored internally in icon object). }
+ procedure StretchDraw( DC : HDC; Dest : TRect );
+ {* Draws icon onto given device context with stretching it to fit destination
+ rectangle. See also Draw. }
+ procedure LoadFromStream( Strm : PStream );
+ {* Loads icon from stream. If stream contains several icons (of
+ different dimentions), icon with the most appropriate size is loading. }
+ procedure LoadFromFile( const FileName : KOLString );
+ {* Load icon from file. If file contains several icons (of
+ different dimensions), icon with the most appropriate size is loading. }
+ procedure LoadFromResourceID( Inst: Integer; ResID: Integer; DesiredSize: Integer );
+ {* Loads icon from resource. To load system default icon, pass 0 as Inst and
+ one of followin values as ResID:
+ |<pre>
+ IDI_APPLICATION Default application icon.
+ IDI_ASTERISK Asterisk (used in informative messages).
+ IDI_EXCLAMATION Exclamation point (used in warning messages).
+ IDI_HAND Hand-shaped icon (used in serious warning messages).
+ IDI_QUESTION Question mark (used in prompting messages).
+ IDI_WINLOGO Windows logo.
+ |</pre> It is also possible to load icon from resources of another module,
+ if pass instance handle of loaded module as Inst parameter. }
+ procedure LoadFromResourceName( Inst: Integer; ResName: PKOLChar; DesiredSize: Integer );
+ {* Loads icon from resource. To load own application resource, pass
+ hInstance as Inst parameter. It is possible to load resource from
+ another module, if pass its instance handle as Inst. }
+ procedure LoadFromExecutable( const FileName: KOLString; IconIdx: Integer );
+ {* Loads icon from executable (exe or dll file). Always default sized icon
+ is loaded. It is possible also to get know how much icons are contained
+ in executable using gloabl function GetFileIconCount. To obtain icon of
+ another size, try to load given executable and use LoadFromResourceID
+ method. }
+ procedure SaveToStream( Strm : PStream );
+ {* Saves single icon to stream. To save icons with several different
+ dimensions, use global procedure SaveIcons2Stream. }
+ procedure SaveToFile( const FileName : KOLString );
+ {* Saves single icon to file. To save icons with several different
+ dimensions, use global procedure SaveIcons2File. }
+ function Convert2Bitmap( TranColor: TColor ): HBitmap;
+ {* Converts icon to bitmap, returning Windows GDI bitmap resource as
+ a result. It is possible later to assign returned bitmap handle to
+ Handle property of TBitmap object to use features of TBitmap.
+ Pass TranColor to replace transparent area of icon with given color. }
+ end;
+
+ procedure SaveIcons2Stream( const Icons : array of PIcon; Strm : PStream );
+ {* Saves several icons (of different dimentions) to stream. }
+ function SaveIcons2StreamEx( const BmpHandles: array of HBitmap; Strm: PStream ): Boolean;
+ {* Saves icons creating it from pairs of bitmaps and their masks.
+ BmpHandles array must contain pairs of bitmap handles, each pair
+ of color bitmap and mask bitmap of the same size. }
+ procedure SaveIcons2File( const Icons : array of PIcon; const FileName : KOLString );
+ {* Saves several icons (of different dimentions) to file. (Single file
+ with extension .ico can contain several different sized icon images
+ to use later one with the most appropriate size). }
+
+ function NewIcon: PIcon;
+ {* Creates new icon object, setting its Size to 32 by default. Created icon
+ is Empty. }
+ function GetFileIconCount( const FileName: KOLString ): Integer;
+ {* Returns number of icon resources stored in given (executable) file. }
+
+type
+ TIconHeader = packed record
+ idReserved: Word; (* Always set to 0 *)
+ idType: Word; (* Always set to 1 *)
+ idCount: Word; (* Number of icon images *)
+ (* immediately followed by idCount TIconDirEntries *)
+ end;
+
+ TIconDirEntry = packed record
+ bWidth: Byte; (* Width *)
+ bHeight: Byte; (* Height *)
+ bColorCount: Byte; (* Nr. of colors used *)
+ bReserved: Byte; (* not used, 0 *)
+ wPlanes: Word; (* not used, 0 *)
+ wBitCount: Word; (* not used, 0 *)
+ dwBytesInRes: Longint; (* total number of bytes in images *)
+ dwImageOffset: Longint;(* location of image from the beginning of file *)
+ end;
+
+function LoadImgIcon( RsrcName: PKOLChar; Size: Integer ): HIcon;
+{* Loads icon of specified size from the resource. }
+
+////////////////////////////////////////////////////////////////////////////////
+// UNIVERSAL CONTROL OBJECT //
+////////////////////////////////////////////////////////////////////////////////
+
+const
+ CM_EXECPROC = $8FFF;
+ CM_BASE = $B000;
+ CM_ACTIVATE = CM_BASE + 0;
+ CM_DEACTIVATE = CM_BASE + 1;
+ CM_ENTER = CM_BASE + 2;
+ CM_RELEASE = CM_BASE + 3;
+ CM_QUIT = CM_BASE + 4;
+ CM_COMMAND = CM_BASE + 5;
+ CM_MEASUREITEM = CM_BASE + 6;
+ CM_DRAWITEM = CM_BASE + 7;
+ CM_TRAYICON = CM_BASE + 8;
+ CM_INVALIDATE = CM_BASE + 9;
+ CM_UPDATE = CM_BASE + 10;
+ CM_NCUPDATE = CM_BASE + 11;
+ CM_SIZEPOS = CM_BASE + 12;
+ CM_SIZE = CM_BASE + 13;
+ CM_SETFOCUS = CM_BASE + 14;
+ CM_CBN_SELCHANGE = 15;
+
+ CM_UIACTIVATE = CM_BASE + 16;
+ CM_UIDEACTIVATE = CM_BASE + 17;
+ CM_PROCESS = CM_BASE + 18;
+ CM_SHOW = CM_BASE + 19;
+
+ CM_AUTOSIZE = CM_BASE + 20;
+ CM_MDIClientShowEdge = CM_BASE + 21;
+
+ CM_INVALIDATECHILD = CM_BASE + 22;
+ CM_FOCUSGRAPHCTL = CM_BASE + 23;
+
+ WM_SYNCPAINT = $88;
+
+ CN_BASE = $BC00;
+ CN_CHARTOITEM = CN_BASE + WM_CHARTOITEM;
+ CN_COMMAND = CN_BASE + WM_COMMAND;
+ CN_COMPAREITEM = CN_BASE + WM_COMPAREITEM;
+
+ CN_CTLCOLORMSGBOX = CN_BASE + WM_CTLCOLORMSGBOX;
+ CN_CTLCOLOREDIT = CN_BASE + WM_CTLCOLOREDIT;
+ CN_CTLCOLORLISTBOX = CN_BASE + WM_CTLCOLORLISTBOX;
+ CN_CTLCOLORBTN = CN_BASE + WM_CTLCOLORBTN;
+ CN_CTLCOLORDLG = CN_BASE + WM_CTLCOLORDLG;
+ CN_CTLCOLORSCROLLBAR = CN_BASE + WM_CTLCOLORSCROLLBAR;
+ CN_CTLCOLORSTATIC = CN_BASE + WM_CTLCOLORSTATIC;
+
+ CN_DELETEITEM = CN_BASE + WM_DELETEITEM;
+ CN_DRAWITEM = CN_BASE + WM_DRAWITEM;
+ CN_HSCROLL = CN_BASE + WM_HSCROLL;
+ CN_MEASUREITEM = CN_BASE + WM_MEASUREITEM;
+ CN_PARENTNOTIFY = CN_BASE + WM_PARENTNOTIFY;
+ CN_VKEYTOITEM = CN_BASE + WM_VKEYTOITEM;
+ CN_VSCROLL = CN_BASE + WM_VSCROLL;
+ CN_KEYDOWN = CN_BASE + WM_KEYDOWN;
+ CN_KEYUP = CN_BASE + WM_KEYUP;
+ CN_CHAR = CN_BASE + WM_CHAR;
+ CN_SYSKEYDOWN = CN_BASE + WM_SYSKEYDOWN;
+ CN_SYSCHAR = CN_BASE + WM_SYSCHAR;
+ CN_NOTIFY = CN_BASE + WM_NOTIFY;
+
+{$ENDIF WIN_GDI}
+const
+ ID_SELF: array[ 0..5 ] of KOLChar = ( 'S','E','L','F','_',#0 );
+ {* Identifier for window property "Self", stored directly in window, when
+ it is created. This property is used to [fast] find TControl object,
+ correspondent to given window handle (using API call GetProp). }
+
+{$IFDEF WIN_GDI}
+ ID_PREVPROC: array[ 0..9 ] of KOLChar = ( 'P','R','E','V','_','P','R','O','C',#0 );
+ {$IFNDEF USE_FLAGS}
+ RADIO_LAST: array[ 0..7 ] of KOLChar = ( 'R','A','D','_','L','S','T',#0 );
+ RADIO_1ST: array[ 0..7 ] of KOLChar = ( 'R','A','D','_','1','S','T',#0 );
+ {$ENDIF}
+ MIN_WND: array[ 0..7 ] of KOLChar = ( 'M','I','N','_','W','N','D',#0 );
+ DFLT_BTN: array[ 0..7 ] of KOLChar = ( 'D','F','L','T','_','B','T',#0 );
+ CNCL_BTN: array[ 0..7 ] of KOLChar = ( 'C','N','C','L','_','B','T',#0 );
+ DRAG_XY: array[ 0..7 ] of KOLChar = ( 'D','R','A','G','_','X','Y',#0 );
+ MDI_CHLDRN: array[ 0..10 ] of KOLChar = ( 'M','D','I','_','C','H','L','D','R','N',#0 );
+
+{$ENDIF WIN_GDI}
+const
+ MK_LBUTTON = 1;
+ MK_RBUTTON = 2;
+ MK_SHIFT = 4;
+ MK_CONTROL = 8;
+ MK_MBUTTON = $10;
+ MK_ALT = $20; // MK_ALT DEFINED
+ MK_LOCK = $40; // CAPS LOCK or SHIFT LOCK
+{$IFDEF WIN_GDI}
+
+{$IFNDEF NOT_USE_RICHEDIT}
+type
+ {$IFDEF UNICODE_CTRLS}
+ TCharFormat2 = TCharFormat2W;
+ {$ELSE}
+ {$IFDEF _D3orHigher}
+ TCharFormat2 = TCharFormat2A;
+ {$ELSE} // Delphi2
+ TCharFormat2 = packed record
+ cbSize: UINT;
+ dwMask: DWORD;
+ dwEffects: DWORD;
+ yHeight: Longint;
+ yOffset: Longint;
+ crTextColor: TColorRef;
+ bCharSet: Byte;
+ bPitchAndFamily: Byte;
+ szFaceName: array[0..LF_FACESIZE - 1] of KOLChar;
+ R2Bytes: Word;
+ wWeight: Word; { Font weight (LOGFONT value) }
+ sSpacing: Smallint; { Amount to space between letters }
+ crBackColor: TColorRef; { Background color }
+ lid: LCID; { Locale ID }
+ dwReserved: DWORD; { Reserved. Must be 0 }
+ sStyle: Smallint; { Style handle }
+ wKerning: Word; { Twip size above which to kern char pair }
+ bUnderlineType: Byte; { Underline type }
+ bAnimation: Byte; { Animated text like marching ants }
+ bRevAuthor: Byte; { Revision author index }
+ bReserved1: Byte;
+ end; {$ENDIF _D3orHigher}
+ {$ENDIF}
+
+ PParaFormat2 = ^TParaFormat2;
+ TParaFormat2 = packed record
+ cbSize: UINT;
+ dwMask: DWORD;
+ wNumbering: Word;
+ wReserved: Word;
+ dxStartIndent: Longint;
+ dxRightIndent: Longint;
+ dxOffset: Longint;
+ wAlignment: Word;
+ cTabCount: Smallint;
+ rgxTabs: array [0..MAX_TAB_STOPS - 1] of Longint;
+ dySpaceBefore: Longint; { Vertical spacing before para }
+ dySpaceAfter: Longint; { Vertical spacing after para }
+ dyLineSpacing: Longint; { Line spacing depending on Rule }
+ sStyle: Smallint; { Style handle }
+ bLineSpacingRule: Byte; { Rule for line spacing (see tom.doc) }
+ bCRC: Byte; { Reserved for CRC for rapid searching }
+ wShadingWeight: Word; { Shading in hundredths of a per cent }
+ wShadingStyle: Word; { Nibble 0: style, 1: cfpat, 2: cbpat }
+ wNumberingStart: Word; { Starting value for numbering }
+ wNumberingStyle: Word; { Alignment, roman/arabic, (), ), ., etc. }
+ wNumberingTab: Word; { Space bet 1st indent and 1st-line text }
+ wBorderSpace: Word; { Space between border and text (twips) }
+ wBorderWidth: Word; { Border pen width (twips) }
+ wBorders: Word; { Byte 0: bits specify which borders }
+ { Nibble 2: border style, 3: color index }
+ end;
+
+ TGetTextLengthEx = packed record
+ flags: DWORD; { flags (see GTL_XXX defines) }
+ codepage: UINT; { code page for translation (CP_ACP for default,
+ 1200 for Unicode }
+ end;
+
+const
+ PFM_SPACEBEFORE = $00000040;
+ PFM_SPACEAFTER = $00000080;
+ PFM_LINESPACING = $00000100;
+ PFM_STYLE = $00000400;
+ PFM_BORDER = $00000800; { (*) }
+ PFM_SHADING = $00001000; { (*) }
+ PFM_NUMBERINGSTYLE = $00002000; { (*) }
+ PFM_NUMBERINGTAB = $00004000; { (*) }
+ PFM_NUMBERINGSTART = $00008000; { (*) }
+
+ PFM_RTLPARA = $00010000;
+ PFM_KEEP = $00020000; { (*) }
+ PFM_KEEPNEXT = $00040000; { (*) }
+ PFM_PAGEBREAKBEFORE = $00080000; { (*) }
+ PFM_NOLINENUMBER = $00100000; { (*) }
+ PFM_NOWIDOWCONTROL = $00200000; { (*) }
+ PFM_DONOTHYPHEN = $00400000; { (*) }
+ PFM_SIDEBYSIDE = $00800000; { (*) }
+
+ PFM_TABLE = $c0000000; { (*) }
+ EM_REDO = WM_USER + 84;
+ EM_AUTOURLDETECT = WM_USER + 91;
+ EM_GETAUTOURLDETECT = WM_USER + 92;
+ CFM_UNDERLINETYPE = $00800000; { (*) }
+ CFM_HIDDEN = $0100; { (*) }
+ CFM_BACKCOLOR = $04000000;
+ CFE_AUTOBACKCOLOR = CFM_BACKCOLOR;
+ GTL_USECRLF = 1; { compute answer using CRLFs for paragraphs }
+ GTL_PRECISE = 2; { compute a precise answer }
+ GTL_CLOSE = 4; { fast computation of a "close" answer }
+ GTL_NUMCHARS = 8; { return the number of characters }
+ GTL_NUMBYTES = 16; { return the number of _bytes_ }
+ EM_GETTEXTLENGTHEX = WM_USER + 95;
+ EM_SETLANGOPTIONS = WM_USER + 120;
+ EM_GETLANGOPTIONS = WM_USER + 121;
+
+ EM_SETEDITSTYLE = $400 + 204;
+ EM_GETEDITSTYLE = $400 + 205;
+
+ SES_EMULATESYSEDIT = 1;
+ SES_BEEPONMAXTEXT = 2;
+ SES_EXTENDBACKCOLOR = 4;
+ SES_MAPCPS = 8;
+ SES_EMULATE10 = 16;
+ SES_USECRLF = 32;
+ SES_USEAIMM = 64;
+ SES_NOIME = 128;
+ SES_ALLOWBEEPS = 256;
+ SES_UPPERCASE = 512;
+ SES_LOWERCASE = 1024;
+ SES_NOINPUTSEQUENCECHK = 2048;
+ SES_BIDI = 4096;
+ SES_SCROLLONKILLFOCUS = 8192;
+ SES_XLTCRCRLFTOCR = 16384;
+
+ EM_GETSCROLLPOS = WM_USER + 221;
+ EM_SETSCROLLPOS = WM_USER + 222;
+ EM_GETZOOM = WM_USER + 224;
+ EM_SETZOOM = WM_USER + 225;
+{$ENDIF NOT_USE_RICHEDIT}
+{$ENDIF WIN_GDI}
+
+const
+ idx_fOnMessage = 0;
+ idx_fOldOnMessage = 1;
+ idx_fOnClick = 2;
+ idx_fOnMouseDown = 3;
+ idx_fOnMouseUp = 4;
+ idx_fOnMouseMove = 5;
+ idx_fOnMouseDblClk = 6;
+ idx_fOnMouseWheel = 7;
+ idx_fOnMouseEnter = 8;
+ idx_fOnMouseLeave = 9;
+ idx_fOnTestMouseOver = 10;
+ idx_fGraphCtlMouseEvent = 11;
+ idx_fMouseLeaveProc = 12;
+ idx_fOnScroll = 13;
+ idx_fOnChar = 14;
+ idx_fOnDeadChar = 15;
+ idx_fOnKeyUp = 16;
+ idx_fOnKeyDown = 17;
+ idx_fOnChangeCtl = 18;
+ idx_fOnEnter = 19;
+ idx_fOnLeave = 20;
+ idx_fLeave = 21;
+ idx_fOnPaint = 22;
+ idx_fOnPaint2 = 23;
+ idx_fOnPrepaint = 24;
+ idx_fOnPostPaint = 25;
+ idx_fPaintProc = 26;
+ idx_fOnEraseBkgnd = 27;
+ idx_fOnDrawItem = 28;
+ idx_fOnMeasureItem = 29;
+ idx_fDragCallback = 30;
+ idx_fOnSelChange = 31;
+ idx_fOnResize = 32;
+ idx_fOnHide = 33;
+ idx_fOnShow = 34;
+ idx_fOnClose = 35;
+ idx_fOnMove = 36;
+ idx_fOnMoving = 37;
+ idx_fOnHelp = 38;
+ idx_fOnQueryEndSession = 39;
+ idx_fOnMinimize = 40;
+ idx_fOnMaximize = 41;
+ idx_fOnRestore = 42;
+ idx_fOnLVCustomDraw = 43;
+ idx_fOnEndEditLVITem = 44;
+ idx_fOnLVData = 45;
+ idx_fOnCompareLVItems = 46;
+ idx_FOnLVStateChange = 47;
+ idx_fOnDeleteLVItem = 48;
+ idx_fOnColumnClick = 49;
+ idx_FOnSBBeforeScroll = 50;
+ idx_FOnSBScroll = 51;
+ idx_FOnDropDown = 52;
+ idx_FOnCloseUp = 53;
+ idx_FOnSplit = 54;
+ idx_FOnProgress = 55;
+ idx_FOnBitBtnDraw = 56;
+ idx_FOnTVBeginDrag = 57;
+ idx_FOnTVBeginEdit = 58;
+
+ idx_FOnTVEndEdit = 59;
+ idx_FOnTVExpanding = 60;
+ idx_FOnTVExpanded = 61;
+ idx_FOnTVSelChanging = 62;
+
+ idx_FOnTVDelete = 63;
+ idx_FOnDTPUserString = 64;
+ idx_FOnREInsModeChg = 65;
+ idx_FOnREOverURL = 66;
+ idx_FOnREURLClick = 67;
+ idx_fOnDropFiles = 68;
+
+ idx_LastEvent = 68;
+
+ idx_fWndFunc = 69;
+ idx_fDoInvalidate = 70;
+ idx_fOnDynHandlers = 71;
+ idx_fPass2DefProc = 72;
+ idx_fWndProcKeybd = 73;
+ idx_fControlClick = 74;
+ idx_fAutoSize = 75;
+ //{-2.95}//idx_fWndProcResizeFlicks
+ idx_fGotoControl = 76;
+ idx_fNotifyChild = 77;
+ idx_fScrollChildren = 78;
+ //idx_FBitBtnGetCaption
+ //idx_FBitBtnExtDraw
+ idx_fCreateWndExt = 79;
+ idx_fExMsgProc = 80;
+ idx_LastProc = 80;
+
+const
+ ANCHOR_LEFT = 1;
+ ANCHOR_RIGHT = 2;
+ ANCHOR_TOP = 4;
+ ANCHOR_BOTTOM = 8;
+ SELF_REQ_PAINT = 16;
+ PARENT_REQ_PAINT = 32;
+ MDI_NOT_AVAILABLE = 64;
+ MDI_DESTROYING = 128;
+
+type
+///////////////////////////////////////////
+{$ifndef _D6orHigher} //
+///////////////////////////////////////////
+ TMethod = packed record
+ {* Is defined here because using of VCL classes.pas unit is
+ not recommended in XCL. This record type is used often
+ to set/access event handlers, referring to a procedure
+ of object (usually to set such event to an ordinal
+ procedure setting Data field to nil. }
+ Code: Pointer; // Pointer to method code.
+ {* If used to fake assigning to event handler of type 'procedure
+ of object' with ordinal procedure pointer, use symbol '@'
+ before method:
+ |<br> <font face="Courier"><b>
+ | Method.Code := @MyProcedure;
+ |</b></font> }
+ Data: Pointer; // Pointer to object, owning the method.
+ {* To fake event of type 'procedure of object' with setting it to
+ ordinal procedure assign here NIL; }
+ end;
+ {* When assigning TMethod record to event handler, typecast it with
+ desired event type, e.g.:
+ |<br> <font face="Courier"><b>
+ | SomeObject.OnSomeEvent := TOnSomeEvent( Method );
+ |</b></font><br> }
+///////////////////////////////////////////
+{$endif} //
+///////////////////////////////////////////
+ PMethod = ^TMethod;
+ {* }
+
+ function MakeMethod( Data, Code: Pointer ): TMethod;
+ {* Help function to construct TMethod record. Can be useful to
+ assign regular type procedure/function as event handler for
+ event, defined as object method (do not forget, that in that
+ case it must have first dummy parameter to replace @Self,
+ passed in EAX to methods of object). }
+
+type
+ T3Style = ( F3_Maximize, F3_ClipChildren, F3_ClipSiblings,
+ F3_Disabled, F3_Visible, F3_Minimize,
+ F3_Child, F3_Popup );
+ T3Styles = Set of T3Style;
+
+ T2Style = ( F2_Tabstop, F2_Group, F2_Thickframe, F2_Sysmenu,
+ F2_HScroll, F2_VScroll, F2_Dlgframe, F2_Border );
+ T2Styles = Set of T2Style;
+
+ TStyle = packed record
+ CASE Integer OF
+ 1: (
+ f0_Style: Byte;
+ f1_Style: Byte;
+ f2_Style: T2Styles;
+ f3_Style: T3Styles;
+ );
+ 2: ( Value: DWORD; );
+ end;
+
+ T1Flag = ( G1_WordWrap, G1_PreventResize, G1_IconShared,
+ G1_IgnoreWndCaption, G1_SizeRedraw, G1_IsStaticControl,
+ G1_CanNotDoublebuf, G1_HasRadio ); //
+ T1Flags = Set of T1Flag;
+
+ T2Flag = ( G2_Transparent, G2_DoubleBuffered, G2_ClassicTransparent,
+ G2_Destroying, G2_BeginDestroying,
+ G2_ChangedPos, G2_ChangedW, G2_ChangedH ); //
+ T2Flags = Set of T2Flag;
+
+ T3Flag = ( G3_ClassicTransparent, G3_IsForm, G3_SizeGrip, G3_IsControl,
+ G3_IsApplet, G3_IsMDIChild, G3_Flat, G3_MouseInCtl ); //
+ T3Flags = Set of T3Flag;
+
+ T4Flag = ( G4_CreateHidden, G4_VisibleWOParent, G4_NotUseAlign,
+ G4_CreateVisible, G4_Pushed, G4_Checked, G4_Hot, G4_Pressed ); //
+ // use G4_Pushed also as KeyPreviewing for form
+ T4Flags = Set of T4Flag;
+
+ T5Flag = ( G5_IsButton, G5_IsBitBtn, G5_IsSplitter, G5_IsGroupbox,
+ G5_IsCommonCtl, G5_3ButtonPress, G5_EraseBkgnd, G5_IgnoreDefault );
+ T5Flags = Set of T5Flag;
+
+ T6Flag = ( G6_KeyPreview, G6_DefaultBtn, G6_CancelBtn, G6_Focused,
+ G6_GraphicCtl, G6_CtlClassNameChg, G6_RightClick, G6_Dragging );
+ T6Flags = Set of T6Flag;
+
+ PControl = ^TControl;
+ {* Type of pointer to TControl visual object. All
+ |<a href="kol_pas.htm#visual_objects_constructors">
+ constructing functions
+ |</a>
+ New[ControlName] are returning
+ pointer of this type. Do not forget about some difference
+ of using objects from using classes. Identifier Self for
+ methods of object is not of pointer type, and to pass
+ pointer to Self, it is necessary to pass @Self instead.
+ At the same time, to use pointer to object in 'WITH' operator,
+ it is necessary to apply suffix '^' to pointer to get know
+ to compiler, what do You want. }
+{$IFDEF WIN}
+ TWindowFunc = function( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
+ : Boolean;
+ {* Event type to define custom extended message handlers (as pointers to
+ procedure entry points). Such handlers are usually defined like add-ons,
+ extending behaviour of certain controls and attached using AttachProc
+ method of TControl. If the handler detects, that it is necessary to stop
+ further message processing, it should return True. }
+{$ENDIF WIN}
+
+ TMouseButton = ( mbNone, mbLeft, mbRight, mbMiddle );
+ {* Available mouse buttons. mbNone is useful to get know, that
+ there were no mouse buttons pressed. }
+
+ TMouseEventData = packed Record
+ {* Record to pass it to mouse handling routines, assigned to OnMouseXXXX
+ events. }
+ Button: TMouseButton;
+ StopHandling: Boolean; // Set it to True in OnMouseXXXX event handler to
+ // stop further processing
+ R1, R2: Byte; // Not used
+ Shift : DWORD; // HiWord( Shift ) = zDelta in WM_MOUSEWHEEL
+ X, Y : SmallInt;
+ end;
+
+ TOnMouse = procedure( Sender: PControl; var Mouse: TMouseEventData ) of object;
+ {* Common mouse handling event type. }
+
+ TOnKey = procedure( Sender: PControl; var Key: Longint; Shift: DWORD ) of object;
+ {* Key events. Shift is a combination of flags MK_SHIFT, MK_CONTROL, MK_ALT.
+ (See GetShiftState funtion). }
+
+ TOnChar = procedure( Sender: PControl; var Key: KOLChar; Shift: DWORD ) of object;
+ {* Char event. Shift is a combination of flags MK_SHIFT, MK_CONTROL, MK_ALT. }
+
+ TTabKey = ( tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn );
+ {* Available tabulating key groups. }
+ TTabKeys = Set of TTabKey;
+ {* Set of tabulating key groups, allowed to be used in with a control
+ (are installed by TControl.LookTabKey property). }
+
+{$IFDEF WIN}
+ TOnMessage = function( var Msg: TMsg; var Rslt: Integer ): Boolean of object;
+ {* Event type for events, which allows to extend behaviour of windowed controls
+ descendants using add-ons. }
+{$ENDIF WIN}
+
+ TOnEventAccept = procedure( Sender: PObj; var Accept: Boolean ) of object;
+ {* Event type for OnClose event. }
+ TCloseQueryReason = ( qClose, qShutdown, qLogoff );
+ {* Request reason type to call OnClose and OnQueryEndSession. }
+ TWindowState = ( wsNormal, wsMinimized, wsMaximized );
+ {* Avalable states of TControl's window object. }
+
+ TOnSplit = function( Sender: PControl; NewSize1, NewSize2: Integer ): Boolean of object;
+ {* Event type for OnSplit event handler, designed specially for splitter
+ control. Event handler must return True to accept new size of previous
+ (to splitter) control and new size of the rest of client area of parent. }
+
+ TOnTVBeginDrag = procedure( Sender: PControl; Item: THandle ) of object;
+ {* Event type for OnTVBeginDrag event (defined for tree view control). }
+ TOnTVBeginEdit = function( Sender: PControl; Item: THandle ): Boolean of object;
+ {* Event type for OnTVBeginEdit event (for tree view control). }
+ TOnTVEndEdit = function( Sender: PControl; Item: THandle; const NewTxt: KOL_String )
+ : Boolean of object;
+ {* Event type for TOnTVEndEdit event. }
+ TOnTVExpanding = function( Sender: PControl; Item: THandle; Expand: Boolean )
+ : Boolean of object;
+ {* Event type for TOnTVExpanding event. }
+ TOnTVExpanded = procedure( Sender: PControl; Item: THandle; Expand: Boolean )
+ of object;
+ {* Event type for OnTVExpanded event. }
+ TOnTVDelete = procedure( Sender: PControl; Item: THandle ) of object;
+ {* Event type for OnTVDelete event. }
+
+ //--------- by Sergey Shisminzev :
+ TOnTVSelChanging = function(Sender: PControl; oldItem, newItem: THandle): Boolean //~ss
+ of object;
+ {* When the handler returns False, selection is not changed. }
+ //-------------------------------
+ TOnDrag = function( Sender: PControl; ScrX, ScrY: Integer; var CursorShape: Integer;
+ var Stop: Boolean ): Boolean of object;
+ {* Event, called during dragging operation (it is initiated
+ with method Drag, where callback function of type TOnDrag is
+ passed as a parameter). Callback function receives Stop parameter True,
+ when operation is finishing. Otherwise, it can set it to True to force
+ finishing the operation (in such case, returning False means cancelling
+ drag operation, True - successful drag and in this last case callback is
+ no more called). During the operation, when input Stop value is False,
+ callback function can control Cursor shape, and return True, if the operation
+ can be finished successfully at the given ScrX, ScrY position.
+ ScrX, ScrY are screen coordinates of the mouse cursor. }
+
+{$IFDEF WIN}
+ TCreateParams = packed record
+ {* Record to pass it through CreateSubClass method. }
+ Caption: PKOLChar;
+ Style: cardinal;
+ ExStyle: cardinal;
+ X, Y: Integer;
+ Width, Height: Integer;
+ WndParent: HWnd;
+ Param: Pointer;
+ WindowClass: TWndClass;
+ WinClassName: array[0..63] of KOLChar;
+ end;
+
+ TCreateWndParams = packed Record
+ ExStyle: DWORD;
+ WinClassName: PKOLChar;
+ Caption: PKOLChar;
+ Style: DWORD;
+ X, Y, Width, Height: Integer;
+ WndParent: HWnd;
+ Menu: HMenu;
+ Inst: THandle;
+ Param: Pointer;
+ WinClsNamBuf: array[ 0..63 ] of KOLChar;
+ WindowClass: TWndClass;
+ end;
+
+ PCommandActions = ^TCommandActions;
+ TCommandActions = packed Record
+ aClear: procedure( Sender: PControl );
+ aAddText: procedure( Sender: PControl; const S: AnsiString );
+ aClick, aEnter, aLeave: WORD;
+ aChange: SmallInt; aSelChange: SmallInt;
+ aGetCount, aSetCount, aGetItemLength, aGetItemText, aSetItemText,
+ aGetItemData, aSetItemData: WORD;
+ aAddItem, aDeleteItem, aInsertItem: WORD;
+ aFindItem, aFindPartial: WORD;
+ bItem2Pos, bPos2Item: BYTE;
+ aGetSelCount, aGetSelected, aGetSelRange,
+ aGetCurrent,
+ aSetSelected, aSetCurrent, aSetSelRange, aExSetSelRange,
+ aGetSelection, aReplaceSel: WORD;
+ aTextAlignLeft, aTextAlignRight, aTextAlignCenter: WORD;
+ bTextAlignMask: Byte;
+ bVertAlignTop, bVertAlignCenter, bVertAlignBottom: Byte;
+ aDir, aSetLimit: Word; aSetImgList: Word;
+ aSetBkColor: Word;
+ aItem2XY: Word;
+ end;
+
+ {$IFDEF COMMANDACTIONS_OBJ}
+ PCommandActionsObj = ^TCommandActionsObj;
+ TCommandActionsObj = object(TObj)
+ aClear: procedure( Sender: PControl );
+ aAddText: procedure( Sender: PControl; const S: KOLString );
+ aClick, aEnter, aLeave: WORD;
+ aChange: SmallInt; aSelChange: SmallInt;
+ aGetCount, aSetCount, aGetItemLength, aGetItemText, aSetItemText,
+ aGetItemData, aSetItemData: WORD;
+ aAddItem, aDeleteItem, aInsertItem: WORD;
+ aFindItem, aFindPartial: WORD;
+ bItem2Pos, bPos2Item: BYTE;
+ aGetSelCount, aGetSelected, aGetSelRange,
+ aGetCurrent,
+ aSetSelected, aSetCurrent, aSetSelRange, aExSetSelRange,
+ aGetSelection, aReplaceSel: WORD;
+ aTextAlignLeft, aTextAlignRight, aTextAlignCenter: WORD;
+ bTextAlignMask: Byte;
+ bVertAlignTop, bVertAlignCenter, bVertAlignBottom: Byte;
+ aDir, aSetLimit: Word; aSetImgList: Word;
+ aSetBkColor: Word;
+ aItem2XY: Word;
+ fIndexInActions: Integer;
+ destructor Destroy; virtual;
+ end;
+ {$ENDIF}
+{$ENDIF WIN}
+
+ TTextAlign = ( taLeft, taRight, taCenter );
+ {* Text alignments available. }
+ TRichTextAlign = ( raLeft, raRight, raCenter,
+ // all other are only set but can not be displayed:
+ raJustify, // displayed like raLeft (though stored normally)
+ raInterLetter, raScaled, raGlyphs, raSnapGrid );
+ {* Text alignment styles, available for RichEdit control. }
+ TVerticalAlign = ( vaTop, vaCenter, vaBottom );
+ {* Vertical alignments available. }
+ TControlAlign = ( caNone, caLeft, caTop, caRight, caBottom, caClient );
+ {* Control alignments available. }
+ TAligning = (oaWaitAlign,oaFromSelf,oaAligning);
+ TAlignings = set of TAligning;
+
+ TBitBtnOption = ( bboImageList,
+ bboNoBorder,
+ bboNoCaption,
+ bboFixed,
+ bboFocusRect );
+ {* Options available for NewBitBtn. }
+ TBitBtnOptions = set of TBitBtnOption;
+ {* Set of options, available for NewBitBtn. }
+ TGlyphLayout = ( glyphLeft, glyphTop, glyphRight, glyphBottom, glyphOver );
+ {* Layout of glyph (for NewBitBtn). Layout glyphOver means that text is
+ drawn over glyph. }
+ TOnBitBtnDraw = function( Sender: PControl; BtnState: Integer ): Boolean of object;
+ {* Event type for TControl.OnBitBtnDraw event (which is called just before
+ drawing the BitBtn). If handler returns True, there are no drawing occure.
+ BtnState, passed to a handler, determines current button state and can
+ be following: 0 - not pressed, 1 - pressed, 2 - disabled, 3 - focused.
+ Value 4 is reserved for highlight state (then mouse is over it), but
+ highlighting is provided only if property Flat is set to True (or one
+ of events OnMouseEnter / OnMouseLeave is assigned to something). }
+
+ TListViewStyle = ( lvsIcon, lvsSmallIcon, lvsList, lvsDetail, lvsDetailNoHeader );
+ {* Styles of view for ListView control (see NewListVew). }
+
+ TListViewItemStates = ( lvisFocus, lvisSelect, lvisBlend, lvisHighlight );
+ TListViewItemState = Set of TListViewItemStates;
+ TListViewOption = (
+ lvoIconLeft, // in lvsIcon, lvsSmallIcon place icon left from text (rather then top)
+ lvoAutoArrange, // keep icons auto arranged in lvsIcon and lvsSmallIcon view
+ lvoButton, // icons look like buttons in lvsIcon view
+ lvoEditLabel, // allows edit labels inplace (first column #0 text)
+ lvoNoLabelWrap, // item text on a single line in lvsIcon view (by default, item text may wrap in lvsIcon view).
+ lvoNoScroll, // obvious
+ lvoNoSortHeader, // click on header button does not lead to sort items
+ lvoHideSel, // hide selection when not in focus
+ lvoMultiselect, // allow to select multiple items
+ lvoSortAscending,
+ lvoSortDescending,
+ // extended styles (not documented in my Win32.hlp :( , got from VCL source:
+ lvoGridLines,
+ lvoSubItemImages,
+ lvoCheckBoxes,
+ lvoTrackSelect,
+ lvoHeaderDragDrop,
+ lvoRowSelect,
+ lvoOneClickActivate,
+ lvoTwoClickActivate,
+ lvoFlatsb,
+ lvoRegional,
+ lvoInfoTip,
+ lvoUnderlineHot,
+ lvoMultiWorkares,
+ // virtual list view style:
+ lvoOwnerData,
+ // custom draw style:
+ lvoOwnerDrawFixed
+ );
+ TListViewOptions = Set of TListViewOption;
+
+ TOnEditLVItem = function( Sender: PControl; Idx, Col: Integer; NewText: PKOL_Char ): Boolean
+ of object;
+ {* Event type for OnEndEditLVItem. Return True in handler to accept new text value. }
+ TOnDeleteLVItem = procedure( Sender: PControl; Idx: Integer ) of object;
+ {* Event type for OnDeleteLVItem event. }
+ TOnLVData = procedure( Sender: PControl; Idx, SubItem: Integer;
+ var Txt: KOL_String; var ImgIdx: Integer; var State: DWORD;
+ var Store: Boolean ) of object;
+ {* Event type for OnLVData event. Used to provide virtual list view control
+ (i.e. having lvoOwnerData style) with actual data on request. Use parameter
+ Store as a flag if control should store obtained data by itself or not. }
+ {$IFDEF ENABLE_DEPRECATED}
+ {$DEFINE interface_1} {$I KOL_deprecated.inc} {$UNDEF interface_1}
+ {$ENDIF DISABLE_DEPRECATED}
+ TOnCompareLVItems = function( Sender: PControl; Idx1, Idx2: Integer ): Integer
+ of object;
+ {* Event type to compare two items of the list view (while sorting it). }
+ TOnLVColumnClick = procedure( Sender: PControl; Idx: Integer ) of object;
+ {* Event type for OnColumnClick event. }
+ TOnLVStateChange = procedure( Sender: PControl; IdxFrom, IdxTo: Integer; OldState, NewState: DWORD )
+ of object;
+ {* Event type for OnLVStateChange event, called in responce to select/unselect
+ a single item or items range in list view control). }
+
+ TDrawActions = ( odaEntire, odaFocus, odaSelect );
+ TDrawAction = Set of TDrawActions;
+ TDrawStates = ( odsSelected, odsGrayed, odsDisabled, odsChecked, odsFocused,
+ odsDefault, odsHotlist, odsInactive,
+ odsNoAccel, odsNoFocusRect,
+ ods400reserved, ods800reserved,
+ odsComboboxEdit,
+ // specific for common controls:
+ odsMarked, odsIndeterminate );
+ {* Possible draw states.
+ |<br>odsSelected - The menu item's status is selected.
+ |<br>odsGrayed - The item is to be grayed. This bit is used only in a menu.
+ |<br>odsDisabled - The item is to be drawn as disabled.
+ |<br>odsChecked - The menu item is to be checked. This bit is used only in
+ a menu.
+ |<br>odsFocused - The item has the keyboard focus.
+ |<br>odsDefault - The item is the default item.
+ |<br>odsHotList - <b>Windows 98, Windows 2000:</b> The item is being
+ hot-tracked, that is, the item will be highlighted when
+ the mouse is on the item.
+ |<br>odsInactive - <b>Windows 98, Windows 2000:</b> The item is inactive
+ and the window associated with the menu is inactive.
+ |<br>odsNoAccel - <b>Windows 2000:</b> The control is drawn without the
+ keyboard accelerator cues.
+ |<br>odsNoFocusRect - <b>Windows 2000:</b> The control is drawn without
+ focus indicator cues.
+ |<br>odsComboboxEdit - The drawing takes place in the selection field
+ (edit control) of an owner-drawn combo box.
+ |<br>odsMarked - for Common controls only. The item is marked. The meaning
+ of this is up to the implementation.
+ |<br>odsIndeterminate - for Common Controls only. The item is in an
+ indeterminate state. }
+ TDrawState = Set of TDrawStates;
+ {* Set of possible draw states. }
+ TOnDrawItem = function( Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer;
+ DrawAction: TDrawAction; ItemState: TDrawState ): Boolean of object;
+ {* Event type for OnDrawItem event (applied to list box, combo box, list view). }
+ TOnMeasureItem = function( Sender: PObj; Idx: Integer ): Integer of object;
+ {* Event type for OnMeasureItem event. The event handler must return height of list box
+ item as a result. }
+ TGetLVItemPart = ( lvipBounds, lvipIcon, lvipLabel, lvupIconAndLabel );
+ {* }
+ TWherePosLVItem = ( lvwpOnIcon, lvwpOnLabel, lvwpOnStateIcon, lvwpOnColumn,
+ lvwpOnItem );
+ {* }
+
+ TOnLVCustomDraw = function( Sender: PControl; DC: HDC; Stage: DWORD;
+ ItemIdx, SubItemIdx: Integer; const Rect: TRect;
+ ItemState: TDrawState; var TextColor, BackColor: TColor )
+ : DWORD of object;
+ {* Event type for OnLVCustomDraw event. }
+
+ TOnPaint = procedure( Sender: PControl; DC: HDC ) of object;
+ TPaintProc = procedure( DC: HDC ) of object;
+
+ TGradientStyle = ( gsVertical, gsHorizontal, gsRectangle, gsElliptic, gsRombic,
+ gsTopToBottom, gsBottomToTop );
+ {* Gradient fill styles. See also TGradientLayout. }
+ TGradientLayout = ( glTopLeft, glTop, glTopRight,
+ glLeft, glCenter, glRight,
+ glBottomLeft, glBottom, glBottomRight );
+ {* Position of starting line / point for gradient filling. Depending on
+ TGradientStyle, means either position of first line of first rectangle
+ (ellipse) to be expanded in a loop to fit entire gradient panel area. }
+
+ TEditOption = ( eoNoHScroll, eoNoVScroll, eoLowercase, eoMultiline,
+ eoNoHideSel, eoOemConvert, eoPassword, eoReadonly,
+ eoUpperCase, eoWantReturn, eoWantTab, eoNumber );
+ {* Available edit options.
+ |<br> Please note, that eoWantTab option just removes TAB key from a list
+ of keys available to tabulate from the edit control. To provide insertion
+ of tabulating key, do so in TControl.OnChar event handler. Sorry for
+ inconvenience, but this is because such behaviour is not must in all cases.
+ See also TControl.EditTabChar property. }
+ TEditOptions = Set of TEditOption;
+ {* Set of available edit options. }
+
+ TEditPositions = packed record
+ SelStart: Integer;
+ SelLength: Integer;
+ TopLine: Integer;
+ TopColumn: Integer;
+ ScrollPos: TPoint;
+ RestoreScroll: Boolean;
+ end;
+
+ TRichFmtArea = ( raSelection, raWord, raAll );
+ {* Characters formatting area for RichEdit. }
+ TRETextFormat = ( reRTF, reText, rePlainRTF, reRTFNoObjs, rePlainRTFNoObjs,
+ reTextized, reUnicode, reTextUnicode );
+ {* Available formats for transfer RichEdit text using property
+ TControl.RE_Text.
+ |<pre>
+ reRTF - normal rich text (no transformations)
+ reText - plain text only (without OLE objects)
+ reTextized - plain text with text representation of COM objects
+ rePlainRTF - reRTF without language-specific keywords
+ reRTFNoObjs - reRTF without OLE objects
+ rePlainRTFNoObjs - rePlainRTF without OLE objects
+ reUnicode - stream is 2-byte Unicode characters rather then 1-byte Ansi
+ |</pre> }
+ TRichUnderline = ( ruSingle, ruWord, ruDouble, ruDotted,
+ //all other - only for RichEditv3.0:
+ ruDash, ruDashDot, ruDashDotDot, ruWave, ruThick, ruHairLine );
+ {* Rich text exteded underline styles (available only for RichEdit v2.0,
+ and even for RichEdit v2.0 additional styles can not displayed - but
+ ruDotted under Windows2000 is working). }
+ TRichTextSizes = ( rtsNoUseCRLF, rtsNoPrecise, rtsClose, rtsBytes );
+ {* Options to calculate size of rich text. Available only for RichEdit2.0
+ or higher. }
+ TRichTextSize = set of TRichTextSizes;
+ {* Set of all available optioins to calculate rich text size using
+ property TControl.RE_TextSize[ options ]. }
+ TRichNumbering = ( rnNone, rnBullets, rnArabic, rnLLetter, rnULetter,
+ rnLRoman, rnURoman );
+ {* Advanced numbering styles for paragraph (RichEdit).
+ |<pre>
+ rnNone - no numbering
+ rnBullets - bullets only
+ rnArabic - 1, 2, 3, 4, ...
+ rnLLetter - a, b, c, d, ...
+ rnULetter - A, B, C, D, ...
+ rnLRoman - i, ii, iii, iv, ...
+ rnURoman - I, II, III, IV, ...
+ rnNoNumber - do not show any numbers (but numbering is taking place).
+ |</pre> }
+ TRichNumBrackets = ( rnbRight, rnbBoth, rnbPeriod, rnbPlain, rnbNoNumber );
+ {* Brackets around number:
+ |<pre>
+ rnbRight - 1) 2) 3) - this is default !
+ rnbBoth - (1) (2) (3)
+ rnbPeriod - 1. 2. 3.
+ rnbPlain - 1 2 3
+ |</pre> }
+ TBorderEdge = (beLeft, beTop, beRight, beBottom);
+ {* Borders of rectangle. }
+
+ {$IFNDEF NOT_USE_RICHEDIT}
+ {$IFDEF _D3orHigher}
+ TCharFormat = TCharFormat2;
+ {$ENDIF _D3orHigher}
+ PCharFormat = ^TCharFormat;
+ TParaFormat = TParaFormat2;
+ {$ENDIF NOT_USE_RICHEDIT}
+
+ TOnTestMouseOver = function( Sender: PControl ): Boolean of object;
+ {* Event type for TControl.OnTestMouseOver event. The handler should
+ return True, if it detects if the mouse is over control. }
+
+ TEdgeStyle = ( esRaised, esLowered, esNone, esTransparent, esSolid );
+ {* Edge styles (for panel - see NewPanel).
+ esTransparent and esSolid - special styles equivalent to esNone
+ except GRushControls are used via USE_GRUSH symbol (ToGRush.pas) }
+
+ TListOption = ( loNoHideScroll, loNoExtendSel, loMultiColumn, loMultiSelect,
+ loNoIntegralHeight, loNoSel, loSort, loTabstops,
+ loNoStrings, loNoData, loOwnerDrawFixed, loOwnerDrawVariable,
+ loHScroll );
+ {* Options for ListBox (see NewListbox).
+ To use loHScroll, you also have to send LB_SETHORIZONTALEXTENT with a
+ maximum width of a line in pixels (wParam)! }
+ TListOptions = Set of TListOption;
+ {* Set of available options for Listbox. }
+
+ TComboOption = ( coReadOnly, coNoHScroll, coAlwaysVScroll, coLowerCase,
+ coNoIntegralHeight, coOemConvert, coSort, coUpperCase,
+ coOwnerDrawFixed, coOwnerDrawVariable, coSimple );
+ {* Options for combobox. }
+ TComboOptions = Set of TComboOption;
+ {* Set of options available for combobox. }
+
+ TProgressbarOption = ( pboVertical, pboSmooth );
+ {* Options for progress bar. }
+ TProgressbarOptions = set of TProgressbarOption;
+ {* Set of options available for progress bar. }
+
+ TTreeViewOption = ( tvoNoLines, tvoLinesRoot, tvoNoButtons, tvoEditLabels, tvoHideSel,
+ tvoDragDrop, tvoNoTooltips, tvoCheckBoxes, tvoTrackSelect,
+ tvoSingleExpand, tvoInfoTip, tvoFullRowSelect, tvoNoScroll,
+ tvoNonEvenHeight );
+ {* Tree view options. }
+ TTreeViewOptions = set of TTreeViewOption;
+ {* Set of tree view options. }
+
+ TTabControlOption = ( tcoButtons, tcoFixedWidth, tcoFocusTabs,
+ tcoIconLeft, tcoLabelLeft,
+ tcoMultiline, tcoMultiselect, tcoFitRows, tcoScrollOpposite,
+ tcoBottom, tcoVertical, tcoFlat, tcoHotTrack, tcoBorder,
+ tcoOwnerDrawFixed );
+ {* Options, available for TabControl. }
+ TTabControlOptions = set of TTabControlOption;
+ {* Set of options, available for TAbControl during its creation (by
+ NewTabControl function). }
+
+ TToolbarOption = ( tboTextRight, tboTextBottom, tboFlat, tboTransparent,
+ tboWrapable, tboNoDivider, tbo3DBorder, tboCustomErase );
+ {* Toolbar options. When tboFlat is set and toolbar is placed onto panel,
+ set its property Transparent to TRUE to provide its correct view. }
+ TToolbarOptions = Set of TToolbarOption;
+ {* Set of toolbar options. }
+ TOnToolbarButtonClick = procedure( Sender: PControl; BtnID: Integer ) of object;
+ {* Special event type to handle separate toolbar buttons click events. }
+ TOnTBCustomDraw = function( Sender: PControl; var NMCD: TNMTBCustomDraw ): Integer of object;
+ {* Event type for OnTBCustomDraw event. }
+
+ TDateTimePickerOption = ( dtpoTime, dtpoDateLong, dtpoUpDown, dtpoRightAlign,
+ dtpoShowNone, dtpoParseInput );
+ {* }
+ TDateTimePickerOptions = set of TDateTimePickerOption;
+ {* }
+ TDTParseInputEvent = procedure(Sender: PControl; const UserString: KOLString;
+ var DateAndTime: TDateTime; var AllowChange: Boolean) of object;
+ {* }
+ TDateTimeRange = packed record
+ FromDate, ToDate: TDateTime;
+ end;
+ {* }
+ TDateTimePickerColor = ( dtpcBackground, dtpcText, dtpcTitleBk,
+ dtpcTitleText, dtpcMonthBk, dtpcTrailingText );
+ {MCSC_BACKGROUND = 0; // the background color (between months)
+ MCSC_TEXT = 1; // the dates
+ MCSC_TITLEBK = 2; // background of the title
+ MCSC_TITLETEXT = 3;
+ MCSC_MONTHBK = 4; // background within the month cal
+ MCSC_TRAILINGTEXT = 5; // the text color of header & trailing days}
+
+ TOnDropFiles = procedure( Sender: PControl; const FileList: KOL_String; const Pt: TPoint ) of object;
+ {* An event type for OnDropFiles event. When the event is occur, FileList
+ parameter contains a list of files dropped. File names in a list are
+ separated with #13 character. This allows You to assign it to TStrList
+ object using its property Text (for example):
+ ! procedure TSomeObject.DropFiles( Sender: PControl; const FileList: AnsiString;
+ ! const Pt: TPoint ); )
+ ! var FList: PStrList;
+ ! I: Integer;
+ ! begin
+ ! FList := NewStrList;
+ ! FList.Text := FileList;
+ ! for I := 0 to FList.Count-1 do
+ ! begin
+ ! // do something with FList.Items[ I ]
+ ! end;
+ ! FList.Free;
+ ! end; }
+
+ TScrollerBar = ( sbHorizontal, sbVertical );
+ TScrollerBars = set of TScrollerBar;
+
+ TOnScroll = procedure( Sender: PControl; Bar: TScrollerBar; ScrollCmd: DWORD;
+ ThumbPos: DWORD ) of object;
+
+ TOnHelp = procedure( var Sender: PControl; var Context: Integer; var Popup: Boolean )
+ of object;
+
+ TOnSBBeforeScroll =
+ procedure(
+ Sender: PControl; OldPos, NewPos: Integer; Cmd: Word;
+ var AllowChange: Boolean) of object;
+ TOnSBScroll = procedure(Sender: PControl; Cmd: Word) of object;
+
+{$IFDEF WIN_GDI}
+ TOnGraphCtlMouse = procedure( var Msg: TMsg ) of object;
+{$ENDIF WIN_GDI}
+ TTriStateCheck = (tsUnchecked{=0}, tsChecked{=1}, tsIndeterminate{=2});
+
+{$IFDEF _X_}
+ //---- in GTK+, each type of widget requieres its own getcaption/setcaption call
+ TGetCaption = FUNCTION( Ctl: PControl ): KOLString;
+ TSetCaption = PROCEDURE( Ctl: PControl; CONST Value: KOLString );
+
+ {$IFDEF GTK}
+ //---- in GTK+, to allow setting absolute position for children,
+ // we should use one of special clients like gtk_fixed, gtk_layout
+ TGetClientArea = FUNCTION( Ctl: PControl ): PGtkWidget;
+ TChildSetPos = PROCEDURE( Ctl, Chld: PControl; x, y: Integer );
+ {$ENDIF GTK}
+{$ENDIF _X_}
+
+ TFormInitFunc = function(Form: PControl): PControl;
+ TFormInitFunc1 = function(Form: PControl; intParam: Integer): PControl;
+ TFormInitFuncArray = array[0..65535] of TFormInitFunc;
+ TFormInitFuncArray1 = array[0..65535] of TFormInitFunc1;
+ PFormInitFuncArray = ^TFormInitFuncArray;
+ PFormInitFuncArray1 = ^TFormInitFuncArray1;
+
+ TSmallIntArray = array[0..65535] of SmallInt;
+ PSmallIntArray = ^TSmallIntArray;
+
+ PPControl = ^PControl;
+
+ {$IFDEF USE_MHTOOLTIP}
+ {$DEFINE pre_interface}
+ PMHHint = ^TMHHint;
+ TKOLMHHint = PMHHint;
+ {$UNDEF pre_interface}
+ {$ENDIF}
+
+ TOnWndFunc = function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+ TProcSender = procedure( Sender: PObj );
+ TOnGotoControl = function( Self_: PControl; Key: DWORD; CheckOnly: Boolean ): Boolean;
+
+ PEvents = ^TEvents;
+ TEvents = record
+ CASE Integer OF
+ 1:(
+ //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ //................... most common events ...................................
+ fOnMessage: TOnMessage;
+ fOldOnMessage: TOnMessage; // for applet only but...
+ fOnClick: TOnEvent;
+ fOnMouseDown: TOnMouse; // CAUTION!!! Order of mouse event handlers is important. ____
+ fOnMouseUp: TOnMouse; //
+ fOnMouseMove: TOnMouse; //
+ fOnMouseDblClk: TOnMouse; //
+ fOnMouseWheel: TOnMouse; //_____________________________________________________//
+
+ fOnMouseEnter: TOnEvent;
+ fOnMouseLeave: TOnEvent;
+ fOnTestMouseOver: TOnTestMouseOver; // mainly for bitbtn but...
+ fGraphCtlMouseEvent: TOnGraphCtlMouse;
+ fMouseLeaveProc: TOnEvent;
+ fOnScroll: TOnScroll;
+
+ fOnChar: TOnChar;
+ fOnDeadChar: TOnChar;
+ fOnKeyUp: TOnKey;
+ fOnKeyDown: TOnKey;
+
+ fOnChangeCtl: TOnEvent;
+ fOnEnter: TOnEvent;
+ fOnLeave: TOnEvent;
+ fLeave: TOnEvent;
+
+ fOnPaint: TOnPaint;
+ fOnPaint2: TOnPaint;
+ fOnPrepaint: TOnPaint;
+ fOnPostPaint: TOnPaint;
+ fPaintProc: TPaintProc;
+ fOnEraseBkgnd: TOnPaint;
+ fOnDrawItem: TOnDrawItem;
+ fOnMeasureItem: TOnMeasureItem;
+
+ fDragCallback: TOnDrag;
+
+ fOnSelChange: TOnEvent;
+ fOnResize: TOnEvent;
+
+ fOnHide: TOnEvent;
+ fOnShow: TOnEvent;
+
+ fOnClose: TOnEventAccept; // mainly for form but...
+
+ fOnMove: TOnEvent;
+ fOnMoving: TOnEventMoving;
+ fOnHelp: TOnHelp;
+ //................... other events .........................................
+ fOnQueryEndSession: TOnEventAccept;
+
+ //----- order of following 3 events important: // for form only ?
+ fOnMinimize: TOnEvent; //
+ fOnMaximize: TOnEvent; //
+ fOnRestore: TOnEvent; //
+ //---------------------------------------------//
+
+ fOnLVCustomDraw: TOnLVCustomDraw;
+ fOnEndEditLVItem: TOnEditLVItem;
+ fOnLVData: TOnLVData;
+ fOnCompareLVItems: TOnCompareLVItems;
+ FOnLVStateChange: TOnLVStateChange;
+ fOnDeleteLVItem: TOnDeleteLVItem;
+ fOnColumnClick: TOnLVColumnClick;
+
+ FOnSBBeforeScroll: TOnSBBeforeScroll;
+ FOnSBScroll: TOnSBScroll;
+
+ FOnDropDown: TOnEvent;
+ FOnCloseUp: TOnEvent;
+
+ FOnSplit: TOnSplit;
+
+ FOnProgress: TOnEvent;
+
+ FOnBitBtnDraw: TOnBitBtnDraw;
+
+ FOnTVBeginDrag: TOnTVBeginDrag;
+ FOnTVBeginEdit: TOnTVBeginEdit;
+ FOnTVEndEdit: TOnTVEndEdit;
+ FOnTVExpanding: TOnTVExpanding;
+ FOnTVExpanded: TOnTVExpanded;
+ FOnTVSelChanging: TOnTVSelChanging;
+
+ FOnTVDelete: TOnTVDelete;
+
+ FOnDTPUserString: TDTParseInputEvent;
+
+ FOnREInsModeChg: TOnEvent;
+ FOnREOverURL: TOnEvent;
+ FOnREURLClick: TOnEvent;
+ fOnDropFiles: TOnDropFiles;
+ );
+ 2: ( MethodEvents: array[ 0..idx_LastEvent ] of TMethod;
+ );
+ end;
+
+ TProcedures = record
+ CASE Integer OF
+ 1: (
+ //..........................................................................
+ fWndFunc: Pointer;
+ fDoInvalidate: TProcSender;
+ fOnDynHandlers: TWindowFunc;
+ fPass2DefProc: TOnWndFunc;
+ fWndProcKeybd: TOnWndFunc;
+ fControlClick: TProcSender; //
+ fAutoSize: TProcSender;
+ //{-2.95}//fWndProcResizeFlicks: TOnWndFunc;
+ fGotoControl: TOnGotoControl;
+ {* Initially pointer to WndFunc. For MDI child window, points to DefMDIChildProc. }
+ fNotifyChild: procedure( Self_, Child: PControl );
+ fScrollChildren: procedure( Self_: PControl );
+ fCreateWndExt: procedure( Sender: PControl );
+ fExMsgProc: function( Applet: PControl; var Msg: TMsg ): Boolean;
+ {* Additional message handler called directly from Applet.ProcessMessage.
+ Used to call TranslateMDISysAccel API function for MDI application. }
+ );
+ 2: ( Procedures: array[ 0..idx_LastProc-idx_LastEvent-1 ] of Pointer;
+ );
+ end;
+
+ // data fields of TControl which are certain for different kinds of control
+ // -- so these can be alternated using variant record type to economy run time
+ // size of TControl object instance
+ TDataFields = packed record
+ fCurrentControl: PControl; //---- sometimes it is used for a parent control,
+ // not only for parent form, so should be common.
+ {$IFDEF UNION_FIELDS}
+ CASE Integer OF
+ 1:( // Toolbar control fields
+ {$ENDIF}
+ fOnTBCustomDraw: TOnTBCustomDraw;
+ fTBevents: PList; // events for TBAssignEvents
+ fTBBtnImgWidth: Integer; // custom toolbar bitmap width
+ fTBBtMinWidth: Integer;
+ fTBBtMaxWidth: Integer;
+ fTBttCmd: PList;
+ fTBttTxt: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF};
+ fTBCurItem: Integer;
+ fDefaultTBBtnStyle: Byte; // for Toolbars
+ fTBDropped: Boolean;
+ {$IFDEF UNION_FIELDS}
+ );
+ 2:( // Combobox + Group box
+ {$ENDIF}
+ fDroppedWidth: Integer; // SmallInt;
+ fDropDownCount: Cardinal;
+ fCurIdxAtDrop: Integer;
+ fErasingBkgnd: Boolean; // for Group box
+ {$IFDEF UNION_FIELDS}
+ );
+ 3:( // Form + Applet
+ {$ENDIF}
+ fModalResult: Integer;
+ fModalForm: PControl;
+ //fCurrentControl: PControl;
+ //FMinimizeWnd: PControl;
+ fIcon: HIcon;
+
+ {$IFDEF USE_GRAPHCTLS}
+ {$IFDEF GRAPHCTL_HOTTRACK}
+ fHotCtl: PControl;
+ {$ENDIF}
+ {$ENDIF}
+ //fDefaultBtnCtl: PControl;
+ //fCancelBtnCtl: PControl;
+ fWindowState: TWindowState;
+ fActivating: Boolean;
+ fCloseQueryReason: TCloseQueryReason;
+ fFixingModal: ShortInt;
+ fShowAction: Byte;
+ fKeyPreviewCount: Byte;
+ fModal: Byte;
+ fAllBtnReturnClick: Boolean;
+ //-- внимание! порядок следующих 3х полей не должен меняться!!!
+ FormCurrentParent: PControl;
+ {* контрол, использующийся в качестве родительского, в функциях создания }
+ FormParams: PAnsiChar;
+ {* строка команд и параметров }
+ FormAddress: PPControl;
+ {* адрес поля Form в объекте формы MCK - нужен для вычисления адресов
+ контролов по смещению, для функции FormSetCurCtl }
+ FormObj: PObj;
+ FormAlphabet: PFormInitFuncArray;
+ {* алфавит процедур }
+ FormLastCreatedChild: PControl;
+ {* контрол, созданный последним }
+ {$IFDEF UNION_FIELDS}
+ );
+ 4:( // ListView
+ {$ENDIF}
+ fColumn: Integer; // for listview only (column to sort)
+ fOnDeleteAllLVItems: TOnEvent;
+ fCtlImageListSml: PImageList;
+ {* ImageList object (with small icons 16x16) to use with a control (e.g.,
+ with ListView control).
+ If not set, but control has a list of image list objects, last added
+ image list with small icons is used automatically. }
+ fCtlImageListNormal: PImageList;
+ {* ImageList object (with big icons 32x32) to use with a control.
+ If not set, last added image list with big icons is used. }
+ fCtlImgListState: PImageList;
+ {* ImageList object to use as a state image list (for ListView control). }
+ fLVColCount: Integer;
+ fLVTextBkColor: TColor;
+ fLVItemHeight: Integer;
+ fLVOptions: TListViewOptions;
+ fLVStyle: TListViewStyle;
+ {$IFDEF UNION_FIELDS}
+ );
+ 5:( // Rich Edit -- 11 dwords
+ {$ENDIF}
+ {$IFNDEF NOT_USE_RICHEDIT}
+ {$IFDEF STATIC_RICHEDIT_DATA}
+ fRECharFormatRec: TCharFormat;
+ fREParaFmtRec: TParaFormat2;
+ {$ELSE}
+ fRECharFormatRec: PCharFormat;
+ fREParaFmtRec: PParaFormat2;
+ {$ENDIF}
+ fCharFmtDeltaSz: Integer;
+ fParaFmtDeltaSz: Integer;
+ fREError: Integer;
+ fREStream: PStream;
+ fREStrLoadLen: DWORD;
+ fREUrl: PKOLChar;
+ fTmpFont: PGraphicTool; // for RichEdit
+ fREUpdCount: SmallInt;
+ fReOvrDisable: Boolean;
+ fREOvr: Boolean;
+ fREScrolling: Boolean;
+ fRECharArea: TRichFmtArea;
+ FSupressTab: Boolean;
+ fRETransparent: Boolean;
+ {$ENDIF NOT_USE_RICHEDIT}
+ {$IFDEF UNION_FIELDS}
+ );
+ 6:( // Label Effect + Graphic edit control
+ {$ENDIF}
+ fShadowDeep: Integer;
+ fEditCtl: PControl;
+ fEditOptions: TEditOptions;
+ {$IFDEF UNION_FIELDS}
+ );
+ 7:( // BitBtn
+ {$ENDIF}
+ fGlyphBitmap : HBitmap;
+ fGlyphCount : Integer;
+ fGlyphWidth, fGlyphHeight: Integer;
+ fRepeatInterval: Integer;
+ fTextShiftX, fTextShiftY: Integer;
+ fBitBtnDrawMnemonic: Boolean;
+ fBitBtnOptions : TBitBtnOptions;
+ fGlyphLayout : TGlyphLayout;
+ fButtonIcon: HIcon; // for Graphic button control though...
+ FBitBtnGetCaption: function( Self_: PControl; const S: KOLString ): KOLString;
+ FBitBtnExtDraw: procedure( Self_: PControl; DC: HDC; X, Y: Integer; const R: TRect;
+ const CapText, CapTxtOrig: KOLString; Color: TColor );
+ {$IFDEF UNION_FIELDS}
+ );
+ 8:( // Splitter
+ {$ENDIF}
+ fSplitStartPos: TPoint;
+ fSplitStartPos2: TPoint;
+ fSplitStartSize: Integer;
+ fSplitMinSize1, fSplitMinSize2: Integer;
+ fSecondControl: PControl;
+ fSplitLastPos: TPoint;
+ {$IFDEF UNION_FIELDS}
+ );
+ 9:( // Gradient panel
+ {$ENDIF}
+ fColor1: TColor;
+ fColor2: TColor;
+ fGradientStyle: TGradientStyle;
+ fGradientLayout: TGradientLayout;
+ {$IFDEF UNION_FIELDS}
+ );
+ 10:( // Tree view only
+ {$ENDIF}
+ fTVRightClickSelect: Boolean;
+ {$IFDEF UNION_FIELDS}
+ );
+ 11:( // Scroll Bar
+ {$ENDIF}
+ FScrollLineDist: array[ 0..1 ] of Integer;
+ fSBMinMax: TPoint;
+ fSBPageSize: Integer;
+ fSBPosition: Integer;
+ {$IFDEF UNION_FIELDS}
+ );
+ 100:( // for custom controls
+ {$ENDIF}
+ //fCustom6: Integer;
+ //fCustEvent2: TOnEvent;
+ fCustom5: Integer;
+ fCustom4: Integer;
+ fCustEvent1: TOnEvent;
+ fCustom3: Integer;
+ fCustom2: Integer;
+ fCustEvent0: TOnEvent;
+ fCustom1: Integer;
+ fCustom0: Integer;
+ fCustFlag7: Boolean;
+ fCustFlag6: Boolean;
+ fCustFlag5: Boolean;
+ fCustFlag4: Boolean;
+ fCustFlag3: Byte;
+ fCustFlag2: Byte;
+ fCustFlag1: Byte;
+ fCustFlag0: Byte;
+ {$IFDEF UNION_FIELDS}
+ );
+ {$ENDIF}
+ end;
+
+{ ----------------------------------------------------------------------
+ TControl - object to implement any visual control
+----------------------------------------------------------------------- }
+//[TControl DEFINITION]
+ TControl = object( TObj )
+ {*! TControl is the basic visual object of KOL. And now, all visual
+ objects have the same type PControl, differing only in "constructor",
+ which during creating of object adjusts it so it can play role of
+ desired control. Idea of incapsulating of all visual objects having
+ the most common set of properties, is belonging to Vladimir Kladov,
+ (C) 2000.
+ |<br> <b> Since all visual objects are represented
+ in KOL by this single object type, not all methods, properties and
+ events defined in TControl, are applicable to different visual objects.
+ See also notes about certain control kinds, located together with its
+ |<a href="kol_pas.htm#visual_objects_constructors">
+ |constructing functions definitions</a></b>. }
+ public
+ procedure SetAnchor(const Index: Integer; const Value: Boolean);
+ protected
+ function GetAnchor(const Index: Integer): Boolean;
+ function Get_StatusWnd: HWND;
+ function Get_Prop_Int(PropName: PKOLChar): Integer;
+ procedure Set_Prop_Int(PropName: PKOLChar; const Value: Integer);
+ function GetHelpContext: Integer;
+ function Get_Ctl3D: Boolean;
+ function Get_OnMouseEvent(const Index: Integer): TOnMouse;
+ public
+ procedure SetOnMouseEvent(const Index: Integer; const Value: TOnMouse);
+ protected
+ {$IFDEF EVENTS_DYNAMIC}
+ function Get_TOnEvent(const Index: Integer): TOnEvent;
+ function Get_OnMessage: TOnMessage;
+ function Get_OnHelp: TOnHelp;
+ function Get_OnBitBtnDraw: TOnBitBtnDraw;
+ function Get_OnMeasureItem: TOnMeasureItem;
+ function Get_OnShow: TOnEvent;
+ function Get_OnHide: TOnEvent;
+ function Get_OnClose: TOnEventAccept;
+ function Get_OnQueryEndSession: TOnEventAccept;
+ function Get_OnPaint: TOnPaint;
+ function Get_OnPrePaint: TOnPaint;
+ function Get_OnPostPaint: TOnPaint;
+ function Get_OnEraseBkgnd: TOnPaint;
+ function Get_OnClick: TOnEvent;
+ function Get_OnResize: TOnEvent;
+ function Get_OnMove: TOnEvent;
+ function Get_OnMoving: TOnEventMoving;
+ function Get_OnSplit: TOnSplit;
+ function Get_OnKeyDown: TOnKey;
+ function Get_OnKeyUp: TOnKey;
+ function Get_OnChar: TOnChar;
+ function Get_OnDeadChar: TOnChar;
+ function Get_OnMouseUp: TOnMouse;
+ function Get_OnMouseDown: TOnMouse;
+ function Get_OnMouseMove: TOnMouse;
+ function Get_OnMouseDblClk: TOnMouse;
+ function Get_OnMouseWheel: TOnMouse;
+ function Get_OnMouseEnter: TOnEvent;
+ function Get_OnMouseLeave: TOnEvent;
+ function Get_OnTestMouseOver: TOnTestMouseOver;
+ function Get_OnEndEditLVItem: TOnEditLVItem;
+ function Get_OnDeleteLVItem: TOnDeleteLVItem;
+ function Get_OnLVData: TOnLVData;
+ function Get_OnCompareLVItems: TOnCompareLVItems;
+ function Get_OnColumnClick: TOnLVColumnClick;
+ function Get_OnLVStateChange: TOnLVStateChange;
+ function Get_OnDrawItem: TOnDrawItem;
+ function Get_OnLVCustomDraw: TOnLVCustomDraw;
+ function Get_OnTVBeginDrag: TOnTVBeginDrag;
+ function Get_OnTVBeginEdit: TOnTVBeginEdit;
+ function Get_OnTVEndEdit: TOnTVEndEdit;
+ function Get_OnTVExpanding: TOnTVExpanding;
+ function Get_OnTVExpanded: TOnTVExpanded;
+ function Get_OnTVDelete: TOnTVDelete;
+ function Get_OnTVSelChanging: TOnTVSelChanging;
+ function Get_OnDTPUserString: TDTParseInputEvent;
+ function Get_OnSBBeforeScroll: TOnSBBeforeScroll;
+ function Get_OnSBScroll: TOnSBScroll;
+ function Get_OnScroll: TOnScroll;
+ function Get_OnDropFiles: TOnDropFiles;
+ public
+ procedure Set_TOnEvent(const Index: Integer; const Value: TOnEvent);
+ procedure Set_OnMessage(const Value: TOnMessage);
+ procedure Set_OnHelp(const Value: TOnHelp);
+ procedure Set_OnBitBtnDraw(const Value: TOnBitBtnDraw);
+ procedure Set_OnPrePaint(const Value: TOnPaint);
+ procedure Set_OnPostPaint(const Value: TOnPaint);
+ procedure Set_OnEraseBkgnd(const Value: TOnPaint);
+ procedure Set_OnSplit(const Value: TOnSplit);
+ procedure Set_OnCompareLVItems(const Value: TOnCompareLVItems);
+ procedure Set_OnTVBeginDrag(const Value: TOnTVBeginDrag);
+ procedure Set_OnTVBeginEdit(const Value: TOnTVBeginEdit);
+ procedure Set_OnTVEndEdit(const Value: TOnTVEndEdit);
+ procedure Set_OnTVExpanding(const Value: TOnTVExpanding);
+ procedure Set_OnTVExpanded(const Value: TOnTVExpanded);
+ procedure Set_OnTVSelChanging(const Value: TOnTVSelChanging);
+ procedure Set_OnDTPUserString(const Value: TDTParseInputEvent);
+ procedure Set_OnSBBeforeScroll(const Value: TOnSBBeforeScroll);
+ procedure Set_OnSBScroll(const Value: TOnSBScroll);
+ {$ENDIF EVENTS_DYNAMIC}
+ protected
+ procedure SetTBAutoSizeButtons(const Value: Boolean);
+ function GetTBAutoSizeButtons: Boolean;
+ function GetTVEditing: Boolean;
+ function GetDroppedDown: Boolean;
+ {$IFDEF USE_FLAGS}
+ function Get_Dragging: Boolean;
+ function GetTabStop: Boolean;
+ procedure SetTabStop(const Value: Boolean);
+ function GetWordWrap: Boolean;
+ procedure SetWordWrap(const Value: Boolean);
+ function GetCannotDoubleBuf: Boolean;
+ procedure SetCannotDoubleBuf(const Value: Boolean);
+ function GetDoubleBuffered: Boolean;
+ function GetTransparent: Boolean;
+ function GetIsForm: Boolean;
+ function GetSizeGrip: Boolean;
+ procedure SetSizeGrip(const Value: Boolean);
+ function GetIsApplet: Boolean;
+ function GetIsControl: Boolean;
+ function GetIsMDIChild: Boolean;
+ function GetCreateVisible: Boolean;
+ procedure SetCreateVisible(const Value: Boolean);
+ function GetIsButton: Boolean;
+ function GetFlat: Boolean;
+ function GetMouseInCtl: Boolean;
+ function GetEraseBackground: Boolean;
+ procedure SetEraseBackground(const Value: Boolean);
+ function Get3ButtonPress: Boolean;
+ function GetKeyPreview: Boolean;
+ procedure SetKeyPreview(const Value: Boolean);
+ function GetIgnoreDefault: Boolean;
+ procedure SetIgnoreDefault(const Value: Boolean);
+ function GetWindowed: Boolean;
+ procedure SetWindowed(const Value: Boolean);
+ function Get_RightClick: Boolean;
+ function Get_SizeRedraw: Boolean;
+ procedure Set_SizeRedraw(const Value: Boolean);
+ {$ENDIF USE_FLAGS}
+ public //+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ FormString: KOLString;
+ {* строка текущего параметра. Очищается после каждого вызова
+ FormExecuteCommands, так что специальная очистка не требуется. }
+ function FormGetIntParam: Integer;
+ {* извлекает очередной целочисленный параметр до ',' или до ';' }
+ function FormGetColorParam: Integer;
+ {* извлекает очередной целочисленный параметр до ',' или до ';' }
+ procedure FormGetStrParam;
+ {* извлекает очередной строковый параметр до ',' или до ';' -> FormString }
+ procedure FormCreateParameters( alphabet: PFormInitFuncArray; params: PAnsiChar );
+ {* задает первоначальный алфавит и параметры с командами }
+ procedure FormExecuteCommands(AForm: PControl; ControlPtrOffsets: PSmallIntArray);
+ {* выполняет команды (с параметрами) до конца или до ';' }
+ {$IFDEF GDI}
+ protected
+ function GetDate: TDateTime;
+ function GetTime: TDateTime;
+ procedure SetDate(const Value: TDateTime);
+ procedure SetTime(const Value: TDateTime);
+ {$ENDIF GDI}
+ protected
+ {$IFDEF GDI}
+ function GetHelpPath: KOLString;
+ procedure SetHelpPath(const Value: KOLString);
+ public
+ procedure SetOnQueryEndSession(const Value: TOnEventAccept);
+ procedure SetOnMinMaxRestore(const Index: Integer; const Value: TOnEvent);
+ procedure SetOnMinimize( const Value: TOnEvent );
+ procedure SetOnMaximize( const Value: TOnEvent );
+ procedure SetOnRestore( const Value: TOnEvent );
+ procedure SetOnScroll(const Value: TOnScroll);
+ protected
+ procedure SetConstraint(const Index: Integer; Value: SmallInt);
+ function GetOnMinMaxRestore(const Index: Integer): TOnEvent;
+ function GetConstraint(const Index: Integer): Integer;
+ function GetLVColalign(Idx: Integer): TTextAlign;
+ procedure SetLVColalign(Idx: Integer; const Value: TTextAlign);
+
+ {$ENDIF GDI}
+ procedure SetParent( Value: PControl );
+ function GetLeft: Integer;
+ procedure SetLeft( Value: Integer );
+ function GetTop: Integer;
+ procedure SetTop( Value: Integer );
+ function GetWidth: Integer;
+ procedure SetWidth( Value: Integer );
+ function GetHeight: Integer;
+ procedure SetHeight( Value: Integer );
+ function GetPosition: TPoint;
+ procedure Set_Position( Value: TPoint );
+ function GetMembers(Idx: Integer): PControl;
+ function GetFont: PGraphicTool;
+ procedure FontChanged( Sender: PGraphicTool );
+ {$IFDEF GDI}
+ function GetBrush: PGraphicTool;
+ procedure BrushChanged( Sender: PGraphicTool );
+ function GetClientHeight: Integer;
+ function GetClientWidth: Integer;
+ procedure SetClientHeight(const Value: Integer);
+ procedure SetClientWidth(const Value: Integer);
+ function GetHasBorder: Boolean;
+ public procedure SetHasBorder(const Value: Boolean);
+ protected
+
+ function GetHasCaption: Boolean;
+ procedure SetHasCaption(const Value: Boolean);
+
+ function GetCanResize: Boolean;
+ procedure SetCanResize( const Value: Boolean );
+
+ function GetStayOnTop: Boolean;
+ public procedure SetStayOnTop(const Value: Boolean);
+ protected
+ function GetChecked: Boolean;
+ procedure Set_Checked(const Value: Boolean);
+
+ function GetCheck3: TTriStateCheck;
+ procedure SetCheck3(value: TTriStateCheck);
+
+ function GetSelStart: Integer;
+ procedure SetSelStart(const Value: Integer);
+ function GetSelLength: Integer;
+ procedure SetSelLength(const Value: Integer);
+
+ function GetItems(Idx: Integer): KOLString;
+ procedure SetItems(Idx: Integer; const Value: KOLString);
+
+ function GetItemsCount: Integer;
+ function GetItemSelected(ItemIdx: Integer): Boolean;
+ procedure SetItemSelected(ItemIdx: Integer; const Value: Boolean);
+
+ public procedure SetCtl3D(const Value: Boolean);
+ protected
+ function GetCurIndex: Integer;
+ procedure SetCurIndex(const Value: Integer);
+
+ {$ENDIF GDI}
+ function GetTextAlign: TTextAlign;
+ public procedure SetTextAlign(const Value: TTextAlign);
+ protected
+ function GetVerticalAlign: TVerticalAlign;
+ public procedure SetVerticalAlign(const Value: TVerticalAlign);
+ protected
+ function GetCanvas: PCanvas;
+ {$IFDEF _X_}
+ {$IFDEF GTK}
+ protected
+ {} fInBkPaint: Boolean;
+ {} fSetTextAlign: PROCEDURE( Self_: PControl );
+ FUNCTION ProvideCanvasHandle( Sender: PCanvas ): HDC;
+ {$ENDIF GTK}
+ {$ENDIF _X_}
+ {$IFDEF GDI}
+ function Dc2Canvas( Sender: PCanvas ): HDC;
+ procedure SetShadowDeep(const Value: Integer);
+ public procedure SetDoubleBuffered(const Value: Boolean);
+ protected
+
+ procedure SetStatusText(Index: Integer; const Value: KOLString);
+ function GetStatusText( Index: Integer ): KOLString;
+ function GetStatusPanelX(Idx: Integer): Integer;
+ procedure SetStatusPanelX(Idx: Integer; const Value: Integer);
+
+ public procedure SetTransparent(const Value: Boolean);
+ protected
+ function GetImgListIdx(const Index: Integer): PImageList;
+
+ procedure SetImgListIdx(const Index: Integer; const Value: PImageList);
+ function GetLVColText(Idx: Integer): KOLString;
+ procedure SetLVColText(Idx: Integer; const Value: KOLString);
+ {$IFDEF ENABLE_DEPRECATED}
+ {$DEFINE interface_2}
+ {$I KOL_deprecated.inc}
+ {$UNDEF interface_2}
+ {$ENDIF DISABLE_DEPRECATED}
+ protected
+ function LVGetItemText(Idx, Col: Integer): KOLString;
+ procedure LVSetItemText(Idx, Col: Integer; const Value: KOLString);
+ procedure SetLVOptions(const Value: TListViewOptions);
+ procedure SetLVStyle(const Value: TListViewStyle);
+ function GetLVColEx(Idx: Integer; const Index: Integer): Integer;
+ procedure SetLVColEx(Idx: Integer; const Index: Integer;
+ const Value: Integer);
+ {$ENDIF GDI}
+ function GetChildCount: Integer;
+ {$IFDEF GDI}
+ function LVGetItemPos(Idx: Integer): TPoint;
+ procedure LVSetItemPos(Idx: Integer; const Value: TPoint);
+ procedure LVSetColorByIdx(const Index: Integer; const Value: TColor);
+ {$IFDEF F_P}
+ function LVGetColorByIdx(const Index: Integer): TColor;
+ {$ENDIF F_P}
+ function GetIntVal(const Index: Integer): Integer;
+ procedure SetIntVal(const Index, Value: Integer);
+ function GetItemVal(Item: Integer; const Index: Integer): Integer;
+ procedure SetItemVal(Item: Integer; const Index, Value: Integer);
+ function TBGetButtonVisible(BtnID: Integer): Boolean;
+ procedure TBSetButtonVisible(BtnID: Integer; const Value: Boolean);
+
+ function TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean;
+ procedure TBSetBtnStt(BtnID: Integer; const Index: Integer; const Value: Boolean);
+ function TBGetButtonText(BtnID: Integer): KOLString;
+ function TBGetButtonRect(BtnID: Integer): TRect;
+
+ function TBGetRows: Integer;
+ procedure TBSetRows(const Value: Integer);
+ procedure SetProgressColor(const Value: TColor);
+ function TBGetBtnImgIdx(BtnID: Integer): Integer;
+ procedure TBSetBtnImgIdx(BtnID: Integer; const Value: Integer);
+
+ procedure TBSetButtonText(BtnID: Integer; const Value: KOLString);
+
+ function TBGetBtnWidth(BtnID: Integer): Integer;
+ procedure TBSetBtnWidth(BtnID: Integer; const Value: Integer);
+ procedure TBSetBtMinMaxWidth(const Idx: Integer; const Value: Integer);
+ {$IFDEF F_P}
+ function TBGetBtMinMaxWidth(const Idx: Integer): Integer;
+ {$ENDIF F_P}
+ procedure TBFreeTBevents;
+ function TBGetButtonLParam(const Idx: Integer): DWORD;
+ procedure TBSetButtonLParam(const Idx: Integer; const Value: DWORD);
+ public
+ procedure Set_Align(const Value: TControlAlign);
+ protected
+ function GetSelection: KOLString;
+ procedure SetSelection(const Value: KOLString);
+ procedure SetTabOrder(const Value: SmallInt);
+ function GetFocused: Boolean;
+ procedure SetFocused(const Value: Boolean);
+ {$IFNDEF NOT_USE_RICHEDIT}
+ function REGetFont: PGraphicTool;
+ procedure RESetFont(Value: PGraphicTool);
+ procedure RESetFontEx(const Index: Integer);
+ function REGetFontEffects(const Index: Integer): Boolean;
+ function REGetFontMask(const Index: Integer): Boolean;
+ procedure RESetFontEffect(const Index: Integer; const Value: Boolean);
+ function REGetFontAttr(const Index: Integer): Integer;
+ procedure RESetFontAttr(const Index, Value: Integer);
+ procedure RESetFontAttr1(const Index, Value: Integer);
+ function REGetFontSizeValid: Boolean;
+ function REGetCharformat: TCharFormat;
+ procedure RESetCharFormat(const Value: TCharFormat);
+ function REReadText(Format: TRETextFormat; SelectionOnly: Boolean): KOLString;
+ procedure REWriteText(Format: TRETextFormat; SelectionOnly: Boolean;
+ const Value: KOLString);
+ function REGetFontName: KOLString;
+ procedure RESetFontName(const Value: KOLString);
+ function REGetParaFmt: TParaFormat;
+ procedure RESetParaFmt(const Value: TParaFormat);
+ function REGetNumbering: Boolean;
+ function REGetParaAttr( const Index: Integer ): Integer;
+ function REGetParaAttrValid( const Index: Integer ): Boolean;
+ function REGetTabCount: Integer;
+ function REGetTabs(Idx: Integer): Integer;
+ function REGetTextAlign: TRichTextAlign;
+ procedure RESetNumbering(const Value: Boolean);
+ procedure RESetParaAttr(const Index, Value: Integer);
+ procedure RESetTabCount(const Value: Integer);
+ procedure RESetTabs(Idx: Integer; const Value: Integer);
+ procedure RESetTextAlign(const Value: TRichTextAlign);
+ function REGetStartIndentValid: Boolean;
+ function REGetAutoURLDetect: Boolean;
+ public procedure RESetAutoURLDetect(const Value: Boolean);
+ protected
+ procedure RESetZoom( const Value: TSmallPoint );
+ function REGetZoom: TSmallPoint;
+
+ function GetMaxTextSize: DWORD;
+ procedure SetMaxTextSize(const Value: DWORD);
+ function REGetUnderlineEx: TRichUnderline;
+ procedure RESetUnderlineEx(const Value: TRichUnderline);
+
+ function GetTextSize: Integer;
+ function REGetTextSize(Units: TRichTextSize): Integer;
+
+ function REGetNumStyle: TRichNumbering;
+ procedure RESetNumStyle(const Value: TRichNumbering);
+ function REGetNumBrackets: TRichNumBrackets;
+ procedure RESetNumBrackets(const Value: TRichNumBrackets);
+ function REGetNumTab: Integer;
+ procedure RESetNumTab(const Value: Integer);
+ function REGetNumStart: Integer;
+ procedure RESetNumStart(const Value: Integer);
+ function REGetSpacing(const Index: Integer): Integer;
+ procedure RESetSpacing(const Index, Value: Integer);
+ function REGetSpacingRule: Integer;
+ procedure RESetSpacingRule(const Value: Integer);
+ function REGetLevel: Integer;
+ function REGetBorder(Side: TBorderEdge; const Index: Integer): Integer;
+ procedure RESetBorder(Side: TBorderEdge; const Index: Integer;
+ const Value: Integer);
+ function REGetParaEffect(const Index: Integer): Boolean;
+ procedure RESetParaEffect(const Index: Integer; const Value: Boolean);
+ function REGetOverwite: Boolean;
+ procedure RESetOverwrite(const Value: Boolean);
+ procedure RESetOvrDisable(const Value: Boolean);
+ function REGetTransparent: Boolean;
+ public procedure RESetTransparent(const Value: Boolean);
+ protected
+ procedure RESetOnURL(const Index: Integer; const Value: TOnEvent);
+ procedure SetOnRE_URLClick( const Value: TOnEvent );
+ procedure SetOnRE_OverURL( const Value: TOnEvent );
+ function REGetOnURL(const Index: Integer): TOnEvent;
+ function REGetLangOptions(const Index: Integer): Boolean;
+ procedure RESetLangOptions(const Index: Integer; const Value: Boolean);
+ {$ENDIF NOT_USE_RICHEDIT}
+ public
+ procedure SetOnResize(const Value: TOnEvent);
+ protected
+ procedure DoSelChange;
+ function LVGetItemImgIdx(Idx: Integer): Integer;
+ procedure LVSetItemImgIdx(Idx: Integer; const Value: Integer);
+ public procedure SetFlat(const Value: Boolean);
+ procedure SetOnMouseEnter(const Value: TOnEvent);
+ procedure SetOnMouseLeave(const Value: TOnEvent);
+ protected
+ procedure EdSetTransparent(const Value: Boolean);
+ procedure SetOnTestMouseOver(const Value: TOnTestMouseOver);
+ function GetPages(Idx: Integer): PControl;
+ function TCGetItemText(Idx: Integer): KOLString;
+ procedure TCSetItemText(Idx: Integer; const Value: KOLString);
+ function TCGetItemImgIDx(Idx: Integer): Integer;
+ procedure TCSetItemImgIdx(Idx: Integer; const Value: Integer);
+ function TCGetItemRect(Idx: Integer): TRect;
+ function TVGetItemIdx(const Index: Integer): THandle;
+ procedure TVSetItemIdx(const Index: Integer; const Value: THandle);
+ function TVGetItemNext(Item: THandle; const Index: Integer): THandle;
+ function TVGetItemRect(Item: THandle; TextOnly: Boolean): TRect;
+ function TVGetItemVisible(Item: THandle): Boolean;
+ procedure TVSetITemVisible(Item: THandle; const Value: Boolean);
+ function TVGetItemStateFlg(Item: THandle; const Index: Integer): Boolean;
+ procedure TVSetItemStateFlg(Item: THandle; const Index: Integer;
+ const Value: Boolean);
+ function TVGetItemImage(Item: THandle; const Index: Integer): Integer;
+ procedure TVSetItemImage(Item: THandle; const Index: Integer;
+ const Value: Integer);
+ function TVGetItemText(Item: THandle): KOLString;
+ procedure TVSetItemText(Item: THandle; const Value: KOLString);
+ function TV_GetItemHasChildren(Item: THandle): Boolean;
+ procedure TV_SetItemHasChildren(Item: THandle; const Value: Boolean);
+ function TV_GetItemChildCount(Item: THandle): Integer;
+ function TVGetItemData(Item: THandle): Pointer;
+ procedure TVSetItemData(Item: THandle; const Value: Pointer);
+ function GetToBeVisible: Boolean;
+ procedure SetAlphaBlend(const Value: Byte);
+ procedure SetMaxProgress(const Index, Value: Integer);
+ procedure SetDroppedWidth(const Value: Integer);
+ function LVGetItemState(Idx: Integer): TListViewItemState;
+ procedure LVSetItemState(Idx: Integer; const Value: TListViewItemState);
+ function LVGetSttImgIdx(Idx: Integer): Integer;
+ procedure LVSetSttImgIdx(Idx: Integer; const Value: Integer);
+ function LVGetOvlImgIdx(Idx: Integer): Integer;
+ procedure LVSetOvlImgIdx(Idx: Integer; const Value: Integer);
+ function LVGetItemData(Idx: Integer): DWORD;
+ procedure LVSetItemData(Idx: Integer; const Value: DWORD);
+ function LVGetItemIndent(Idx: Integer): Integer;
+ procedure LVSetItemIndent(Idx: Integer; const Value: Integer);
+ public
+ procedure SetOnDeleteAllLVItems(const Value: TOnEvent);
+ procedure SetOnDeleteLVItem(const Value: TOnDeleteLVItem);
+ procedure SetOnEndEditLVItem(const Value: TOnEditLVItem);
+ procedure SetOnLVData(const Value: TOnLVData);
+ procedure SetOnColumnClick(const Value: TOnLVColumnClick);
+ procedure SetOnDrawItem(const Value: TOnDrawItem);
+ procedure SetOnMeasureItem(const Value: TOnMeasureItem);
+
+ procedure SetItemsCount(const Value: Integer);
+ protected
+ function GetItemData(Idx: Integer): DWORD;
+ procedure SetItemData(Idx: Integer; const Value: DWORD);
+ function GetLVCurItem: Integer;
+ procedure SetLVCurItem(const Value: Integer);
+ function GetLVFocusItem: Integer;
+ public
+ procedure SetOnDropFiles(const Value: TOnDropFiles);
+ procedure SetOnHide(const Value: TOnEvent);
+ procedure SetOnShow(const Value: TOnEvent);
+ procedure SetClientMargin(const Index: Integer; Value: ShortInt);
+ protected
+ {$IFDEF F_P}
+ function GetClientMargin(const Index: Integer): Integer;
+ {$ENDIF F_P}
+ {$ENDIF GDI}
+ protected
+ {$IFDEF _X_}
+ {$IFDEF GTK}
+ {} fExposeEvent: Integer;
+ {$ENDIF GTK}
+ {$ENDIF _X_}
+ public
+ procedure SetOnPaint(const Value: TOnPaint);
+ {$IFDEF GDI}
+ procedure SetOnEraseBkgnd(const Value: TOnPaint);
+ procedure SetTVRightClickSelect(const Value: Boolean);
+ procedure SetOnLVStateChange(const Value: TOnLVStateChange);
+ procedure SetOnMove(const Value: TOnEvent);
+ procedure SetOnMoving(const Value: TOnEventMoving);
+ procedure SetColor1(const Value: TColor);
+ procedure SetColor2(const Value: TColor);
+ procedure SetGradientLayout(const Value: TGradientLayout);
+ procedure SetGradientStyle(const Value: TGradientStyle);
+ protected
+ procedure SetDroppedDown(const Value: Boolean);
+ function get_ClassName: KOLString;
+ procedure set_ClassName(const Value: KOLString);
+ procedure SetClsStyle( Value: DWord );
+
+{$IFDEF GRAPHCTL_XPSTYLES}
+ function GetEdgeStyle: TEdgeStyle;
+ procedure SetEdgeStyle( Value: TEdgeStyle );
+{$ENDIF}
+
+ procedure SetStyle( Value: DWord );
+ procedure SetExStyle( Value: DWord );
+
+ procedure SetCursor( Value: HCursor );
+
+ procedure SetIcon( Value: HIcon );
+ procedure SetMenu( Value: HMenu );
+ {$ENDIF GDI}
+ protected
+ {$IFDEF _X_}
+ {} fGetCaption: TGetCaption;
+ {} fSetCaption: TSetCaption;
+ {$ENDIF _X_}
+ function GetCaption: KOLString;
+ procedure SetCaption( const Value: KOLString );
+ {$IFDEF GDI}
+
+ public procedure SetWindowState( Value: TWindowState );
+ protected
+ function GetWindowState: TWindowState;
+ procedure DoClick;
+ function TBAddInsButtons( Idx: Integer; const Buttons: array of PKOLChar;
+ const BtnImgIdxArray: array of Integer ): Integer; stdcall;
+ public procedure SetBitBtnDrawMnemonic(const Value: Boolean);
+ protected
+ function GetBitBtnImgIdx: Integer;
+ procedure SetBitBtnImgIdx(const Value: Integer);
+ function GetBitBtnImageList: THandle;
+ procedure SetBitBtnImageList(const Value: THandle);
+
+ function GetModal: Boolean;
+ {$IFDEF USE_SETMODALRESULT}
+ procedure SetModalResult( const Value: Integer );
+ {$ENDIF}
+
+ {$ENDIF GDI}
+ protected
+ {$IFDEF GDI}
+ fHandle: HWnd;
+ {$ELSE}
+ {$IFDEF GTK} {} fHandle: PGtkWidget;
+ {} fCaptionHandle: PGtkWidget;
+ {} fEventboxHandle: PGtkWidget;
+ {} fGetClientArea: TGetClientArea;
+ {} fClient: PGtkWidget;
+ {} fChildPut: TChildSetPos;
+ {} fChildSetPos: TChildSetPos;
+ {$ENDIF}
+ {$IFDEF Q_T} fHandle: sometypehere ; {$ENDIF}
+ {$ENDIF}
+ {$IFDEF GDI}
+ fClsStyle: DWord;
+ fStyle: TStyle;
+ fExStyle: DWord;
+ {$ENDIF GDI}
+ {$IFDEF GDI}
+ fDefWndProc: Pointer;
+ {$ENDIF GDI}
+ FParent: PControl;
+
+ {$IFDEF USE_FLAGS} //................... less memory usage with USE_FLAGS ..
+ fFlagsG1: T1Flags;
+ fFlagsG2: T2Flags;
+ fFlagsG3: T3Flags;
+ fFlagsG4: T4Flags;
+ fFlagsG5: T5Flags;
+ fFlagsG6: T6Flags;
+ {$ELSE} //..................................................................
+ {} fEnabled: Boolean; // Caution!!! fVisible must follow fEnabled! ___
+ {} fVisible: Boolean; //____________________________________________//
+ {} fTabstop: Boolean;
+ {} fWordWrap: Boolean;
+ {} fPreventResize: Boolean;
+ // fCursorShared: Boolean;
+ {} fIconShared: Boolean;
+ {} fIgnoreWndCaption: Boolean;
+ {} fSizeRedraw: Boolean; {YS}
+ {} fIsStaticControl: Byte;
+ {} fCannotDoubleBuf: Boolean;
+ {} fDoubleBuffered: Boolean;
+ {* True, if cannot set DoubleBuffered to True (RichEdit). }
+ {* True, if it is static control with a caption. (Mainly, to prevent
+ flicks in DoubleBuffered mode. }
+ {} fTransparent: Boolean;
+ {} fClassicTransparent : Boolean;
+ // FCreating: Boolean;
+ {* True, when creating of object is in progress. }
+ {} fDestroying: Boolean;
+ {* True, when destroying of the window is started. }
+ {} fBeginDestroying: Boolean;
+ {* true, when destroying of the window is initiated by the system, i.e.
+ message WM_DESTROY fired }
+ {} fChangedPosSz: Byte;
+ {* Flags of changing left (1), top (2), width (4) or height (8) }
+ {} fIsForm: Boolean;
+ {* True, if the object is form. }
+ {} fSizeGrip: Boolean;
+ {} fIsApplet: Boolean;
+ {* True, if the object represent application taskbar button. }
+ {} fIsControl: Boolean;
+ {* True, if it is a control on form. }
+ {} fIsMDIChild: Boolean;
+ {* TRUE, if the object is MDI child form. }
+ {} fCreateHidden: Boolean;
+ {} fVisibleWoParent: Boolean;
+ {} fNotUseAlign: Boolean;
+ {} fNotUpdate: Boolean; // was used for PreventResizeFlicks -- now abandoned
+ {} fCreateVisible: Boolean;
+ {} fIsButton: Boolean;
+ {} fIsBitBtn: Boolean;
+ {} fIsGroupBox: Boolean;
+ {} fIsSplitter: Boolean;
+ {} fIsCommonControl: Boolean;
+ {* True, if it is common control. }
+ {} fFlat: Boolean;
+ {} fMouseInControl: Boolean;
+ {} fChecked: Boolean;
+ {} fPushed: Boolean;
+ {} fHot: Boolean;
+ {} fFocused: Boolean;
+ {} fPressed : Boolean;
+ // fDropped: Boolean;
+ {} f3ButtonPress: Boolean;
+ // fEditing: Boolean;
+ {} fEraseUpdRgn: Boolean;
+ {} fKeyPreview: Boolean;
+ {} fKeyPreviewing: Boolean;
+ {} fIgnoreDefault: Boolean;
+ {} fDefaultBtn: Boolean;
+ {} fCancelBtn: Boolean;
+ {} fWindowed: Boolean; //
+ {* True, if control is windowed (or is a form). It is set to FALSE only for
+ graphic controls. }
+ {} fCtlClsNameChg: Boolean; //
+ {* True, if control class name changed and memory is allocated to store it. } //
+ {} fRightClick: Boolean;
+ {} fDragging: Boolean;
+ {$ENDIF not USE_FLAGS} //.................................................................
+ fTextAlign: TTextAlign;
+ fVerticalAlign: TVerticalAlign;
+ {$IFDEF STORE_EDGESTYLE}
+ {} fEdgeStyle : TEdgeStyle;
+ {$ENDIF}
+ fLookTabKeys: TTabKeys;
+ fTabOrder: SmallInt;
+ fAlphaBlend: Byte;
+
+ // Caution!!! order of following 5 fields is important!!!
+ fDynHandlers: PList;
+ fChildren: PList;
+ {* List of children. }
+ //________________________________________________________//
+ {$IFDEF GDI}
+
+ fTmpBrush: HBrush;
+ {* Brush handle to return in response to some color set messages.
+ Intended for internal use instead of Brush.Color if possible
+ to avoid using it. }
+ {$IFDEF STORE_fTmpBrushColorRGB}
+ {} fTmpBrushColorRGB: TColor;
+ {$ENDIF}
+ { }
+ public
+ {$IFDEF COMMANDACTIONS_OBJ}
+ fCommandActions: PCommandActionsObj;
+ {$ELSE}
+ fCommandActions: TCommandActions;
+ {$ENDIF}
+ {$IFDEF EVENTS_DYNAMIC}
+ EV: PEvents;
+ protected
+ function ProvideUniqueEvents: PEvents;
+ procedure FreeEV;
+ {$ELSE}
+ protected
+ EV: TEvents;
+ {$ENDIF}
+ protected
+ PP: TProcedures;
+ fMenu: HMenu;
+ {* Usually used to store handle of attached main menu, but sometimes
+ is used to store control ID (for standard GUI controls only). }
+ {$ENDIF GDI}
+ fMenuObj: PObj;
+ {* PMenu pointer to TMenu object. Freed automatically with entire
+ chain of menu objects attached to a control (or form). }
+ {$IFDEF _X_}
+ {$IFDEF GTK}
+ //fMenuBar: PGtkWidget;
+ {$ENDIF GTK}
+ {$ENDIF _X_}
+ {$IFDEF GDI}
+{$IFNDEF NEW_MENU_ACCELL}
+ fAccelTable: HAccel;
+ procedure DoDestroyAccelTable;
+{$ENDIF}
+ {$ENDIF GDI}
+ protected
+ {$IFDEF GDI}
+ {* Handle of accelerator table created by menu(s). }
+ fImageList: PImageList;
+ {* Pointer to first private image list. Control can own several image,
+ lists, linked to a chain of image list objects. All these image lists
+ are released automatically, when control is destroyed. }
+ {$ENDIF GDI}
+ {$IFDEF GDI}
+ fUpdRgn: HRgn;
+ //fCollectUpdRgn: HRGN;
+ fPaintDC: HDC;
+ {$ENDIF GDI}
+ protected
+ fAutoPopupMenu: PObj;
+ //fHelpContext: Integer;
+
+ {$IFDEF GTK}
+ fDeltaX, fDeltaY: Integer;
+ {$ENDIF GTK}
+ // Order of following fields is important:
+ //_______________________________________________________________________________________________
+ //{$ENDIF GDI}
+ {$IFDEF GDI}
+ // //
+ {$ENDIF GDI}
+ fTextColor: TColor; //
+ {* Color of text. Used instead of fFont.Color internally to //
+ avoid usage of Font object if user is not accessing and changing it. } //
+ fColor: TColor; //
+ {* Color of control background. } //
+ fFont: PGraphicTool; //
+ fBrush: PGraphicTool; //
+ fMargin: ShortInt; //
+ fClientTop: ShortInt;
+ fClientBottom: ShortInt;
+ fClientLeft: ShortInt;
+ fClientRight: ShortInt; //
+ {* Store adjustment factor of ClientRect for some 'idiosincrasies' windows, //
+ such as Groupbox or Tabcontrol. } //
+ fCtl3D_child: Byte; //
+ fBoundsRect: TRect; //
+ fCursor: HCursor;
+ //_____________________________________________________________________________________________//
+ // this is the end of fiels set, which order is important
+ fCanvas: PCanvas;
+ {$IFDEF GDI}
+ fDblExcludeRgn: HDC;
+
+ {$ENDIF GDI}
+ {$IFDEF GTK}
+ {} fClickedEvent: Integer;
+ {$ENDIF}
+ public
+ procedure SetOnClick( const Value: TOnEvent );
+ protected
+ {$IFDEF GDI}
+ //fRadio1st: THandle;
+ //fRadioLast : THandle;
+ //fDropDownProc: procedure( Sender : PObj );
+ //fPrevWndProc: Pointer;
+
+ fCurIndex: Integer;
+
+ //fOldDefWndProc: Pointer;
+ procedure SetSBMax(Value: Longint);
+ procedure SetSBMin(Value: Longint);
+ procedure SetSBPageSize(Value: Integer);
+ procedure SetSBPosition(Value: Integer);
+ procedure SetSBMinMax(const Value: TPoint);
+ protected
+ procedure SetOnLVCustomDraw(const Value: TOnLVCustomDraw);
+ {$ENDIF GDI}
+ protected
+ {$IFDEF GDI}
+ //fPaintMsg: TMsg;
+
+ {$ENDIF GDI}
+ FMaxWidth: SmallInt;
+ FMinWidth: SmallInt;
+ FMaxHeight: SmallInt;
+ FMinHeight: SmallInt;
+ {$IFDEF GDI}
+ fStatusCtl: PControl;
+ //fStatusTxt: PKOLChar;
+ {$ENDIF GDI}
+ {$IFDEF GDI}
+ //fDragStartPos: TSmallPoint;
+ //fMouseStartPos: TSmallPoint;
+ {$IFDEF FIX_WIDTH_HEIGHT}
+ {} FFixWidth: Integer;
+ {} FFixHeight: Integer;
+ {$ENDIF}
+ {$ENDIF GDI}
+ //----- order of following 3 fields important: //
+ fCaption: KOLString;
+ fCustomData: Pointer;
+ fControlClassName: PKOLChar; //
+ {$IFDEF GDI}
+ //---------------------------------------------//
+ fCustomObj: PObj;
+ public
+ DF: TDataFields;
+ {* Data fields for certain controls. These are overlapped to
+ economy size of TControl object. }
+ //fCreateParamsExt: procedure( Self_: PControl; var Params: TCreateParams );
+ protected
+
+ {$IFDEF USE_MHTOOLTIP}
+ {$DEFINE var}
+ fHint: PMHHint;
+ {$UNDEF var}
+
+ {$DEFINE function}
+ function GetHint: PMHHint;
+ {$UNDEF function}
+ {$ENDIF}
+
+ {$ENDIF GDI}
+
+ procedure Init; virtual;
+ {$IFDEF GDI}
+ procedure InitParented( AParent: PControl ); virtual;
+ {* Initialization of visual object. }
+ procedure InitOrthaned( AParentWnd: HWnd ); virtual;
+ {* Initialization of visual object. }
+ {$ENDIF GDI}
+ {$IFDEF _X_}
+ {$IFDEF GTK}
+ PROCEDURE InitParented( AParent: PControl; widget: PGtkWidget;
+ {}need_eventbox: Boolean ); VIRTUAL;
+ {* Initialization of visual object. }
+ {$ENDIF GTK}
+ {$ENDIF _X_}
+ {$IFDEF GDI}
+ procedure DestroyChildren;
+ {* Destroys children. Is called in destructor, and can be
+ called in descending classes as earlier as needed to
+ prevent problems of too late destroying of visuals.
+ |<br>
+ Note: since v 2.40, used only for case when a symbol NOT_USE_AUTOFREE4CONTROLS
+ is defined, otherwise all children are destroyed using common mechanism of
+ Add2AutoFree. }
+
+ function GetParentWnd( NeedHandle: Boolean ): HWnd;
+ {* Returns handle of parent window. }
+ function GetParentWindow: HWnd;
+ {* }
+ procedure SetEnabled( Value: Boolean );
+ {* Changes Enabled property value. Overriden here to change enabling
+ status of a window. }
+ function GetEnabled: Boolean;
+ {* Returns True, if Enabled. Overriden here to obtain real window
+ state. }
+ procedure SetVisible( Value: Boolean );
+ {* Sets Visible property value. Overriden here to change visibility
+ of correspondent window. }
+ procedure Set_Visible( Value: Boolean );
+ {* }
+ function GetVisible: Boolean;
+ {* Returns True, if correspondent window is Visible. Overriden
+ to get visibility of real window, not just value stored in object. }
+ function Get_Visible: Boolean;
+ {* Returns True, if correspondent window is Visible, for forms and applet,
+ or if fVisible flag is set, for controls. }
+ protected
+ {$ENDIF GDI}
+ procedure SetCtlColor( Value: TColor );
+ {* Sets TControl's Color property value. }
+ procedure SetBoundsRect( const Value: TRect );
+ {* Sets BoudsRect property value. }
+ function GetBoundsRect: TRect;
+ {* Returns bounding rectangle. }
+ {$IFDEF GDI}
+ function GetIcon: HIcon;
+ {* Returns Icon property. By default, if it is not set,
+ returns Icon property of an Applet. }
+
+ procedure CreateSubclass( var Params: TCreateParams; ControlClassName: PKOLChar );
+ {* Can be used in descending classes to subclass window with given
+ standard Windows ControlClassName - must be called after
+ creating Params but before CreateWindow. Usually it is called
+ in overriden method CreateParams after calling of the inherited one. }
+
+ function UpdateWndStyles: PControl;
+ public
+ {* Updates fStyle, fExStyle, fClsStyle from window handle }
+ procedure SetOnChar(const Value: TOnChar);
+ {* }
+ {$IFDEF SUPPORT_ONDEADCHAR}
+ procedure SetOnDeadChar(const Value: TOnChar);
+ {* }
+ {$ENDIF SUPPORT_ONDEADCHAR}
+ procedure SetOnKeyDown(const Value: TOnKey);
+ {* }
+ procedure SetOnKeyUp(const Value: TOnKey);
+ {* }
+ {$ENDIF GDI}
+ {$IFDEF GDI}
+ procedure SetHelpContext( Value: Integer );
+ {* }
+ procedure SetOnTVDelete( const Value: TOnTVDelete );
+ {* }
+ public procedure SetDefaultBtn(const Index: Integer; const Value: Boolean);
+ protected
+ function GetDefaultBtn(const Index: Integer): Boolean;
+ function DefaultBtnProc( var Msg: TMsg; var Rslt: Integer ): Boolean;
+ {* }
+
+ procedure SetDateTime( Value: TDateTime );
+ function GetDateTime: TDateTime;
+ procedure SetDateTimeRange( Value: TDateTimeRange );
+ function GetDateTimeRange: TDateTimeRange;
+ procedure SetDateTimePickerColor( Index: TDateTimePickerColor; Value: TColor );
+ function GetDateTimePickerColor( Index: TDateTimePickerColor ): TColor;
+ procedure SetDateTimeFormat( const Value: KOLString );
+ function Get_SystemTime: TSystemTime;
+ procedure Set_SystemTime(const Value: TSystemTime);
+
+ procedure SetOnTBCustomDraw( const Value: TOnTBCustomDraw );
+
+ {$ENDIF GDI}
+ procedure DoAutoSize;
+
+ public
+ {$IFDEF GDI}
+ constructor CreateParented( AParent: PControl );
+ {* Creates new instance of TControl object, calling InitParented }
+ constructor CreateOrthaned( AParentWnd: HWnd );
+ {* Creates new instance of TControl object, calling InitOrthaned }
+ {$ENDIF GDI}
+ {$IFDEF _X_}
+ {$IFDEF GTK}
+ CONSTRUCTOR CreateParented( AParent: PControl; widget: PGtkWidget;
+ {}need_eventbox: Boolean );
+ {* Creates new instance of TControl object, calling InitParented }
+ {$ENDIF GTK}
+ {$ENDIF _X_}
+ {$IFDEF GDI}
+ destructor Destroy; virtual;
+ {* Destroyes object. First of all, destructors for all children
+ are called. }
+
+ function GetWindowHandle: HWnd;
+ {* Returns window handle. If window is not yet created,
+ method CreateWindow is called. }
+ procedure CreateChildWindows;
+ {* Enumerates all children recursively and calls CreateWindow for all
+ of these. }
+ {$ENDIF GDI}
+ property Parent: PControl read fParent write SetParent;
+ {* Parent of TParent object. Also must be of TParent type or derived from TParent. }
+ //property Tag: Integer read FTag write FTag; //--------- moved to TObj --------
+ {* User-defined pointer, which can contain any data or reference to
+ anywhere in memory (when used as a pointer).
+ }
+ function ChildIndex( Child: PControl ): Integer;
+ {* Returns index of given child. }
+ procedure MoveChild( Child: PControl; NewIdx: Integer );
+ {* Moves given Child into new position. }
+
+ {$IFDEF GDI}
+ property Enabled: Boolean read GetEnabled write SetEnabled;
+ {* Enabled usually used to decide if control can get keyboard focus
+ or been clicked by mouse. }
+ procedure EnableChildren( Enable, Recursive: Boolean );
+ {* Enables (Enable = TRUE) or disables (Enable = FALSE) all the children
+ of the control. If Recursive = TRUE then all the children of all the
+ children are enabled or disabled recursively. }
+ property Visible: Boolean read Get_Visible write SetVisible;
+ {* Obvious. }
+ property ToBeVisible: Boolean read GetToBeVisible;
+ {* Returns True, if a control is supposed to be visible when its
+ form is showing. }
+ property CreateVisible: Boolean
+ read {$IFDEF USE_FLAGS} GetCreateVisible {$ELSE} fCreateVisible {$ENDIF}
+ write {$IFDEF USE_FLAGS} SetCreateVisible {$ELSE} fCreateVisible {$ENDIF};
+ {* False by default. If You want your form to be created visible and
+ flick due creation, set it to True. This does not affect size of
+ executable anyway. }
+ {$ENDIF GDI}
+ property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
+ {* Bounding rectangle of the visual. Coordinates are relative
+ to top left corner of parent's ClientRect, or to top left corner
+ of screen (for TForm). }
+ property Left: Integer read GetLeft write SetLeft;
+ {* Left horizontal position. }
+ property Top: Integer read GetTop write SetTop;
+ {* Top vertical position. }
+ property Width: Integer read GetWidth write SetWidth;
+ {* Width of TVisual object. }
+ property Height: Integer read GetHeight write SetHeight;
+ {* Height of TVisual object. }
+ property Position: TPoint read GetPosition write Set_Position;
+ {* Represents top left position of the object. See also BoundsRect. }
+ {$IFDEF GDI}
+ property MinWidth: SmallInt index 0
+ {$IFDEF F_P} read GetConstraint
+ {$ELSE DELPHI} read FMinWidth
+ {$ENDIF F_P/DELPHI} write SetConstraint;
+ {* Minimal width constraint. }
+ property MinHeight: SmallInt index 1
+ {$IFDEF F_P} read GetConstraint
+ {$ELSE DELPHI} read FMinHeight
+ {$ENDIF F_P/DELPHI} write SetConstraint;
+ {* Minimal height constraint. }
+ property MaxWidth: SmallInt index 2
+ {$IFDEF F_P} read GetConstraint
+ {$ELSE DELPHI} read FMaxWidth
+ {$ENDIF F_P/DELPHI} write SetConstraint;
+ {* Maximal width constraint. }
+ property MaxHeight: SmallInt index 3
+ {$IFDEF F_P} read GetConstraint
+ {$ELSE DELPHI} read FMaxHeight
+ {$ENDIF F_P/DELPHI} write SetConstraint;
+ {* Maximal height constraint. }
+
+ {$ENDIF GDI}
+ function ClientRect: TRect;
+ {* Client rectangle of TControl. Contrary to VCL, for some
+ classes (e.g. for graphic controls) can be relative
+ not to itself, but to top left corner of the parent's ClientRect
+ rectangle. }
+ {$IFDEF GDI}
+ property ClientWidth: Integer read GetClientWidth write SetClientWidth;
+ {* Obvious. Accessing this property, program forces window latent creation. }
+ property ClientHeight: Integer read GetClientHeight write SetClientHeight;
+ {* Obvious. Accessing this property, program forces window latent creation. }
+
+ function ControlRect: TRect;
+ {* Absolute bounding rectangle relatively to nearest
+ Windowed parent client rectangle (at least to a form, but usually to
+ a Parent).
+ Useful while drawing on device context, provided by such
+ Windowed parent. For form itself is the same as BoundsRect. }
+
+ function ControlAtPos( X, Y: Integer; IgnoreDisabled: Boolean ): PControl;
+ {* Searches control at the given position (relatively to top left
+ corner of the ClientRect). }
+ {$ENDIF GDI}
+ procedure Invalidate;
+ {* Invalidates rectangle, occupied by the visual (but only if Showing =
+ True). }
+ {$IFDEF GDI}
+ public
+ procedure InvalidateEx;
+ {* Invalidates the window and all its children. }
+ procedure InvalidateNC( Recursive: Boolean );
+ {* Invalidates the window and all its children including non-client area. }
+ procedure Update;
+ {* Updates control's window and calls Update for all child controls. }
+ procedure BeginUpdate;
+ {* |<#treeview>
+ |<#listview>
+ |<#richedit>
+ |<#memo>
+ |<#listbox>
+ Call this method to stop visual updates of the control until correspondent
+ EndUpdate called (pairs BeginUpdate - EndUpdate can be nested). }
+ procedure EndUpdate;
+ {* See BeginUpdate. }
+
+ property Windowed: Boolean
+ read {$IFDEF USE_FLAGS} GetWindowed {$ELSE} fWindowed {$ENDIF}
+ write {$IFDEF USE_FLAGS} SetWindowed {$ELSE} fWindowed {$ENDIF};
+ {* Constantly returns True, if object is windowed (i.e. owns
+ correspondent window handle). Otherwise, returns False.
+ |<br>
+ By now, all the controls are windowed (there are no controls in KOL, which are
+ emulating window, acually belonging to Parent - like TGraphicControl
+ in VCL).
+ |<br>
+ Writing of this property provided only for internal purposes,
+ do not change it directly unless you understand well what you do. }
+
+ function HandleAllocated: Boolean;
+ {* Returns True, if window handle is allocated. Has no sense for
+ non-Windowed objects (but now, the KOL has no non-Windowed controls). }
+ {$ENDIF GDI}
+
+ property ChildCount: Integer read GetChildCount;
+ {* Returns number of commonly accessed child objects. }
+ property Children[ Idx: Integer ]: PControl read GetMembers;
+ {* Child items of TVisual object. Property is reintroduced here
+ to separate access to always visible Children[] from restricted
+ a bit Members[]. }
+ {$IFDEF GDI}
+ procedure PaintBackground( DC: HDC; Rect: PRect );
+ {* Is called to paint background in given rectangle. This
+ method is filling clipped area of the Rect rectangle with
+ Color, but only if global event Global_OnPaintBkgnd is
+ not assigned. If assigned, this one is called instead here.
+ |<br>
+ This method made public, so it can be called directly to
+ fill some device context's rectangle. But remember, that
+ independantly of Rect, top left corner of background piece
+ will be located so, if drawing is occure into ControlRect
+ rectangle. }
+ property WindowedParent: PControl read fParent;
+ {* Returns nearest windowed parent, the same as Parent. }
+ {$ENDIF GDI}
+ function ParentForm: PControl;
+ {* |<#form>
+ Returns parent form for a control (of @Self for form itself. }
+ function FormParentForm: PControl;
+ {* |<#form>
+ Returns parent form for a control (of @Self for form itself. For a frame,
+ returns frame panel instead. }
+ function MarkPanelAsForm: PControl;
+ {* Special function for MCK to mark panel as frame parent control. }
+ {$IFDEF GDI}
+ property ActiveControl: PControl read DF.fCurrentControl write DF.fCurrentControl;
+ {* }
+ function Client2Screen( const P: TPoint ): TPoint;
+ {* Converts the client coordinates of a specified point to screen coordinates. }
+ function Screen2Client( const P: TPoint ): TPoint;
+ {* Converts screen coordinates of a specified point to client coordinates. }
+ function CreateWindow: Boolean; virtual;
+ {* |<#form>
+ Creates correspondent window object. Returns True if success (if
+ window is already created, False is returned). If applied to a form,
+ all child controls also allocates handles that time.
+ |<br>
+ Call this method to ensure, that a hanle is allocated for a form,
+ an application button or a control. (It is not necessary to do so in
+ the most cases, even if You plan to work with control's handle directly.
+ But immediately after creating the object, if You want to pass its
+ handle to API function, this can be helpful). }
+ {$ENDIF GDI}
+ {$IFDEF _X_}
+ procedure VisualizyWindow; // for _X_, makes actually visible a window and
+ // all its subwindows recursively, if they are having Visible = TRUE
+ {$ENDIF _X_}
+ {$IFDEF GDI}
+ procedure Close;
+ {* |<#appbutton>
+ |<#form>
+ Closes window. If a window is the main form, this closes application,
+ terminating it. Also it is possible to call Close method for Applet
+ window to stop application. }
+
+ {$IFDEF USE_MHTOOLTIP}
+ {$DEFINE public}
+ property Hint: PMHHint read GetHint;
+ {$UNDEF public}
+ {$ENDIF}
+
+ property Handle: HWnd read fHandle; //GetHandle;
+ {* Returns descriptor of system window object. If window is not yet
+ created, 0 is returned. To allocate handle, call CreateWindow method. }
+
+ property ParentWindow: HWnd read GetParentWindow;
+ {* Returns handle of parent window (not TControl object, but system
+ window object handle). }
+ property ClsStyle: DWord read fClsStyle write SetClsStyle;
+ {* Window class style. Available styles are:
+ |<table border=0>
+ |&L=<tr><td valign=top><font face=Fixedsys>%1</font></td><td>
+ |&E=</td></tr>
+ |&N=<br>
+ <L CS_BYTEALIGNCLIENT> - Aligns the window's client area on the byte boundary
+ (in the x direction) to enhance performance during
+ drawing operations. <E>
+ <L CS_BYTEALIGNWINDOW> - Aligns a window on a byte boundary (in the x
+ direction). <E>
+ <L CS_CLASSDC> - Allocates one device context to be shared by all
+ windows in the class. <E>
+ <L CS_DBLCLKS> - Sends double-click messages to the window
+ procedure when the user double-clicks the mouse while the
+ cursor is within a window belonging to the class. <E>
+ <L CS_GLOBALCLASS> - Allows an application to create a window of
+ the class regardless of the value of the hInstance parameter.
+ <N> You can create a global class by creating
+ the window class in a dynamic-link library (DLL) and listing the
+ name of the DLL in the registry under specific keys. <E>
+ <L CS_HREDRAW> - Redraws the entire window if a movement or
+ size adjustment changes the width of the client area. <E>
+ <L CS_NOCLOSE> - Disables the Close command on the System menu. <E>
+ <L CS_OWNDC> - Allocates a unique device context for each window
+ in the class. <E>
+ <L CS_PARENTDC> - Sets the clipping region of the child window to
+ that of the parent window so that the child can draw on the parent. <E>
+ <L CS_SAVEBITS> - Saves, as a bitmap, the portion of the screen
+ image obscured by a window. Windows uses the saved bitmap to re-create
+ the screen image when the window is removed. <E>
+ <L CS_VREDRAW> - Redraws the entire window if a movement or size
+ adjustment changes the height of the client area. <E>
+ |</table> For more info, see Win32.hlp (keyword 'WndClass');
+ }
+
+
+{$IFDEF GRAPHCTL_XPSTYLES}
+ property edgeStyle : TEdgeStyle
+ read {$IFnDEF STORE_EDGESTYLE} GetEdgeStyle {$ELSE} fEdgeStyle {$ENDIF}
+ write SetEdgeStyle;
+{$ENDIF}
+
+ property Style: DWord read fStyle.Value write SetStyle;
+ {* Window styles. Available styles are:
+ |<table border=0>
+ <L WS_BORDER> Creates a window that has a thin-line border. <E>
+ <L WS_CAPTION> Creates a window that has a title bar (includes the
+ WS_BORDER style). <E>
+ <L WS_CHILD> Creates a child window. This style cannot be used with
+ the WS_POPUP style. <E>
+ <L WS_CHILDWINDOW> Same as the WS_CHILD style. <E>
+ <L WS_CLIPCHILDREN> Excludes the area occupied by child windows
+ when drawing occurs within the parent window. This style is used
+ when creating the parent window. <E>
+ <L WS_CLIPSIBLINGS> Clips child windows relative to each other;
+ that is, when a particular child window receives a WM_PAINT message,
+ the WS_CLIPSIBLINGS style clips all other overlapping child windows
+ out of the region of the child window to be updated. If
+ WS_CLIPSIBLINGS is not specified and child windows overlap, it is
+ possible, when drawing within the client area of a child window,
+ to draw within the client area of a neighboring child window. <E>
+ <L WS_DISABLED> Creates a window that is initially disabled. A
+ disabled window cannot receive input from the user. <E>
+ <L WS_DLGFRAME> Creates a window that has a border of a style
+ typically used with dialog boxes. A window with this style cannot
+ have a title bar. <E>
+ <L WS_GROUP> Specifies the first control of a group of controls.
+ The group consists of this first control and all controls defined
+ after it, up to the next control with the WS_GROUP style.
+ The first control in each group usually has the WS_TABSTOP
+ style so that the user can move from group to group. The user
+ can subsequently change the keyboard focus from one control in
+ the group to the next control in the group by using the direction
+ keys. <E>
+ <L WS_HSCROLL> Creates a window that has a horizontal scroll bar. <E>
+ <L WS_ICONIC> Creates a window that is initially minimized. Same as
+ the WS_MINIMIZE style. <E>
+ <L WS_MAXIMIZE> Creates a window that is initially maximized. <E>
+ <L WS_MAXIMIZEBOX> Creates a window that has a Maximize button.
+ Cannot be combined with the WS_EX_CONTEXTHELP style. The WS_SYSMENU
+ style must also be specified. <E>
+ <L WS_MINIMIZE> Creates a window that is initially minimized.
+ Same as the WS_ICONIC style. <E>
+ <L WS_MINIMIZEBOX> Creates a window that has a Minimize button.
+ Cannot be combined with the WS_EX_CONTEXTHELP style. The WS_SYSMENU
+ style must also be specified. <E>
+ <L WS_OVERLAPPED> Creates an overlapped window. An overlapped
+ window has a title bar and a border. Same as the WS_TILED style. <E>
+ <L WS_OVERLAPPEDWINDOW> Creates an overlapped window with the
+ WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU, WS_THICKFRAME, WS_MINIMIZEBOX,
+ and WS_MAXIMIZEBOX styles. Same as the WS_TILEDWINDOW style. <E>
+ <L WS_POPUP> Creates a pop-up window. This style cannot be used with
+ the WS_CHILD style. <E>
+ <L WS_POPUPWINDOW> Creates a pop-up window with WS_BORDER,
+ WS_POPUP, and WS_SYSMENU styles. The WS_CAPTION and WS_POPUPWINDOW
+ styles must be combined to make the window menu visible. <E>
+ <L WS_SIZEBOX> Creates a window that has a sizing border. Same as the
+ WS_THICKFRAME style. <E>
+ <L WS_SYSMENU> Creates a window that has a window-menu on its title
+ bar. The WS_CAPTION style must also be specified. <E>
+ <L WS_TABSTOP> Specifies a control that can receive the keyboard focus
+ when the user presses the TAB key. Pressing the TAB key changes
+ the keyboard focus to the next control with the WS_TABSTOP style. <E>
+ <L WS_THICKFRAME> Creates a window that has a sizing border.
+ Same as the WS_SIZEBOX style. <E>
+ <L WS_TILED> Creates an overlapped window. An overlapped window has
+ a title bar and a border. Same as the WS_OVERLAPPED style. <E>
+ <L WS_TILEDWINDOW> Creates an overlapped window with the
+ WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU, WS_THICKFRAME,
+ WS_MINIMIZEBOX, and WS_MAXIMIZEBOX styles. Same as the
+ WS_OVERLAPPEDWINDOW style. <E>
+ <L WS_VISIBLE> Creates a window that is initially visible. <E>
+ <L WS_VSCROLL> Creates a window that has a vertical scroll bar. <E>
+ |</table>
+ See also Win32.hlp (topic CreateWindow).
+ }
+ property ExStyle: DWord read fExStyle write SetExStyle;
+ {* Extra window styles. Available flags are following:
+ |<table border=0>
+ <L WS_EX_ACCEPTFILES> Specifies that a window created with this style
+ accepts drag-drop files. <E>
+ <L WS_EX_APPWINDOW> Forces a top-level window onto the taskbar
+ when the window is minimized. <E>
+ <L WS_EX_CLIENTEDGE> Specifies that a window has a border with a
+ sunken edge. <E>
+ <L WS_EX_CONTEXTHELP> Includes a question mark in the title bar of
+ the window. When the user clicks the question mark, the cursor
+ changes to a question mark with a pointer. If the user then clicks
+ a child window, the child receives a WM_HELP message. The child
+ window should pass the message to the parent window procedure,
+ which should call the WinHelp function using the HELP_WM_HELP
+ command. The Help application displays a pop-up window that
+ typically contains help for the child window.WS_EX_CONTEXTHELP
+ cannot be used with the WS_MAXIMIZEBOX or WS_MINIMIZEBOX styles. <E>
+ <L WS_EX_CONTROLPARENT> Allows the user to navigate among the child
+ windows of the window by using the TAB key. <E>
+ <L WS_EX_DLGMODALFRAME> Creates a window that has a double border;
+ the window can, optionally, be created with a title bar by
+ specifying the WS_CAPTION style in the dwStyle parameter. <E>
+ <L WS_EX_LEFT> Window has generic "left-aligned" properties. This
+ is the default. <E>
+ <L WS_EX_LEFTSCROLLBAR> If the shell language is Hebrew, Arabic, or
+ another language that supports reading order alignment, the
+ vertical scroll bar (if present) is to the left of the client
+ area. For other languages, the style is ignored and not treated
+ as an error. <E>
+ <L WS_EX_LTRREADING> The window text is displayed using Left to
+ Right reading-order properties. This is the default. <E>
+ <L WS_EX_MDICHILD> Creates an MDI child window. <E>
+ <L WS_EX_NOPARENTNOTIFY> Specifies that a child window created
+ with this style does not send the WM_PARENTNOTIFY message to its
+ parent window when it is created or destroyed. <E>
+ <L WS_EX_OVERLAPPEDWINDOW> Combines the WS_EX_CLIENTEDGE and
+ WS_EX_WINDOWEDGE styles. <E>
+ <L WS_EX_PALETTEWINDOW> Combines the WS_EX_WINDOWEDGE,
+ WS_EX_TOOLWINDOW, and WS_EX_TOPMOST styles. <E>
+ <L WS_EX_RIGHT> Window has generic "right-aligned" properties.
+ This depends on the window class. This style has an effect only
+ if the shell language is Hebrew, Arabic, or another language that
+ supports reading order alignment; otherwise, the style is
+ ignored and not treated as an error. <E>
+ <L WS_EX_RIGHTSCROLLBAR> Vertical scroll bar (if present) is to the
+ right of the client area. This is the default. <E>
+ <L WS_EX_RTLREADING> If the shell language is Hebrew, Arabic, or
+ another language that supports reading order alignment, the
+ window text is displayed using Right to Left reading-order
+ properties. For other languages, the style is ignored and not
+ treated as an error. <E>
+ <L WS_EX_STATICEDGE> Creates a window with a three-dimensional
+ border style intended to be used for items that do not accept
+ user input. <E>
+ <L WS_EX_TOOLWINDOW> Creates a tool window; that is, a window
+ intended to be used as a floating toolbar. A tool window has
+ a title bar that is shorter than a normal title bar, and the
+ window title is drawn using a smaller font. A tool window does
+ not appear in the taskbar or in the dialog that appears when
+ the user presses ALT+TAB. <E>
+ <L WS_EX_TOPMOST> Specifies that a window created with this style
+ should be placed above all non-topmost windows and should stay
+ above them, even when the window is deactivated. To add or remove
+ this style, use the SetWindowPos function. <E>
+ <L WS_EX_TRANSPARENT> Specifies that a window created with this
+ style is to be transparent. That is, any windows that are
+ beneath the window are not obscured by the window. A window
+ created with this style receives WM_PAINT messages only after
+ all sibling windows beneath it have been updated. <E>
+ <L WS_EX_WINDOWEDGE> Specifies that a window has a border with
+ a raised edge. <E>
+ |</table>
+ See also Win32.hlp (topic CreateWindowEx).
+ }
+
+ property Cursor: HCursor read fCursor write SetCursor;
+ {* Current cursor. For most of controls, sets initially to IDC_ARROW. See
+ also ScreenCursor. }
+ procedure CursorLoad( Inst: Integer; ResName: PKOLChar );
+ {* Loads Cursor from the resource. See also comments for Icon property. }
+
+ property Icon: HIcon read {$IFDEF SMALLEST_CODE} DF.fIcon {$ELSE} GetIcon {$ENDIF}
+ write SetIcon;
+ {* |<#appbutton>
+ |<#form>
+ Icon. By default, icon of the Applet is used. To load icon from the
+ resource, use IconLoad or IconLoadCursor method - this is more correct, because
+ in such case a special flag is set to prevent attempts to destroy
+ shared icon object in the destructor of the control. }
+
+ procedure IconLoad( Inst: Integer; ResName: PKOLChar );
+ {* |<#appbutton>
+ |<#form>
+ See Icon property. }
+ procedure IconLoadCursor( Inst: Integer; ResName: PKOLChar );
+ {* |<#appbutton>
+ |<#form>
+ Loads Icon from the cursor resource. See also Icon property. }
+
+ property Menu: HMenu read fMenu write SetMenu;
+
+ {* Menu (or ID of control - for standard GUI controls). }
+ property HelpContext: Integer read GetHelpContext write SetHelpContext;
+ {* Help context. }
+ function AssignHelpContext( Context: Integer ): PControl;
+ {* Assigns HelpContext and returns @ Self (can be used in initialization
+ of a control in a chain of "transparent" calls). }
+
+ procedure CallHelp( Context: Integer; CtxCtl: PControl {; CtlID: Integer} );
+ {* Method of a form or Applet. Call it to show help with the given context
+ ID. If the Context = 0, help contents is displayed. By default,
+ WinHelp is used. To allow using HtmlHelp, call AssignHtmlHelp global
+ function. When WinHelp used, HelpPath variable can be assigned directly.
+ If HelpPath variable is not assigned, application name
+ (and path) is used, with extension replaced to '.hlp'. }
+
+ property HelpPath: KOLString read GetHelpPath write SetHelpPath;
+ {* Property of a form or an Applet. Change it to provide custom path to
+ WinHelp format help file. If HtmlHelp used, call global procedure
+ AssignHtmlHelp instead. }
+
+ property OnHelp: TOnHelp
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnHelp {$ELSE} EV.fOnHelp {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnHelp {$ELSE} EV.fOnHelp {$ENDIF};
+ {* An event of a form, it is called when F1 pressed or help topic requested
+ by any other way. To prevent showing help, nullify Sender. Set Popup to
+ TRUE to provide showing help in a pop-up window. It is also possible to
+ change Context dynamically. }
+
+ {$ENDIF GDI}
+ property Caption: KOLString read GetCaption write SetCaption;
+ {* |<#appbutton>
+ |<#form>
+ |<#button>
+ |<#bitbtn>
+ |<#label>
+ |<#wwlabel>
+ |<#3dlabel>
+ Caption of a window. For standard Windows buttons, labels and so on
+ not a caption of a window, but text of the window. }
+ property Text: KOLString read GetCaption write SetCaption;
+ {* |<#edit>
+ |<#memo>
+ The same as Caption. To make more convenient with Edit controls. For
+ Rich Edit control, use property RE_Text. }
+
+ {$IFDEF GDI}
+ property SelStart: Integer read GetSelStart write SetSelStart;
+ {* |<#edit>
+ |<#memo>
+ |<#richedit>
+ Start of selection (editbox - character position). }
+ property SelLength: Integer read GetSelLength write SetSelLength;
+ {* |<#edit>
+ |<#memo>
+ |<#richedit>
+ |<#listbox>
+ |<#listview>
+ Length of selection (editbox - number of characters selected, multiselect
+ listbox or listview - number of items selected).
+ |<br>
+ Note, that for combobox and single-select listbox it always returns 0
+ (though for single-select listview, returns 1, if there is an item
+ selected).
+ |<br>
+ It is possible to set SelLength only for memo and richedit controls. }
+
+ property Selection: KOLString read GetSelection write SetSelection;
+ {* |<#edit>
+ |<#memo>
+ |<#richedit>
+ Selected text (editbox, richedit) as string. Can be useful to replace
+ selection. For rich edit, use RE_Text[ reText, TRUE ], if you want to
+ read correctly characters from another locale then ANSI only. }
+ procedure SelectAll;
+ {* |<#edit>
+ |<#memo>
+ |<#richedit>
+ Makes all the text in editbox or RichEdit, or all items in listbox
+ selected. }
+
+ procedure ReplaceSelection( const Value: KOLString; aCanUndo: Boolean );
+ {* |<#edit>
+ |<#memo>
+ |<#richedit>
+ Replaces selection (in edit, RichEdit). Unlike assigning new value
+ to Selection property, it is possible to specify, if operation can
+ be undone.
+ |<br>
+ 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 := 'bolded text'#13#10;
+ ! RichEdit1.RE_FmtBold := FALSE;
+ ! RichEdit1.RE_FmtItalic := TRUE;
+ ! RichEdit1.Selection := 'italized text';
+ !... }
+
+ procedure DeleteLines( FromLine, ToLine: Integer );
+ {* |<#edit>
+ |<#memo>
+ |<#richedit>
+ Deletes lines from FromLine to ToLine (inclusively, i.e. 0 to 0 deletes
+ one line with index 0). Current selection is restored as possible. }
+ property CurIndex: Integer read GetCurIndex write SetCurIndex;
+ {* |<#listbox>
+ |<#combo>
+ |<#toolbar>
+ Index of current item (for listbox, combobox) or button index pressed
+ or dropped down (for toolbar button, and only in appropriate event
+ handler call).
+ |<br>
+ You cannot use it to set or remove a selection in a multiple-selection
+ list box, so you should set option loNoExtendSel to true.
+ |<br>
+ In OnClick event handler, CurIndex has not yet changed for listbox or combobox.
+ Use OnSelChange to respond to selection changes. }
+
+ property Count: Integer read GetItemsCount write SetItemsCount;
+ {* |<#listbox>
+ |<#combo>
+ |<#listview>
+ |<#treeview>
+ |<#edit>
+ |<#memo>
+ |<#richedit>
+ |<#toolbar>
+ Number of items (listbox, combobox, listview) or lines (multiline
+ editbox, richedit control) or buttons (toolbar). It is possible to
+ assign a value to this property only for listbox control with loNoData
+ style and for list view control with lvoOwnerData style (virtual list
+ box and list view). }
+
+ property Items[ Idx: Integer ]: KOLString read GetItems write SetItems;
+ {* |<#edit>
+ |<#listbox>
+ |<#combo>
+ |<#memo>
+ |<#richedit>
+ Obvious. Used with editboxes, listbox, combobox. With list view, use
+ property LVItems instead. }
+
+ function Item2Pos( ItemIdx: Integer ): DWORD;
+ {* |<#edit>
+ |<#memo>
+ Only for edit controls: converts line index to character position. }
+ function Pos2Item( Pos: Integer ): DWORD;
+ {* |<#edit>
+ |<#memo>
+ Only for edit controls: converts character position to line index. }
+
+ function SavePosition: TEditPositions;
+ {* |<#edit>
+ |<#memo>
+ Only for edit controls: saves current editor selection and scroll
+ positions. To restore position, use RestorePosition with a structure,
+ containing saved position as a parameter. }
+ procedure RestorePosition( const p: TEditPositions );
+ {* |<#edit>
+ |<#memo>
+ Call RestorePosition with a structure, containing saved position
+ as a parameter (this structure filled in in SavePosition method).
+ If you set RestoreScroll to FALSE, only selection is restored,
+ without scroll position. }
+ procedure UpdatePosition( var p: TEditPositions; FromPos,
+ CountInsertDelChars, CountInsertDelLines: Integer );
+ {* |<#edit>
+ |<#memo>
+ If you called SavePosition and then make some changes in the edit control,
+ calling RestorePosition will fail if chages are affecting selection size.
+ The problem can be solved updating saved position info using this method.
+ Pass a count of inserted characters and lines as a positive number and a
+ count of deleted characters as a negative number here. CountInsertDelLines
+ is optional paramters: if you do not specify it, only selection is fixed.
+ }
+
+ function EditTabChar: PControl;
+ {* |<#edit>
+ |<#memo>
+ Call this method (once) to provide insertion of tab character (code #9)
+ when tab key is pressed on keyboard. }
+
+ function IndexOf( const S: KOLString ): Integer;
+ {* |<#listbox>
+ |<#combobox>
+ |<#tabcontrol>
+ Works for the most of control types, though some of those
+ have its own methods to search given item. If a control is not
+ list box or combobox, item is finding by enumerating all
+ the Items one by one. See also SearchFor method. }
+ function SearchFor( const S: KOLString; StartAfter: Integer; Partial: Boolean ): Integer;
+ {* |<#listbox>
+ |<#combobox>
+ |<#tabcontrol>
+ Works for the most of control types, though some of those
+ have its own methods to search given item. If a control is not
+ list box or combobox, item is finding by enumerating all
+ the Items one by one. See also IndexOf method. }
+
+ property ItemSelected[ ItemIdx: Integer ]: Boolean read GetItemSelected write SetItemSelected;
+ {* |<#edit>
+ |<#memo>
+ |<#listbox>
+ |<#combo>
+ |<#listview>
+ Returns True, if a line (in editbox) or an item (in listbox, combobox,
+ listview) is selected.
+ Can be set only for listboxes. For listboxes, which are not multiselect, and
+ for combo lists, it is possible only to set to True, to change selection. }
+
+ property ItemData[ Idx: Integer ]: DWORD read GetItemData write SetItemData;
+ {* |<#listbox>
+ |<#combo>
+ Access to user-defined data, associated with the item of a list box and
+ combo box. }
+ property OnDropDown: TOnEvent 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>
+ 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). }
+ property DroppedWidth: Integer read DF.FDroppedWidth write SetDroppedWidth;
+ {* |<#combo>
+ 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. }
+ procedure AddDirList( const Filemask: KOLString; Attrs: DWORD );
+ {* |<#listbox>
+ |<#combo>
+ Can be used only with listbox and combobox - to add directory list items,
+ filtered by given Filemask (can contain wildcards) and Attrs. Following
+ flags can be combined in Attrs:
+ |<table border=0>
+ |&L=<tr><td>%1</td><td>
+ <L DDL_ARCHIVE> Include archived files. <E>
+ <L DDL_DIRECTORY> Includes subdirectories. Subdirectory names are
+ enclosed in square brackets ([ ]). <E>
+ <L DDL_DRIVES> Includes drives. Drives are listed in the form [-x-],
+ where x is the drive letter. <E>
+ <L DDL_EXCLUSIVE> Includes only files with the specified attributes.
+ By default, read-write files are listed even if DDL_READWRITE is
+ not specified. Also, this flag needed to list directories only,
+ etc. <E>
+ <L DDL_HIDDEN> Includes hidden files. <E>
+ <L DDL_READONLY> Includes read-only files. <E>
+ <L DDL_READWRITE> Includes read-write files with no additional
+ attributes. <E>
+ <L DDL_SYSTEM> Includes system files. <E>
+ </table>
+ If the listbox is sorted, directory items will be sorted (alpabetically). }
+ property OnBitBtnDraw: TOnBitBtnDraw
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnBitBtnDraw {$ELSE} EV.fOnBitBtnDraw {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnBitBtnDraw {$ELSE} EV.fOnBitBtnDraw {$ENDIF};
+ {* |<#bitbtn>
+ Special event for BitBtn. Using it, it is possible to provide
+ additional effects, such as highlighting button text (by changing
+ its Font and other properties). If the handler returns True, it is
+ supposed that it made all drawing and there are no further drawing
+ occure. }
+ property BitBtnDrawMnemonic: Boolean read DF.fBitBtnDrawMnemonic write SetBitBtnDrawMnemonic;
+ {* |<#bitbtn>
+ Set this property to TRUE to provide correct drawing of bit btn control
+ caption with '&' characters (to remove such characters, and underline
+ follow ones). }
+ property TextShiftX: Integer read DF.fTextShiftX write DF.fTextShiftX;
+ {* |<#bitbtn>
+ Horizontal shift for bitbtn text when the bitbtn is pressed. }
+ property TextShiftY: Integer read DF.fTextShiftY write DF.fTextShiftY;
+ {* |<#bitbtn>
+ Vertical shift for bitbtn text when the bitbtn is pressed. }
+ property BitBtnImgIdx: Integer read GetBitBtnImgIdx write SetBitBtnImgIdx;
+ {* |<#bitbtn>
+ BitBtn image index for the first image in list view, used as bitbtn
+ image. It is used only in case when BitBtn is created with bboImageList
+ option. }
+ property BitBtnImgList: THandle read GetBitBtnImageList write SetBitBtnImageList;
+ {* |<#bitbtn>
+ BitBtn Image list. Assign image list handle to change it. }
+
+ function SetButtonIcon( aIcon: HIcon ): PControl;
+ {* |<#button>
+ Sets up button icon image and changes its styles. Returns button itself. }
+ function SetButtonBitmap( aBmp: HBitmap ): PControl;
+ {* |<#button>
+ Sets up button icon image and changes its styles. Returns button itself. }
+
+ property OnMeasureItem: TOnMeasureItem
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnMeasureItem {$ELSE} EV.fOnMeasureItem {$ENDIF}
+ write SetOnMeasureItem;
+ {* |<#combo>
+ |<#listbox>
+ |<#listview>
+ This event is called for owner-drawn controls, such as list box, combo box,
+ list view with appropriate owner-drawn style. For fixed item height controls
+ (list box with loOwnerDrawFixed style, combobox with coOwnerDrawFixed and
+ list view with lvoOwnerDrawFixed option) this event is called once. For
+ list box with loOwnerDrawVariable style and for combobox with coOwnerDrawVariable
+ style this event is called for every item. }
+
+ property DefaultBtn: Boolean index 13
+ {$IFDEF F_P} read GetDefaultBtn
+ {$ELSE DELPHI} read {$IFDEF USE_FLAGS} GetDefaultBtn {$ELSE} fDefaultBtn {$ENDIF}
+ {$ENDIF F_P/DELPHI} write SetDefaultBtn;
+ {* |<#button>
+ |<#bitbtn>
+ Set this property to true to make control clicked when ENTER key is pressed.
+ This property uses OnMessage event of the parent form, storing it into
+ fOldOnMessage field and calling in chain. So, assign default button
+ after setting OnMessage event for the form. }
+ property CancelBtn: Boolean index 27
+ {$IFDEF F_P} read GetDefaultBtn
+ {$ELSE DELPHI} read {$IFDEF USE_FLAGS} GetDefaultBtn {$ELSE} fCancelBtn {$ENDIF}
+ {$ENDIF F_P/DELPHI} write SetDefaultBtn;
+ {* |<#button>
+ |<#bitbtn>
+ Set this property to true to make control clicked when escape key is pressed.
+ This property uses OnMessage event of the parent form, storing it into
+ fOldOnMessage field and calling in chain. So, assign cancel button
+ after setting OnMessage event for the form. }
+ function AllBtnReturnClick: PControl;
+ {* Call this method for a form or control to provide clicking
+ a focused button when ENTER pressed. By default, a button can be clicked
+ only by SPACE key from the keyboard, or by mouse. }
+ property IgnoreDefault: Boolean
+ read {$IFDEF USE_FLAGS} GetIgnoreDefault {$ELSE} fIgnoreDefault {$ENDIF}
+ write {$IFDEF USE_FLAGS} SetIgnoreDefault {$ELSE} fIgnoreDefault {$ENDIF};
+ {* Change this property to TRUE to ignore default button reaction on
+ press ENTER key when a focus is grabbed of the control. Default
+ value is different for different controls. By default, DefaultBtn
+ ignored in memo, richedit (even if read-only). }
+
+ {$ENDIF GDI}
+ property Color: TColor read fColor write SetCtlColor;
+ {* Property Color is one of the most common for all visual
+ elements (like form, control etc.) Please note, that standard GUI button
+ can not change its color and the most characteristics of the Font. Also,
+ standard button can not become Transparent. Use bitbtn for such purposes.
+ Also, changing Color property for some kinds of control has no effect (rich edit,
+ list view, tree view, etc.). To solve this, use native (for such controls)
+ color property, or call Perform method with appropriate message to set the
+ background color. }
+ property Font: PGraphicTool read GetFont;
+ {* If the Font property is not accessed, correspondent TGraphicTool object
+ is not created and its methods are not included into executable. Leaving
+ properties Font and Brush untouched can economy executable size a lot. }
+ {$IFDEF GDI}
+ property Brush: PGraphicTool read GetBrush;
+ {* If not accessed, correspondent TGraphicTool object is not created
+ and its methods are not referenced. See also note on Font property. }
+
+ property Ctl3D: Boolean read Get_Ctl3D write SetCtl3D;
+ {* Inheritable from parent controls to child ones. }
+
+ procedure Show;
+ {* |<#appbutton>
+ |<#form>
+ Makes control visible and activates it. }
+ function ShowModal: Integer;
+ {* |<#form>
+ Can be used only with a forms to show it modal. See also global function
+ ShowMsgModal.
+ |<br>
+ To use a form as a modal, it is possible to make it either auto-created
+ or dynamically created. For a first case, You (may be prefer to hide a
+ form after showing it as a modal:
+ !
+ ! procedure TForm1.Button1Click( Sender: PObj );
+ ! begin
+ ! Form2.Form.ShowModal;
+ ! Form2.Form.Hide;
+ ! end;
+ !
+ Another way is to create modal form just before showing it (this economies
+ system resources):
+ !
+ ! procedure TForm1.Button1Click( Sender: PObj );
+ ! begin
+ ! NewForm2( Form2, Applet );
+ ! Form2.Form.ShowModal;
+ ! Form2.Form.Free; // Never call Form2.Free or Form2.Form.Close
+ ! end; // but always Form2.Form.Free; (!)
+ !
+ In samples above, You certainly can place any wished code before and after
+ calling ShowModal method.
+ |<br>
+ Do not forget that if You have more than a single form in your project,
+ separate Applet object should be used.
+ |<br>
+ See also ShowModalEx.
+ }
+ function ShowModalParented( const AParent: PControl ): Integer;
+ {* by Alexander Pravdin. The same as ShowModal, but with a certain
+ form as a parent. }
+ function ShowModalEx: Integer;
+ {* The same as ShowModal, but all the windows of current thread are
+ disabled while showing form modal. This is useful if KOL form from
+ a DLL is used modally in non-KOL application. }
+ property ModalResult: Integer read DF.fModalResult
+ write {$IFDEF USE_SETMODALRESULT} SetModalResult {$ELSE} DF.fModalResult {$ENDIF};
+ {* |<#form>
+ Modal result. Set it to value<>0 to stop modal dialog. By agreement,
+ value 1 corresponds 'OK', 2 - 'Cancel'. But it is totally by decision
+ of yours how to interpret this value. }
+ property Modal: Boolean read GetModal;
+ {* |<#form>
+ TRUE, if the form is shown modal. }
+ property ModalForm: PControl read DF.fModalForm write DF.fModalForm;
+ {* |<#form>
+ |<#appbutton>
+ Form currently shown modal from this form or from Applet. }
+
+ procedure Hide;
+ {* |<#appbutton>
+ |<#form>
+ Makes control hidden. }
+ property OnShow: TOnEvent
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnShow {$ELSE} EV.FOnShow {$ENDIF}
+ write SetOnShow;
+ {* Is called when a control or form is to be shown. This event is not fired
+ for a form, if its WindowState initially is set to wsMaximized or
+ wsMinimized. This behaviour is by design (the window does not receive
+ WM_SHOW message in such case). }
+ property OnHide: TOnEvent
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnHide {$ELSE} EV.FOnHide {$ENDIF}
+ write SetOnHide;
+ {* Is called when a control or form becomes hidden. }
+ property WindowState: TWindowState read GetWindowState write SetWindowState;
+ {* |<#form>
+ Window state. }
+
+ {$ENDIF GDI}
+ property Canvas: PCanvas read GetCanvas;
+ {* |<#paintbox>
+ Placeholder for Canvas: PCanvas. But in KOL, it is possible to
+ create applets without canvases at all. To do so, avoid using
+ Canvas and use DC directly (which is passed in OnPaint event). }
+ {$IFDEF GDI}
+ function CallDefWndProc( var Msg: TMsg ): Integer;
+ {* Function to be called in WndProc method to redirect message handling
+ to default window procedure. }
+ function DoSetFocus: Boolean;
+ {* Sets focus for Enabled window. Returns True, if success. }
+
+ procedure MinimizeNormalAnimated;
+ {* |<#form>
+ Apply this method to a main form (not to another form or Applet,
+ even when separate Applet control is not used and main form matches it!).
+ This provides normal animated visual minimization for the application.
+ It therefore has no effect, if animation during minimize/resore is
+ turned off by user.
+ |<br>
+ Applying this method also provides for the main form (only for it)
+ correct restoring the form maximized if it was maximized while
+ minimizing the application. See also RestoreNormalMaximized method. }
+ procedure RestoreNormalMaximized;
+ {* |<#form>
+ Apply to any form for which it is important to restore it maximized
+ when the application was minimizing while such form was maximized.
+ If the method MinimizeNormalAnimated was called for the main form,
+ then the correct behaviour is already provided for the main form, so
+ in such case it is no more necessary to call also this method, but
+ calling it therefore is not an error. }
+
+ property OnMessage: TOnMessage
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnMessage {$ELSE} EV.fOnMessage {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnMessage {$ELSE} EV.fOnMessage {$ENDIF};
+ {* |<#appbutton>
+ |<#form>
+ Is called for every message processed by TControl object. And for
+ Applet window, this event is called also for all messages, handled by
+ all its child windows (forms). }
+
+ {$ENDIF GDI}
+ function IsMainWindow: Boolean;
+ {* |<#appbutton>
+ |<#form>
+ Returns True, if a window is the main in application (created first
+ after the Applet, or matches the Applet). }
+ property IsApplet: Boolean read {$IFDEF USE_FLAGS} GetIsApplet {$ELSE} FIsApplet {$ENDIF};
+ {* Returns true, if the control is created using NewApplet (or CreateApplet).
+ }
+ property IsForm: Boolean read {$IFDEF USE_FLAGS} GetIsForm {$ELSE} fIsForm {$ENDIF};
+ {* Returns True, if the object is form window. }
+ property IsMDIChild: Boolean read {$IFDEF USE_FLAGS} GetIsMDIChild {$ELSE} fIsMDIChild {$ENDIF};
+ {* Returns TRUE, if the object is MDI child form. In such case, IsForm also
+ returns TRUE. }
+ property IsControl: Boolean read {$IFDEF USE_FLAGS} GetIsControl {$ELSE} fIsControl {$ENDIF};
+ {* Returns True, is the control is control (not form or applet). }
+ property IsButton: Boolean read {$IFDEF USE_FLAGS} GetIsButton {$ELSE} fIsButton {$ENDIF};
+ {* Returns True, if the control is button-like or containing buttons (button,
+ bitbtn, checkbox, radiobox, toolbar). }
+
+ {$IFDEF GDI}
+ function ProcessMessage: Boolean;
+ {* |<#appbutton>
+ Processes one message. See also ProcessMessages. }
+
+ procedure ProcessMessages;
+ {* |<#appbutton>
+ Processes pending messages during long cycle of calculation,
+ allowing to window to be repainted if needed and to respond to other
+ messages. But if there are no such messages, your application can be
+ stopped until such one appear in messages queue. To prevent such
+ situation, use method ProcessPendingMessages instead. }
+
+ procedure ProcessMessagesEx;
+ {* Version of ProcessMessages, which works always correctly, even if
+ the application is minimized or background. }
+
+ procedure ProcessPendingMessages;
+ {* |<#appbutton>
+ Similar to ProcessMessages, but without waiting of
+ message in messages queue. I.e., if there are no pending
+ messages, this method immediately returns control to your
+ code. This method is better to call during long cycle of
+ calculation (then ProcessMessages). }
+ procedure ProcessPaintMessages;
+ {* }
+ function WndProc( var Msg: TMsg ): Integer; virtual; //{$IFNDEF DEBUG_MCK} virtual; {$ENDIF}
+ {* Responds to all Windows messages, posted (sended) to the
+ window, before all other proceeding. You can override it in
+ derived controls, but in KOL there are several other ways
+ to control message flow of existing controls without deriving
+ another costom controls for only such purposes. See OnMessage,
+ AttachProc. }
+ property HasBorder: Boolean read GetHasBorder write SetHasBorder;
+ {* |<#form>
+ Obvious. Form-aware. }
+
+ property HasCaption: Boolean read GetHasCaption write SetHasCaption;
+ {* |<#form>
+ Obvious. Form-aware. }
+ property CanResize: Boolean read GetCanResize write SetCanResize;
+ {* |<#form>
+ Obvious. Form-aware. }
+ property StayOnTop: Boolean read GetStayOnTop write SetStayOnTop;
+ {* |<#form>
+ Obvious. Form-aware, but can be applied to controls. }
+ property Border: ShortInt read fMargin write fMargin;
+ {* |<#form>
+ Distance between edges and child controls and between child
+ controls by default (if methods PlaceRight, PlaceDown, PlaceUnder,
+ ResizeParent, ResizeParentRight, ResizeParentBottom are called).
+ |<br>
+ Originally was named Margin, now I recommend to use the name 'Border' to
+ avoid confusion with MarginTop, MarginBottom, MarginLeft and
+ MarginRight properties.
+ |<br>
+ Initial value is always 2. Border property is used in realigning
+ child controls (when its Align property is not caNone), and value
+ of this property determines size of borders between edges of children
+ and its parent and between aligned controls too.
+ |<br>
+ See also properties MarginLeft, MarginRight, MarginTop, MarginBottom. }
+ function SetBorder( Value: Integer ): PControl;
+ {* Assigns new Border value, and returns @ Self. }
+
+ property Margin: ShortInt read fMargin write fMargin;
+ {* |<#form>
+ Old name for property Border. }
+
+ property MarginTop: ShortInt index 1
+ {$IFDEF F_P} read GetClientMargin
+ {$ELSE DELPHI} read fClientTop
+ {$ENDIF F_P/DELPHI} write SetClientMargin;
+ {* Additional distance between true window client top and logical top of
+ client rectangle. This value is added to Top of rectangle, returning
+ by property ClientRect. Together with other margins and property Border,
+ this property allows to change view of form for case, that Align property
+ is used to align controls on parent (it is possible to provide some
+ distance from child controls to its parent, and between child controls.
+ |<br>
+ Originally this property was introduced to compensate incorrect
+ ClientRect property, calculated for some types of controls.
+ |<br>
+ See also properties Border, MarginBottom, MarginLeft, MarginRight. }
+ property MarginBottom: ShortInt index 2
+ {$IFDEF F_P} read GetClientMargin
+ {$ELSE DELPHI} read fClientBottom
+ {$ENDIF F_P/DELPHI} write SetClientMargin;
+ {* The same as MarginTop, but a distance between true window Bottom of
+ client rectangle and logical bottom one. Take in attention, that this value
+ should be POSITIVE to make logical bottom edge located above true edge.
+ |<br>
+ See also properties Border, MarginTop, MarginLeft, MarginRight. }
+ property MarginLeft: ShortInt index 3
+ {$IFDEF F_P} read GetClientMargin
+ {$ELSE DELPHI} read fClientLeft
+ {$ENDIF F_P/DELPHI} write SetClientMargin;
+ {* The same as MarginTop, but a distance between true window Left of
+ client rectangle and logical left edge.
+ |<br>
+ See also properties Border, MarginTop, MarginRight, MarginBottom. }
+ property MarginRight: ShortInt index 4
+ {$IFDEF F_P} read GetClientMargin
+ {$ELSE DELPHI} read fClientRight
+ {$ENDIF F_P/DELPHI} write SetClientMargin;
+ {* The same as MarginLeft, but a distance between true window Right of
+ client rectangle and logical bottom one. Take in attention, that this value
+ should be POSITIVE to make logical right edge located left of true edge.
+ |<br>
+ See also properties Border, MarginTop, MarginLeft, MarginBottom. }
+
+ property Tabstop: Boolean
+ {$IFDEF USE_FLAGS}
+ read GetTabStop write SetTabStop
+ {$ELSE}
+ read fTabstop write fTabstop
+ {$ENDIF}
+ ;
+ {* True, if control can be focused using tabulating between controls.
+ Set it to False to make control unavailable for keyboard, but only
+ for mouse. }
+
+ property TabOrder: SmallInt read fTabOrder write SetTabOrder;
+ {* Order of tabulating of controls. Initially, TabOrder is equal to
+ creation order of controls. If TabOrder changed, TabOrder of
+ all controls with not less value of one is shifted up. To place
+ control before another, assign TabOrder of one to another.
+ For example:
+ ! Button1.TabOrder := EditBox1.TabOrder;
+ In code above, Button1 is placed just before EditBox1 in tabulating
+ order (value of TabOrder of EditBox1 is incremented, as well as
+ for all follow controls). }
+
+ property Focused: Boolean read GetFocused write SetFocused;
+ {* True, if the control is current on form (but check also, what form
+ itself is focused). For form it is True, if the form is active (i.e.
+ it is foreground and capture keyboard). Set this value to True to make
+ control current and focused (if applicable). }
+
+ function BringToFront: PControl;
+ {* Changes z-order of the control, bringing it to the topmost level. }
+ function SendToBack: PControl;
+ {* Changes z-order of the control, sending it to the back of siblings. }
+ {$ENDIF GDI}
+ property TextAlign: TTextAlign read GetTextAlign write SetTextAlign;
+ {* |<#label>
+ |<#panel>
+ |<#button>
+ |<#bitbtn>
+ |<#edit>
+ |<#memo>
+ Text horizontal alignment. Applicable to labels, buttons,
+ multi-line edit boxes, panels. }
+ property VerticalAlign: TVerticalAlign read GetVerticalAlign write SetVerticalAlign;
+ {* |<#button>
+ |<#label>
+ |<#panel>
+ Text vertical alignment. Applicable to buttons, labels and panels. }
+ {$IFDEF GDI}
+ property WordWrap: Boolean
+ {$IFDEF USE_FLAGS}
+ read GetWordWrap write SetWordWrap
+ {$ELSE}
+ read fWordWrap write fWordWrap
+ {$ENDIF USE_FLAGS};
+ {* TRUE, if this is a label, created using NewWordWrapLabel. }
+ property ShadowDeep: Integer read DF.FShadowDeep write SetShadowDeep;
+ {* |<#3dlabel>
+ Deep of a shadow (for label effect only, created calling NewLabelEffect). }
+
+ property CannotDoubleBuf: Boolean
+ {$IFDEF USE_FLAGS}
+ read GetCannotDoubleBuf write SetCannotDoubleBuf
+ {$ELSE}
+ read fCannotDoubleBuf write fCannotDoubleBuf
+ {$ENDIF};
+ {* }
+ property DoubleBuffered: Boolean
+ read {$IFDEF USE_FLAGS} GetDoubleBuffered
+ {$ELSE} fDoubleBuffered {$ENDIF}
+ write SetDoubleBuffered;
+ {* Set it to true for some controls, which are flickering in repainting
+ (like label effect). Slow, and requires additional code. This property
+ is inherited by all child controls.
+ |<br>
+ Note: RichEdit control can not become DoubleBuffered. }
+ function DblBufTopParent: PControl;
+ {* Returns the topmost DoubleBuffered Parent control. }
+ property Transparent: Boolean
+ read {$IFDEF USE_FLAGS} GetTransparent {$ELSE} fTransparent {$ENDIF}
+ write SetTransparent;
+ {* Set it to true to get special effects. Transparency also uses
+ DoubleBuffered and inherited by child controls.
+ |<br>
+ Please note, that some controls can not be shown properly, when
+ Transparent is set to True for it. If You want to make edit control
+ transparent (e.g., over gradient filled panel), handle its OnChanged
+ property and call there Invalidate to provide repainting of edit
+ control content. Note also, that for RichEdit control property
+ Transparent has no effect (as well as DoubleBuffered). But special
+ property RE_Transparent is designed especially for RichEdit control
+ (it works fine, but with great number of flicks while resizing
+ of a control). Another note is about Edit control. To allow editing
+ of transparent edit box, it is necessary to invalidate it for
+ every pressed character. Or, use Ed_Transparent property instead. }
+ property Ed_Transparent: Boolean
+ read {$IFDEF USE_FLAGS} GetTransparent {$ELSE} fTransparent {$ENDIF}
+ write EdSetTransparent;
+ {* |<#edit>
+ |<#memo>
+ Use this property for editbox to make it really Transparent. Remember,
+ that though Transparent property is inherited by child controls from
+ its parent, this is not so for Ed_Transparent. So, it is necessary to
+ set Ed_Transparent to True for every edit control explicitly. }
+ property AlphaBlend: Byte read fAlphaBlend write SetAlphaBlend;
+ {* |<#form>
+ If assigned to 0..254, makes window (form or control) semi-transparent
+ (Win2K only).
+ |<br>
+ Depending on value assigned, it is possible to adjust transparency
+ level ( 0 - totally transparent, 255 - totally opaque).
+ |<br>Note: from XP, any control can be alpha blended! }
+ function MouseTransparent: PControl;
+ {* Call this method to set up mouse transparent control (which always
+ returns HTTRANSPARENT in responce to WM_NCHITTEST). This function
+ returns a pointer to a control itself. }
+
+ property LookTabKeys: TTabKeys read fLookTabKeys write fLookTabKeys;
+ {* Set of keys which can be used as tabulation keys in a control. }
+ procedure GotoControl( Key: DWORD );
+ {* |<#form>
+ Emulates tabulation key press w/o sending message to current control.
+ Can be applied to a form or to any its control. If VK_TAB is used,
+ state of shift kay is checked in: if it is pressed, tabulate is in
+ backward direction. }
+ property SubClassName: KOLString read get_ClassName write set_ClassName;
+ {* Name of window class - unique for every window class
+ in every run session of a program. }
+
+ public
+ procedure SetOnClose( const AOnClose: TOnEventAccept );
+ procedure SetFormOnClick( const AOnClick: TOnEvent );
+ public
+ property OnClose: TOnEventAccept
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnClose {$ELSE} EV.fOnClose {$ENDIF}
+ write SetOnClose;
+ {* |<#form>
+ |<#applet>
+ Called before closing the window. It is possible to set Accept
+ parameter to False to prevent closing the window. This event events
+ is not called when windows session is finishing (to handle this
+ event, handle WM_QUERYENDSESSION message, or assign OnQueryEndSession
+ event to another or the same event handler). }
+
+ property OnQueryEndSession: TOnEventAccept
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnQueryEndSession {$ELSE} EV.fOnQueryEndSession {$ENDIF}
+ write SetOnQueryEndSession;
+ {* |<#form>
+ |<#applet>
+ Called when WM_QUERYENDSESSION message come in. It is possible to set Accept
+ parameter to False to prevent closing the window (in such case session ending
+ is halted). It is possible to check CloseQueryReason property to find out,
+ why event occur.
+ |<br>
+ To provide normal application close while handling OnQueryEndSession,
+ call in your code PostQuitMessage( 0 ) or call method Close for the main form,
+ this is enough to provide all OnClose and OnDestroy handlers to be called. }
+ property CloseQueryReason: TCloseQueryReason read DF.fCloseQueryReason;
+ {* Reason why OnClose or OnQueryEndSession called. }
+ property OnMinimize: TOnEvent index 0 read
+ {$IFDEF F_P} GetOnMinMaxRestore {$ELSE DELPHI}
+ {$IFDEF EVENTS_DYNAMIC} GetOnMinMaxRestore
+ {$ELSE} EV.fOnMinimize {$ENDIF}
+ {$ENDIF F_P/DELPHI} write SetOnMinMaxRestore;
+ {* |<#form>
+ Called when window is minimized. }
+ property OnMaximize: TOnEvent index 8 read
+ {$IFDEF F_P} GetOnMinMaxRestore {$ELSE DELPHI}
+ {$IFDEF EVENTS_DYNAMIC} GetOnMinMaxRestore
+ {$ELSE} EV.fOnMaximize {$ENDIF}
+ {$ENDIF F_P/DELPHI} write SetOnMinMaxRestore;
+ {* |<#form>
+ Called when window is maximized. }
+ property OnRestore: TOnEvent index 16 read
+ {$IFDEF F_P} GetOnMinMaxRestore {$ELSE DELPHI}
+ {$IFDEF EVENTS_DYNAMIC} GetOnMinMaxRestore
+ {$ELSE} EV.fOnMaximize {$ENDIF}
+ {$ENDIF F_P/DELPHI} write SetOnMinMaxRestore;
+ {* |<#form>
+ Called when window is restored from minimized or maximized state. }
+
+ property UpdateRgn: HRgn read fUpdRgn;
+ {* A handle of update region. Valid only in OnPaint method. You
+ can use it to improve painting (for speed), if necessary. When
+ UpdateRgn is obtained in response to WM_PAINT message, value
+ of the property EraseBackground is used to pass it to the API
+ function GetUpdateRgn. If UpdateRgn = 0, this means that entire
+ window should be repainted. Otherwise, You (e.g.) can check
+ if the rectangle is in clipping region using API function
+ RectInRegion. }
+
+ property EraseBackground: Boolean
+ read {$IFDEF USE_FLAGS} GetEraseBackground {$ELSE} fEraseUpdRgn {$ENDIF}
+ write {$IFDEF USE_FLAGS} SetEraseBackground {$ELSE} fEraseUpdRgn {$ENDIF};
+ {* This value is used to pass it to the API function GetUpdateRgn,
+ when UpadateRgn property is obtained first in responce to WM_PAINT
+ message. If EraseBackground is set to True, system is responsible
+ for erasing background of update region before painting. If not
+ (default), the entire region invalidated should be painted by your
+ event handler. }
+ {$ENDIF GDI}
+ property OnPaint: TOnPaint
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnPaint {$ELSE} EV.fOnPaint {$ENDIF}
+ write SetOnPaint;
+ {* Event to set to override standard control painting. Can be applied
+ to any control (though originally was designed only for paintbox
+ control). When an event handler is called, it is possible to use
+ UpdateRgn to examine what parts of window require painting to
+ improve performance of the painting operation. }
+ {$IFDEF GDI}
+ property OnPrePaint: TOnPaint
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnPrePaint {$ELSE} EV.fOnPrePaint {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnPrePaint {$ELSE} EV.fOnPrePaint {$ENDIF};
+ {* Only for graphic controls. If you assign it, call Invalidate also. }
+ property OnPostPaint: TOnPaint
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnPostPaint {$ELSE} EV.fOnPostPaint {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnPostPaint {$ELSE} EV.fOnPostPaint {$ENDIF};
+ {* Only for graphic controls. If you assign it, call Invalidate also. }
+
+ property OnEraseBkgnd: TOnPaint
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnEraseBkgnd {$ELSE} EV.fOnEraseBkgnd {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnEraseBkgnd {$ELSE} SetOnEraseBkgnd {$ENDIF};
+ {* This event allows to override erasing window background in response
+ to WM_ERASEBKGND message. This allows to add some decorations to
+ standard controls without overriding its painting in total.
+ Note: When erase background, remember, that property ClientRect can
+ return not true client rectangle of the window - use GetClientRect
+ API function instead. For example:
+ !
+ !var BkBmp: HBitmap;
+ !
+ !procedure TForm1.KOLForm1FormCreate(Sender: PObj);
+ !begin
+ ! Toolbar1.OnEraseBkgnd := DecorateToolbar;
+ ! BkBmp := LoadBitmap( hInstance, 'BK1' );
+ !end;
+ !
+ !procedure TForm1.DecorateToolbar(Sender: PControl; DC: HDC);
+ !var CR: TRect;
+ !begin
+ ! GetClientRect( Sender.Handle, CR );
+ ! Sender.Canvas.Brush.BrushBitmap := BkBmp;
+ ! Sender.Canvas.FillRect( CR );
+ !end;
+ !
+ }
+
+ {$ENDIF GDI}
+ property OnClick: TOnEvent
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnClick {$ELSE} EV.fOnClick {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} SetOnClick {$ELSE}
+ {$IFDEF GDI} EV.fOnClick
+ {$ELSE _X_} SetOnClick {$ENDIF _X_}{$ENDIF};
+ {* |<#button>
+ |<#checkbox>
+ |<#radiobox>
+ |<#toolbar>
+ Called on click at control. For buttons, checkboxes and radioboxes
+ is called regadless if control clicked by mouse or keyboard. For toolbar,
+ the same event is used for all toolbar buttons and toolbar itself.
+ To determine which toolbar button is clicked, check CurIndex property.
+ And note, that all the buttons including separator buttons are enumerated
+ starting from 0. Though images are stored (and prepared) only for
+ non-separator buttons. And to determine, if toolbar button was clicked
+ with right mouse button, check RightClick property.
+ |<br>
+ This event does not work on a Form, still it is fired in responce to
+ WM_COMMAND window message mainly rather direct to mouse down. But, if
+ you want to have OnClick event to be fired on a Form, use (following)
+ property OnFormClick to assign it. }
+ {$IFDEF GDI}
+ property OnFormClick: TOnEvent
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnClick {$ELSE} EV.fOnClick {$ENDIF}
+ write SetFormOnClick;
+ {* |<#form>
+ Assign you OnClick event handler using this property, if you want it to
+ be fired in result of mouse click on a form surface. Use to assign the
+ event only for forms (to avoid doublicated firing the handler).
+ |<br>
+ Note: for a form, in case of WM_xDOUBLECLK event, this event is fired
+ for both clicks. So if you install both OnFormClick and OnMouseDblClk,
+ handlers will be called in the following sequence for each double click:
+ OnFormClick; OnMouseDblClk; OnFormClick. }
+ property RightClick: Boolean read {$IFDEF USE_FLAGS} Get_RightClick {$ELSE} fRightClick {$ENDIF};
+ {* |<#toolbar>
+ |<#listview>
+ Use this property to determine which mouse button was clicked
+ (applicable to toolbar in the OnClick event handler). }
+ property OnEnter: TOnEvent index idx_fOnEnter
+ read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnEnter {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnEnter {$ENDIF};
+ {* Called when control receives focus. }
+ property OnLeave: TOnEvent index idx_fOnLeave
+ read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnLeave {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnLeave{$ENDIF};
+ {* Called when control looses focus. }
+ property OnChange: TOnEvent index idx_fOnChangeCtl
+ read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnChangeCtl {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnChangeCtl {$ENDIF};
+ {* |<#edit>
+ |<#memo>
+ |<#listbox>
+ |<#combo>
+ |<#tabcontrol>
+ Called when edit control is changed, or selection in listbox or
+ current index in combobox is changed (but if OnSelChanged assigned,
+ the last is called for change selection). To respond to check/uncheck
+ checkbox or radiobox events, use OnClick instead. }
+ property OnSelChange: TOnEvent index idx_fOnSelChange
+ read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnSelChange {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnSelChange{$ENDIF};
+ {* |<#richedit>
+ |<#listbox>
+ |<#combo>
+ |<#treeview>
+ Called for rich edit control, listbox, combobox or treeview when current selection
+ (range, or current item) is changed. If not assigned, but OnChange is
+ assigned, OnChange is called instead. }
+ property OnResize: TOnEvent
+ read {$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). }
+ 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). }
+
+ property MinSizePrev: Integer read DF.fSplitMinSize1 write DF.fSplitMinSize1;
+ {* |<#splitter>
+ Minimal allowed (while dragging splitter) size of previous control
+ for splitter (see NewSplitter). }
+ property SplitMinSize1: Integer read DF.fSplitMinSize1 write DF.fSplitMinSize1;
+ {* The same as MinSizePrev }
+ property MinSizeNext: Integer read DF.fSplitMinSize2 write DF.fSplitMinSize2;
+ {* |<#splitter>
+ Minimal allowed (while dragging splitter) size of the rest of parent
+ of splitter or of SecondControl (see NewSplitter). }
+ property SplitMinSize2: Integer read DF.fSplitMinSize2 write DF.fSplitMinSize2;
+ {* The same as MinSizeNext. }
+ property SecondControl: PControl read DF.fSecondControl write DF.fSecondControl;
+ {* |<#splitter>
+ Second control to check (while dragging splitter) if its size not less
+ than SplitMinSize2 (see NewSplitter). By default, second control is
+ not necessary, and needed only in rare case when SecondControl can not
+ be determined automatically to restrict splitter right (bottom) position. }
+ property OnSplit: TOnSplit
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnSplit {$ELSE} EV.fOnSplit {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnSplit {$ELSE} EV.fOnSplit{$ENDIF};
+ {* |<#splitter>
+ Called when splitter control is dragging - to allow for
+ your event handler to decide if to accept new size of
+ left (top) control, and new size of the rest area of parent. }
+ property Dragging: Boolean read {$IFDEF USE_FLAGS} Get_Dragging {$ELSE} FDragging{$ENDIF};
+ {* |<#splitter>
+ True, if splitter control is dragging now by user with left
+ mouse button. Also, this property can be used to detect if the control
+ is dragging with mouse (after calling DragStartEx method). }
+ procedure DragStart;
+ {* Call this method for a form or control to drag it with left mouse button,
+ when mouse left button is already down. Dragging is stopped when left mouse
+ button is released. See also DragStartEx, DragStopEx. }
+ procedure DragStartEx;
+ {* Call this method to start dragging the form by mouse. To stop
+ dragging, call DragStopEx method. (Tip: to detect mouse up event,
+ use OnMouseUp event of the dragging control). This method can be used
+ to move any control with the mouse, not only entire form. State of
+ mouse button is not significant. Determine dragging state of the control
+ checking its Dragging property. }
+ procedure DragStopEx;
+ {* Call this method to stop dragging the form (started by DragStopEx). }
+ procedure DragItem( OnDrag: TOnDrag );
+ {* Starts dragging something with mouse. During the process,
+ callback function OnDrag is called, which allows to control
+ drop target, change cursor shape, etc. }
+
+ property OnKeyDown: TOnKey
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnKeyDown {$ELSE} EV.fOnKeyDown {$ENDIF}
+ write SetOnKeyDown;
+ {* Obvious. }
+ property OnKeyUp: TOnKey
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnKeyUp {$ELSE} EV.fOnKeyUp {$ENDIF}
+ write SetOnKeyUp;
+ {* Obvious. }
+ property OnChar: TOnChar
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnChar {$ELSE} EV.fOnChar {$ENDIF}
+ write SetOnChar;
+ {* Deprecated event, use OnKeyChar. }
+ property OnKeyChar: TOnChar
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnChar {$ELSE} EV.fOnChar {$ENDIF}
+ write SetOnChar;
+ {* Obviuos. }
+ {$IFDEF SUPPORT_ONDEADCHAR}
+ property OnKeyDeadChar: TOnChar
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnDeadChar {$ELSE} EV.fOnDeadChar {$ENDIF}
+ write SetOnDeadChar;
+ {* Obviuos. }
+ {$ENDIF SUPPORT_ONDEADCHAR}
+
+ {$ENDIF GDI}
+ property OnMouseUp: TOnMouse index idx_fOnMouseUp
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseUp {$ENDIF}
+ write SetOnMouseEvent;
+ {* Obvious. }
+ property OnMouseDown: TOnMouse index idx_fOnMouseDown
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseDown {$ENDIF}
+ write SetOnMouseEvent;
+ {* Obvious. }
+ property OnMouseMove: TOnMouse index idx_fOnMouseMove
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseMove {$ENDIF}
+ write SetOnMouseEvent;
+ {* Obvious. }
+ property OnMouseDblClk: TOnMouse index idx_fOnMouseDblClk
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseDblClk {$ENDIF}
+ write SetOnMouseEvent;
+ {* Obvious. }
+ property ThreeButtonPress: Boolean
+ read {$IFDEF USE_FLAGS} Get3ButtonPress {$ELSE} f3ButtonPress {$ENDIF};
+ {* GDK (*nix) only. TRUE, if 3 button press detected. Check this flag in
+ OnMouseDblClk event handler. If 3rd button click is done for a short
+ period of time after the double click, the control receives OnMouseDblClk
+ the second time and this flag is set. (Applicable to the GDK and other
+ Linux systems). }
+ property OnMouseWheel: TOnMouse index idx_fOnMouseWheel
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseWheel {$ENDIF}
+ write SetOnMouseEvent;
+ {* Mouse wheel (up or down) event. In Windows, only focused controls and
+ controls having scrollbars (or a scrollbar iteself) receive such
+ message. To get direction and amount of wheel, use typecast:
+ SmallInt( HiWord( Mouse.Shift ) ). Value 120 corresponds to one wheel
+ step (-120 - for step back). }
+ {$IFDEF GDI}
+
+ property OnMouseEnter: TOnEvent
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEnter {$ELSE} EV.fOnMouseEnter {$ENDIF}
+ write SetOnMouseEnter;
+ {* Is called when mouse is entered into control. See also OnMouseLeave. }
+ property OnMouseLeave: TOnEvent
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseLeave {$ELSE} EV.fOnMouseLeave {$ENDIF}
+ write SetOnMouseLeave;
+ {* Is called when mouse is leaved control. If this event is assigned,
+ then mouse is captured on mouse enter event to handle all other
+ mouse events until mouse cursor leaves the control. }
+ property OnTestMouseOver: TOnTestMouseOver
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnTestMouseOver {$ELSE} EV.fOnTestMouseOver {$ENDIF}
+ write SetOnTestMouseOver;
+ {* |<#bitbtn>
+ Special event, which allows to extend OnMouseEnter / OnMouseLeave
+ (and also Flat property for BitBtn control). If a handler is assigned
+ to this event, actual testing whether mouse is in control or not,
+ is occuring in the handler. So, it is possible to simulate more
+ careful hot tracking for controls with non-rectangular shape (such
+ as glyphed BitBtn control). }
+
+ property MouseInControl: Boolean
+ read {$IFDEF USE_FLAGS} GetMouseInCtl {$ELSE} fMouseInControl {$ENDIF};
+ {* |<#bitbtn>
+ This property can return True only if OnMouseEnter / OnMouseLeave
+ event handlers are set for a control (or, for BitBtn, property Flat
+ is set to True. Otherwise, False is returned always. }
+
+ property Flat: Boolean read {$IFDEF USE_FLAGS} GetFlat {$ELSE} fFlat {$ENDIF}
+ write SetFlat;
+ {* |<#bitbtn>
+ Set it to True for BitBtn, to provide either flat border for a button
+ or availability of "highlighting" (correspondent to glyph index 4).
+ |<br>
+ Note: this can work incorrectly a bit under win95 without comctl32.dll
+ updated. Therefore, application will launch. To enforce correct working
+ even under Win95, use your own timer, which event handler checks for
+ mouse over bitbtn control, e.g.:
+ ! procedure TForm1.Timer1Timer(Sender: PObj);
+ ! var P: TPoint;
+ ! begin
+ ! if not BitBtn1.MouseInControl then Exit;
+ ! GetCursorPos( P );
+ ! P := BitBtn1.Screen2Client( P );
+ ! if not PtInRect( BitBtn1.ClientRect, P ) then
+ ! begin
+ ! BitBtn1.Flat := FALSE;
+ ! BitBtn1.Flat := TRUE;
+ ! end;
+ ! end;
+ }
+ property RepeatInterval: Integer read DF.fRepeatInterval write DF.fRepeatInterval;
+ {* |<#bitbtn>
+ If this property is set to non-zero, it is interpreted (for BitBtn
+ only) as an interval in milliseconds between repeat button down events,
+ which are generated after first mouse or button click and until
+ button is released. Though, if the button is pressed with keyboard (with
+ space key), RepeatInterval value is ignored and frequency of repeatitive
+ clicking is determined by user keyboard settings only. }
+ function LikeSpeedButton: PControl;
+ {* |<#button>
+ |<#bitbtn>
+ Transparent method (returns control itself). Makes button not focusable. }
+
+ function Add( const S: KOLString ): Integer;
+ {* |<#listbox>
+ |<#combo>
+ Only for listbox and combobox. }
+
+ function Insert( Idx: Integer; const S: KOLString ): Integer;
+ {* |<#listbox>
+ |<#combo>
+ Only for listbox and combobox. }
+ procedure Delete( Idx: Integer );
+ {* |<#listbox>
+ |<#combo>
+ |<#listview>
+ |<#treeview>
+ Only listed controls. }
+ procedure Clear;
+ {* Clears object content. Has different sense for different controls.
+ E.g., for label, editbox, button and other simple controls it
+ assigns empty string to Caption property. For listbox, combobox,
+ listview it deletes all items. For toolbar, it deletes all buttons.
+ Et so on. }
+
+ property Progress: Integer index ((PBM_SETPOS or $8000) shl 16) or PBM_GETPOS
+ read GetIntVal write SetIntVal;
+ {* |<#progressbar>
+ Only for ProgressBar. }
+ property MaxProgress: Integer index ((PBM_SETRANGE32 or $8000) shl 16) or PBM_GETRANGE
+ read GetIntVal write SetMaxProgress;
+ {* |<#progressbar>
+ Only for ProgressBar. 100 is the default value. }
+ property ProgressColor: TColor read fTextColor write SetProgressColor;
+ {* |<#progressbar>
+ Only for ProgressBar. }
+ property ProgressBkColor: TColor read fColor write SetCtlColor; //SetProgressBkColor;
+ {* |<#progressbar>
+ Obsolete. Now the same as Color. }
+
+ property StatusText[ Idx: Integer ]: KOLString read GetStatusText write SetStatusText;
+ {* |<#form>
+ Only for forms to set/retrieve status text to/from given status panel.
+ Panels are enumerated from 0 to 254, 255 is to indicate simple
+ status bar. Size grip in right bottom corner of status window is
+ displayed only if form still CanResize.
+ |<br>
+ When a status text is set first time, status bar window is created
+ (always aligned to bottom), and form is resizing to preset client height.
+ While status bar is showing, client height value is returned without
+ height of status bar. To remove status bar, call RemoveStatus method for
+ a form.
+ |<br>
+ By default, text is left-aligned within the specified part of a status
+ window. You can embed tab characters (#9) in the text to center or
+ right-align it. Text to the right of a single tab character is centered,
+ and text to the right of a second tab character is right-aligned.
+ |<br>
+ If You use separate status bar onto several panels, these automatically
+ align its widths to the same value (width divided to number of panels).
+ To adjust status panel widths for every panel, use property StatusPanelRightX.
+ }
+ property SimpleStatusText: KOLString index 255 read GetStatusText write SetStatusText;
+ {* |<#form>
+ Only for forms to set/retrive status text to/from simple status bar.
+ Size grip in right bottom corner of status window is displayed only
+ if form CanResize.
+ |<br>
+ When status text set first time, (simple) status bar window is created
+ (always aligned to bottom), and form is resizing to preset client height.
+ While status bar is showing, client height value is returned without
+ height of status bar. To remove status bar, call RemoveStatus method for
+ a form.
+ |<br>
+ By default, text is left-aligned within the specified part of a status
+ window. You can embed tab characters (#9) in the text to center or
+ right-align it. Text to the right of a single tab character is centered,
+ and text to the right of a second tab character is right-aligned.
+ }
+ property StatusCtl: PControl read fStatusCtl;
+ {* Pointer to Status bar control. To "create" child controls on
+ the status bar, first create it as a child of form, for instance, and
+ then change its property Parent, e.g.:
+ ! var Progress1: PControl;
+ ! ...
+ ! Progress1 := NewProgressBar( Form1 );
+ ! Progress1.Parent := Form1.StatusCtl;
+ (If you use MCK, code should be another a bit, and in this case it is
+ possible to create and adjust the control at design-time, and at run-time
+ change its parent control. E.g. (Progress1 is created at run-time here too):
+ ! Progress1 := NewProgressBar( Form );
+ ! Progress1.Parent := Form.StatusCtl;
+ ).
+ Do not forget to provide StatusCtl to be existing first (e.g. assign
+ one-space string to SimpleStatusText property of the form, for MCK do
+ so using Object Inspector).
+
+ Please note that not only a form can have status bar
+ but any other control too!
+ }
+ property SizeGrip: Boolean
+ read {$IFDEF USE_FLAGS} GetSizeGrip {$ELSE} fSizeGrip {$ENDIF}
+ write {$IFDEF USE_FLAGS} SetSizeGrip {$ELSE} fSizeGrip {$ENDIF};
+ {* Size grip for status bar. Has effect only before creating window. }
+
+ procedure RemoveStatus;
+ {* |<#form>
+ Call it to remove status bar from a form (created in result of assigning
+ value(s) to StatusText[], SimpleStatusText properties). When status bar is
+ removed, form is resized to preset client height. }
+ function StatusPanelCount: Integer;
+ {* |<#form>
+ Returns number of status panels defined in status bar. }
+ property StatusPanelRightX[ Idx: Integer ]: Integer read GetStatusPanelX write SetStatusPanelX;
+ {* |<#form>
+ Use this property to adjust status panel right edges (if the status bar is
+ divided onto several subpanels). If the right edge for the last panel is
+ set to -1 (by default) it is expanded to the right edge of a form window.
+ Otherwise, status bar can be shorter then form width. }
+ property StatusWindow: HWND read Get_StatusWnd;
+ {* |<#form>
+ Provided for case if You want to use API direct message sending to
+ status bar. }
+
+ property Color1: TColor read DF.fColor1 write SetColor1;
+ {* |<#gradient>
+ Top line color for GradientPanel. }
+ property Color2: TColor read DF.fColor2 write SetColor2;
+ {* |<#gradient>
+ |<#3Dlabel>
+ Bottom line color for GradientPanel, or shadow color for LabelEffect.
+ (If clNone, shadow color for LabelEffect is calculated as a mix bitween
+ TextColor and clBlack). }
+ property GradientStyle: TGradientStyle read DF.fGradientStyle write SetGradientStyle;
+ {* |<#gradient>
+ Styles other then gsVertical and gsHorizontal has effect only for
+ gradient panel, created by NewGradientPanelEx. }
+ property GradientLayout: TGradientLayout read DF.fGradientLayout write SetGradientLayout;
+ {* |<#gradient>
+ Has only effect for gradient panel, created by NewGradientPanelEx.
+ Ignored for styles gsVertical and gsHorizontal. }
+
+ //======== Image lists (for ListView, TreeView, ToolBar and TabControl):
+ property ImageListSmall: PImageList index 16 read GetImgListIdx write SetImgListIdx;
+ {* |<#listview>
+ Image list with small icons used with List View control. If not set,
+ last added (i.e. created with a control as an owner) image list with
+ small icons is used. }
+ property ImageListNormal: PImageList index 32 read GetImgListIdx write SetImgListIdx;
+ {* |<#listview>
+ |<#treeview>
+ |<#tabcontrol>
+ |<#bitbtn>
+ Image list with normal size icons used with List View control (or with
+ icons for BitBtn, TreeView or TabControl). If not set,
+ last added (i.e. created with a control as an owner) image list is used.
+ }
+ property ImageListState: PImageList index 0 read GetImgListIdx write SetImgListIdx;
+ {* |<#listview>
+ |<#treeview>
+ Image list used as a state images list for ListView or TreeView control. }
+
+ //========
+ function SetUnicode( Unicode: Boolean ): PControl;
+ {* |<#listview>
+ |<#treeview>
+ |<#tabcontrol>
+ Sets control as Unicode or not. The control itself is returned as for
+ other "transparent" functions. A conditional define UNICODE_CTRLS must
+ be added to a project to provide handling unicode messages. }
+
+ //======== TabControl-specific properties and methods:
+ property Pages[ Idx: Integer ]: PControl read GetPages;
+ {* |<#tabcontrol>
+ Returns controls, which can be used as parent for controls, placed on
+ different pages of a tab control. Use it like in follows example:
+ | Label1 := NewLabel( TabControl1.Pages[ 0 ], 'Label1' );
+ To find number of pages available, check out Count property of the tab
+ control. Pages are enumerated from 0 to Count - 1, as usual. }
+ property TC_Pages[ Idx: Integer ]: PControl read GetPages;
+ {* |<#tabcontrol>
+ The same as above. }
+ function TC_Insert( Idx: Integer; const TabText: KOLString; TabImgIdx: Integer ): PControl;
+ {* |<#tabcontrol>
+ Inserts new tab before given, returns correspondent page control
+ (which can be used as a parent for controls to place on the page). }
+ procedure TC_Delete( Idx: Integer );
+ {* |<#tabcontrol>
+ Removes tab from tab control, destroying all its child controls. }
+{$IFNDEF OLD_ALIGN}
+ procedure TC_InsertControl( Idx: Integer; const TabText: KOLString; TabImgIdx: Integer; Page: PControl);
+ {* |<#tabcontrol>
+ Inserts new tab before given, but not construt this Page
+ (this control must be created before inserting, and may be not a Panel). }
+ function TC_Remove( Idx: Integer ):PControl;
+ {* |<#tabcontrol>
+ Only removes tab from tab control, and return this Page as Result. }
+{$ENDIF}
+ property TC_Items[ Idx: Integer ]: KOLString read TCGetItemText write TCSetItemText;
+ {* |<#tabcontrol>
+ Text, displayed on tab control tabs. }
+ property TC_Images[ Idx: Integer ]: Integer read TCGetItemImgIDx write TCSetItemImgIdx;
+ {* |<#tabcontrol>
+ Image index for a tab in tab control. }
+ property TC_ItemRect[ Idx: Integer ]: TRect read TCGetItemRect;
+ {* |<#tabcontrol>
+ Item rectangle for a tab in tab control. }
+ procedure TC_SetPadding( cx, cy: Integer );
+ {* |<#tabcontrol>
+ Sets space padding around tab text in a tab of tab control. }
+ function TC_TabAtPos( x, y: Integer ): Integer;
+ {* |<#tabcontrol>
+ Returns index of tab, found at the given position (relative to
+ a client rectangle of tab control). If no tabs found at the
+ position, -1 is returned. }
+ function TC_DisplayRect: TRect;
+ {* |<#tabcontrol>
+ Returns rectangle, occupied by a page rather then tab. }
+ function TC_IndexOf(const S: KOLString): Integer;
+ {* |<#tabcontrol>
+ By Mr Brdo. Index of page by its Caption. }
+ function TC_SearchFor(const S: KOLString; StartAfter: Integer; Partial: Boolean): Integer;
+ {* |<#tabcontrol>
+ By Mr Brdo. Index of page by its Caption. }
+
+ //======== ListView style and options:
+ property LVStyle: TListViewStyle read DF.fLVStyle write SetLVStyle;
+ {* |<#listview>
+ ListView style of view. Can be changed at run time. }
+
+ property LVOptions: TListViewOptions read DF.fLVOptions write SetLVOptions;
+ {* |<#listview>
+ ListView options. Can be changed at run time. }
+
+ property LVTextColor: TColor index LVM_GETTEXTCOLOR
+ {$IFDEF F_P} read LVGetColorByIdx
+ {$ELSE DELPHI} read fTextColor
+ {$ENDIF F_P/DELPHI} write LVSetColorByIdx;
+ {* |<#listview>
+ ListView text color. Use it instead of Font.Color. }
+ property LVTextBkColor: TColor index LVM_GETTEXTBKCOLOR
+ {$IFDEF F_P} read LVGetColorByIdx
+ {$ELSE DELPHI} read DF.fLVTextBkColor
+ {$ENDIF F_P/DELPHI} write LVSetColorByIdx;
+ {* |<#listview>
+ ListView background color for text. }
+ property LVBkColor: TColor read fColor write SetCtlColor; //LVSetBkColor;
+ {* |<#listview>
+ ListView background color. Use it instead of Color. }
+
+ //======== List View columns handling:
+ property LVColCount: Integer read DF.fLVColCount;
+ {* |<#listview>
+ ListView (additional) column count. Value 0 means that there are
+ no columns (single item text / icon is used). If You want
+ to provide several columns, first call LVColAdd to "insert" column 0,
+ i.e. to provide header text for first column (with index 0).
+ If there are no column, nothing will be shown in lvsDetail /
+ lvsDetailNoHeader view style. }
+ procedure LVColAdd( const aText: KOLString; aalign: TTextAlign; aWidth: Integer );
+ {* |<#listview>
+ Adds new column. Pass 'width' <= 0 to provide default column width.
+ 'text' is a column header text. }
+ procedure LVColInsert( ColIdx: Integer; const aText: KOLString; aAlign: TTextAlign; aWidth: Integer );
+ {* |<#listview>
+ Inserts new column at the Idx position (1-based column index). }
+ procedure LVColDelete( ColIdx: Integer );
+ {* |<#listview>
+ Deletes column from List View }
+ property LVColWidth[ Item: Integer ]: Integer index LVM_GETCOLUMNWIDTH
+ read GetItemVal write SetItemVal;
+ {* |<#listview>
+ Retrieves or changes column width. For lvsList view style, the same width
+ is returned for all columns (ColIdx is ignored). It is possible to use
+ special values to assign to a property:
+ |<br> LVSCW_AUTOSIZE - Automatically sizes the column
+ |<br> LVSCW_AUTOSIZE_USEHEADER - Automatically sizes the column to fit
+ the header text
+ |<br>
+ To set coumn width in lvsList view mode, column index must be -1
+ (and Width to set must be in range 0..32767 always). }
+ property LVColText[ Idx: Integer ]: KOLString read GetLVColText write SetLVColText;
+ {* |<#listview>
+ Allows to get/change column header text at run time. }
+ property LVColAlign[ Idx: Integer ]: TTextAlign read GetLVColalign write SetLVColalign;
+ {* |<#listview>
+ Column text aligning. }
+ property LVColImage[ Idx: Integer ]: Integer index LVCF_IMAGE or (24 shl 16) read GetLVColEx write SetLVColEx;
+ {* |<#listview>
+ Only starting from comctrl32.dll of version 4.70 (IE4+). Allows to
+ set an image for list view column itself from the ImageListSmall.
+ }
+ property LVColOrder[ Idx: Integer ]: Integer index LVCF_ORDER or (28 shl 16) read GetLVColEx write SetLVColEx;
+ {* |<#listview>
+ Only starting from comctrl32.dll of version 4.70 (IE4+). Allows to
+ set visual order of the list view column from the ImageListSmall.
+ This value does not affect the index, by which the column is still
+ accessible in the column array.
+ }
+
+ //======== List View items handling:
+ property LVCount: Integer read GetItemsCount write SetItemsCount;
+ {* |<#listview>
+ Returns item count for ListView control. It is possible to use Count
+ property instead when obtaining of item count is needed only. But this this
+ property allows also to set actual count of list view items when a list
+ view is virtual. }
+
+ property LVCurItem: Integer read GetLVCurItem write SetLVCurItem;
+ {* |<#listview>
+ Returns first selected item index in a list view. See also LVNextSelected,
+ LVNextItem and LVFocusItem functions. }
+
+ property LVFocusItem: Integer read GetLVFocusItem;
+ {* |<#listview>
+ Returns focused item index in a list view. See also LVCurItem. }
+
+ function LVNextItem( IdxPrev: Integer; Attrs: DWORD ): Integer;
+ {* |<#listview>
+ Returns an index of the next after IdxPrev item with given attributes in
+ the list view. Attributes can be:
+ LVNI_ALL - Searches for a subsequent item by index, the default value.
+ |<br><br>
+ Searchs by physical relationship to the index of the item where the
+ search is to begin.
+ LVNI_ABOVE - Searches for an item that is above the specified item.
+ LVNI_BELOW - Searches for an item that is below the specified item.
+ LVNI_TOLEFT - Searches for an item to the left of the specified item.
+ LVNI_TORIGHT - Searches for an item to the right of the specified item.
+ |<br><br>
+ The state of the item to find can be specified with one or a combination
+ of the following values:
+ LVNI_CUT - The item has the LVIS_CUT state flag set.
+ LVNI_DROPHILITED - The item has the LVIS_DROPHILITED state flag set
+ LVNI_FOCUSED - The item has the LVIS_FOCUSED state flag set.
+ LVNI_SELECTED - The item has the LVIS_SELECTED state flag set.}
+ function LVNextSelected( IdxPrev: Integer ): Integer;
+ {* |<#listview>
+ Returns an index of next (after IdxPrev) selected item in a list view. }
+
+ function LVAdd( const aText: KOLString; ImgIdx: Integer; State: TListViewItemState;
+ StateImgIdx, OverlayImgIdx: Integer; Data: DWORD ): Integer;
+ {* |<#listview>
+ Adds new line to the end of ListView control. Only content of item itself
+ is set (aText, ImgIdx). To change other column text and attributes of
+ item added, use appropriate properties / methods ().
+ |<br>
+ Returns an index of added item.
+ |<br>
+ There is no Unicode version defined, use LVItemAddW instead. }
+ function LVItemAdd( const aText: KOLString ): Integer;
+ {* |<#listview>
+ Adds an item to the end of list view. Returns an index of the item added. }
+ function LVInsert( Idx: Integer; const aText: KOLString; ImgIdx: Integer;
+ State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer; Data: DWORD ): Integer;
+ {* |<#listview>
+ Inserts new line before line with index Idx in ListView control. Only
+ content of item itself is set (aText, ImgIdx). To change other column
+ text and attributes of item added, use appropriate properties / methods ().
+ if ImgIdx = I_IMAGECALLBACK, event handler OnGetLVItemImgIdx is responsible
+ for returning image index for an item ( /// not implemented yet /// )
+ Pass StateImgIdx and OverlayImgIdx = 0 (ignored in that case) or 1..15 to
+ use correspondent icon from ImageListState image list.
+ |<br> Returns an index of item inserted.
+ |<br> There is no unicode version of this method, use LVItemInsertW. }
+ function LVItemInsert( Idx: Integer; const aText: KOLString ): Integer;
+ {* |<#listview>
+ Inserts an item to Idx position. }
+
+ procedure LVDelete( Idx: Integer );
+ {* |<#listview>
+ Deletes item of ListView with subitems (full row - in lvsDetail view style. }
+ procedure LVSetItem( Idx, Col: Integer; const aText: KOLString; ImgIdx: Integer;
+ State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer; Data: DWORD );
+ {* |<#listview>
+ Use this method to set item data and item columns data for ListView control.
+ It is possible to pass I_SKIP as ImgIdx, StateImgIdx, OverlayImgIdx values to
+ skip setting this fields. But all other are set always. Like in LVInsert /
+ LVAdd, ImgIdx can be I_IMAGECALLBACK to determine that image will be
+ retrieved in OnGetItemImgIdx event handler when needed.
+ |<br>
+ If this method is called to set data for column > 0, parameters ImgIdx and
+ Data are ignored anyway.
+ |<br> There is no unicode version of this method, use other methods
+ to set up listed properties separately using correspondent W-functions. }
+
+ property LVItemState[ Idx: Integer ]: TListViewItemState read LVGetItemState write LVSetItemState;
+ {* |<#listview>
+ Access to list view item states set [lvisBlend, lvisHighlight, lvisFocus,
+ lvisSelect]. When assign new value to the property, it is possible to use
+ special index value -1 to change state for all items for a list view
+ (but only when lvoMultiselect style is applied to the list view, otherwise
+ index -1 is referring to the last item of the list view). }
+
+ property LVItemIndent[ Idx: Integer ]: Integer read LVGetItemIndent write LVSetItemIndent;
+ {* Item indentation. Indentation is calculated as this value multiplied to
+ image list ImgWidth value (Image list must be applied to list view).
+ Note: indentation supported only if IE3.0 or higher installed. }
+ property LVItemStateImgIdx[ Idx: Integer ]: Integer read LVGetSttImgIdx write LVSetSttImgIdx;
+ {* |<#listview>
+ Access to state image of the item. Use index -1 to assign the same state
+ image index to all items of the list view at once (fast).
+ Option lvoCheckBoxes just means, that control itself creates special inner
+ image list for two state images. Later it is possible to examine checked
+ state for items or set checked state programmatically by changing
+ LVItemStateImgIdx[ ] property. Value 1 corresponds to unchecked state,
+ 2 to checked. Value 0 allows to remove checkbox at all. So, to check all
+ added items by default (e.g.), do following:
+ ! ListView1.LVItemStateImgIdx[ -1 ] := 2;
+ |<br>Use 1-based index of the image
+ in image list ImageListState. Value 0 reserved to use as "no state image".
+ Values 1..15 can be used only - this is the Windows restriction on
+ state images. }
+ property LVItemOverlayImgIdx[ Idx: Integer ]: Integer read LVGetOvlImgIdx write LVSetOvlImgIdx;
+ {* |<#listview>
+ Access to overlay image of the item. Use index -1 to assign the same
+ overlay image to all items of the list view at once (fast). }
+ property LVItemData[ Idx: Integer ]: DWORD read LVGetItemData write LVSetItemData;
+ {* |<#listview>
+ Access to user defined data, assiciated with the item of the list view. }
+ procedure LVSelectAll;
+ {* |<#listview>
+ Call this method to select all the items of the list view control. }
+ property LVSelCount: Integer read GetSelLength; // write SetSelLength;
+ {* |<#listview>
+ Returns number of items selected in listview. }
+ property LVItemImageIndex[ Idx: Integer ]: Integer read LVGetItemImgIdx write LVSetItemImgIdx;
+ {* |<#listview>
+ Image index of items in listview. When an item is created (using LVItemAdd
+ or LVItemInsert), image index 0 is set by default (not -1 like in VCL!). }
+ property LVItems[ Idx, Col: Integer ]: KOLString read LVGetItemText write LVSetItemText;
+ {* |<#listview>
+ Access to List View item text. }
+ function LVItemRect( Idx: Integer; Part: TGetLVItemPart ): TRect;
+ {* |<#listview>
+ Returns rectangle occupied by given item part(s) in ListView window.
+ Empty rectangle is returned, if the item is not viewing currently. }
+ function LVSubItemRect( Idx, ColIdx: Integer ): TRect;
+ {* |<#listview>
+ Returns rectangle occupied by given item's subitem in ListView window,
+ in lvsDetail or lvsDetailNoHeader style. Empty rectangle (0,0,0,0) is
+ returned if the item is not viewing currently. Left or/and right bounds
+ of the rectangle returned can be outbound item rectangle if only a part
+ of the subitem is visible or the subitem is not visible in the item,
+ which is visible itself. }
+ property LVItemPos[ Idx: Integer ]: TPoint read LVGetItemPos write LVSetItemPos;
+ {* |<#listview>
+ Position of List View item (can be changed in icon or small icon view). }
+ function LVItemAtPos( X, Y: Integer ): Integer;
+ {* |<#listview>
+ Return index of item at the given position. }
+ function LVItemAtPosEx( X, Y: Integer; var Where: TWherePosLVItem ): Integer;
+ {* |<#listview>
+ Retrieves index of item and sets in Where, what part of item is under
+ given coordinates. If there are no items at the specified position,
+ -1 is returned. }
+ procedure LVMakeVisible( Item: Integer; PartiallyOK: Boolean );
+ {* |<#listview>
+ Makes listview item visible. Ignred when Item passed < 0. }
+ procedure LVEditItemLabel( Idx: Integer );
+ {* |<#listview>
+ Begins in-place editing of item label (first column text). }
+ procedure LVSort;
+ {* |<#listview>
+ Initiates sorting of list view items. This sorting procedure is available only
+ for Win2K, WinNT4 with IE5, Win98 or Win95 with IE5. See also LVSortData. }
+ procedure LVSortData;
+ {* |<#listview>
+ Initiates sorting of list view items. This sorting procedure is always available
+ in Windows95/98, NT/2000. But OnCompareLVItems procedure receives not indexes of
+ items compared but its Data field associated instead. }
+ procedure LVSortColumn( Idx: Integer );
+ {* |<#listview>
+ This is a method to simplify sort by column. Just call it in your OnColumnClick
+ event passing column index and enjoy with your list view sorted automatically
+ when column header is clicked. Requieres Windows2000 or Winows98, not supported
+ under WinNT 4.0 and below and under Windows95.
+ |<br>
+ Either lvoSortAscending or lvoSortDescending option must be set in
+ LVOptions, otherwise no sorting is performed. }
+ function LVIndexOf( const S: KOLString ): Integer;
+ {* Returns first list view item index with caption matching S.
+ The same as LVSearchFor( S, -1, FALSE ). }
+ function LVSearchFor( const S: KOLString; StartAfter: Integer; Partial: Boolean ): Integer;
+ {* Searches an item with Caption equal to S (or starting from S, if Partial = TRUE).
+ Searching is started after an item specified by StartAfter parameter. }
+
+ //======== List view page:
+ property LVTopItem: Integer index LVM_GETTOPINDEX read GetIntVal; //LVGetTopItem;
+ {* |<#listview>
+ Returns index of topmost visible item of ListView in lvsList view style. }
+ property LVPerPage: Integer index LVM_GETCOUNTPERPAGE read GetIntVal; //LVGetPerPage;
+ {* |<#listview>
+ Returns the number of fully-visible items if successful. If the current
+ view is icon or small icon view, the return value is the total number
+ of items in the list view control. }
+
+ //======== List View specific events:
+ property OnEndEditLVItem: TOnEditLVItem
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnEndEditLVItem {$ELSE} EV.fOnEndEditLVItem {$ENDIF}
+ write SetOnEndEditLVItem;
+ {* |<#listview>
+ Called when edit of an item label in ListView control finished. Return
+ True to accept new label text, or false - to not accept it (item label
+ will not be changed). If handler not set to an event, all changes are
+ accepted. }
+
+ property OnLVDelete: TOnDeleteLVItem
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnDeleteLVItem {$ELSE} EV.fOnDeleteLVItem {$ENDIF}
+ write SetOnDeleteLVItem;
+ {* |<#listview>
+ This event is called when an item is deleted in the listview.
+ Do not add, delete, or rearrange items in the list view while processing
+ this notification. }
+ property OnDeleteLVItem: TOnDeleteLVItem
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnDeleteLVItem {$ELSE} EV.fOnDeleteLVItem {$ENDIF}
+ write SetOnDeleteLVItem;
+ {* |<#listview>
+ Called for every deleted list view item. }
+ property OnDeleteAllLVItems: TOnEvent read DF.fOnDeleteAllLVItems write SetOnDeleteAllLVItems;
+ {* |<#listview>
+ Called when all the items of the list view control are to be deleted. If after
+ returning from this event handler event OnDeleteLVItem is yet assigned,
+ an event OnDeleteLVItem will be called for every deleted item. }
+ property OnLVData: TOnLVData
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnLVData {$ELSE} EV.fOnLVData {$ENDIF}
+ write SetOnLVData;
+ {* |<#listview>
+ Called to provide virtual list view with actual data. To use list view as
+ virtaul list view, define also lvsOwnerData style and set Count property
+ to actual row count of the list view. This manner of working with list view
+ control can greatly improve performance of an application when working with
+ huge data sets represented in listview control. }
+
+ property OnCompareLVItems: TOnCompareLVItems
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnCompareLVItems {$ELSE} EV.fOnCompareLVItems {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnCompareLVItems {$ELSE} EV.fOnCompareLVItems {$ENDIF};
+ {* |<#listview>
+ Event to compare two list view items during sort operation (initiated by
+ LVSort method call). Do not send any messages to the list view control
+ while it is sorting - results can be unpredictable! }
+ property OnColumnClick: TOnLVColumnClick
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnColumnClick {$ELSE} EV.fOnColumnClick {$ENDIF}
+ write SetOnColumnClick;
+ {* |<#listview>
+ This event handler is called when column of the list view control is clicked.
+ You can use this event to initiate sorting of list view items by this column. }
+ property OnLVStateChange: TOnLVStateChange
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnLVStateChange {$ELSE} EV.FOnLVStateChange {$ENDIF}
+ write SetOnLVStateChange;
+ {* |<#listview>
+ This event occure when an item or items range in list view control are
+ changing its state (e.g. selected or unselected). }
+ property OnDrawItem: TOnDrawItem
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnDrawItem {$ELSE} EV.fOnDrawItem {$ENDIF}
+ write SetOnDrawItem;
+ {* |<#listview>
+ |<#listbox>
+ |<#combo>
+ This event can be used to implement custom drawing for list view, list box, dropped
+ list of a combobox. For a list view, custom drawing using this event is possible
+ only in lvsDetail and lvsDetailNoHeader styles, and OnDrawItem is called to draw
+ entire row at once only. See also OnLVCustomDraw event. }
+
+ property OnLVCustomDraw: TOnLVCustomDraw
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnLVCustomDraw {$ELSE} EV.FOnLVCustomDraw {$ENDIF}
+ write SetOnLVCustomDraw;
+ {* |<#listview>
+ Custom draw event for listview. For every item to be drawn, this event
+ can be called several times during a single drawing cycle - depending on
+ a result, returned by an event handler. Stage can have one of following
+ values:
+ |<pre>
+ CDDS_PREERASE
+ CDDS_POSTERASE
+ CDDS_ITEMPREERASE
+ CDDS_PREPAINT
+ CDDS_ITEMPREPAINT
+ CDDS_ITEM
+ CDDS_SUBITEM + CDDS_ITEMPREPAINT
+ CDDS_SUBITEM + CDDS_ITEMPOSTPAINT
+ CDDS_ITEMPOSTPAINT
+ CDDS_POSTPAINT
+ </pre>
+ When called, see on Stage to get know, on what stage the event is
+ activated. And depend on the stage and on what you want to paint,
+ return a value as a result, which instructs the system, if to use
+ default drawing on this (and follows) stage(s) for the item, and if
+ to notify further about different stages of drawing the item during
+ this drawing cycle. Possible values to return are:
+ |<pre>
+ CDRF_DODEFAULT - perform default drawing. Do not notify further for this
+ item (subitem) (or for entire listview, if called with
+ flag CDDS_ITEM reset - ?);
+ CDRF_NOTIFYITEMDRAW - return this value, when the event is called the
+ first time in a cycle of drawing, with ItemIdx = -1 and
+ flag CDDS_ITEM reset in Stage parameter;
+ CDRF_NOTIFYPOSTERASE - usually can be used to provide default erasing,
+ if you want to perform drawing immediately after that;
+ CDRF_NOTIFYPOSTPAINT - return this value to provide calling the event
+ after performing default drawing. Useful when you wish
+ redraw only a part of the (sub)item;
+ CDRF_SKIPDEFAULT - return this value to inform the system that all
+ drawing is done and system should not peform any more
+ drawing for the (sub)item during this drawing cycle.
+ CDRF_NEWFONT - informs the system, that font is changed and default
+ drawing should be performed with changed font;
+ |</pre>
+ 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.
+ |<br>
+ See also NM_CUSTOMDRAW in API Help.
+ }
+
+ procedure Set_LVItemHeight(Value: Integer);
+ function SetLVItemHeight(Value: Integer): PControl;
+ property LVItemHeight: Integer read DF.fLVItemHeight write Set_LVItemHeight;
+ {* |<#listview>
+ |<#listbox>
+ |#combo>
+ It is possible to assign a value to LVItemHeight property only to
+ control with "owner-draw" style (lvoOwnerDrawFixed for listview,
+ loOwnerDrawFixed or loOwnerDrawVariable for listbox and
+ coOwnerDrawFixed or coOwnerDrawVariable for combobox. At least, the
+ control should have such option while creating it (after showing it
+ the first time it is possible to change its options to avoid owner
+ drawing later). }
+
+ //======== TreeView specific properties and methods:
+ function TVInsert( nParent, nAfter: THandle; const Txt: KOLString ): THandle;
+ {* |<#treeview>
+ Inserts item to a tree view. If nParent is 0 or TVI_ROOT, the item is
+ inserted at the root of tree view. It is possible to pass following special
+ values as nAfter parameter:
+ |<pre>
+ TVI_FIRST Inserts the item at the beginning of the list.
+ TVI_LAST Inserts the item at the end of the list.
+ TVI_SORT Inserts the item into the list in alphabetical order.
+ |</pre> }
+ procedure TVDelete( Item: THandle );
+ {* |<#treeview>
+ Removes an item from the tree view. If value TVI_ROOT is passed, all items
+ are removed. }
+
+ property TVSelected: THandle index TVGN_CARET read TVGetItemIdx write TVSetItemIdx;
+ {* |<#treeview>
+ Returns or sets currently selected item handle in tree view. }
+
+ property TVDropHilighted: THandle index TVGN_DROPHILITE read TVGetItemIdx write TVSetItemIdx;
+ {* |<#treeview>
+ Returns or sets item, which is currently highlighted as a drop target. }
+ property TVDropHilited: THandle index TVGN_DROPHILITE read TVGetItemIdx write TVSetItemIdx;
+ {* The same as TVDropHilighted. }
+ property TVFirstVisible: THandle index TVGN_FIRSTVISIBLE read TVGetItemIdx write TVSetItemIdx;
+ {* |<#treeview>
+ Returns or sets given item to top of tree view. }
+
+ property TVIndent: Integer index TVM_GETINDENT read GetIntVal write SetIntVal;
+ {* |<#treeview>
+ The amount, in pixels, that child items are indented relative to their
+ parent items. }
+ property TVVisibleCount: Integer index TVM_GETVISIBLECOUNT read GetIntVal;
+ {* |<#treeview>
+ Returns number of fully (not partially) visible items in tree view. }
+
+ property TVRoot: THandle index TVGN_ROOT read TVGetItemIdx;
+ {* |<#treeview>
+ Returns handle of root item in tree view (or 0, if tree is empty). }
+ property TVItemChild[ Item: THandle ]: THandle index TVGN_CHILD read TVGetItemNext;
+ {* |<#treeview>
+ Returns first child item for given one. }
+ property TVItemHasChildren[ Item: THandle ]: Boolean read TV_GetItemHasChildren write TV_SetItemHasChildren;
+ {* |<#treeview>
+ TRUE, if an Item has children. Set this value to true if you want to
+ force [+] sign appearing left from the node, even if there are no
+ subnodes added to the node yet. }
+ property TVItemChildCount[ Item: THandle ]: Integer read TV_GetItemChildCount;
+ {* |<#treeview>
+ Returns number of node child items in tree view.
+ }
+ property TVItemNext[ Item: THandle ]: THandle index TVGN_NEXT read TVGetItemNext;
+ {* |<#treeview>
+ Returns next sibling item handle for given one (or 0, if passed item is
+ the last child for its parent node). }
+ property TVItemPrevious[ Item: THandle ]: THandle index TVGN_PREVIOUS read TVGetItemNext;
+ {* |<#treeview>
+ Returns previous sibling item (or 0, if the is no such item). }
+ property TVItemNextVisible[ Item: THandle ]: THandle index TVGN_NEXTVISIBLE read TVGetItemNext;
+ {* |<#treeview>
+ Returns next visible item (passed item must be visible too, to determine,
+ if it is really visible, use property TVItemRect or TVItemVisible. }
+ property TVItemPreviousVisible[ Item: THandle ]: THandle index TVGN_PREVIOUSVISIBLE read TVGetItemNext;
+ {* |<#treeview>
+ Returns previous visible item. }
+ property TVItemParent[ Item: THandle ]: THandle index TVGN_PARENT read TVGetItemNext;
+ {* |<#treeview>
+ Returns parent item for given one (or 0 for root item). }
+
+ property TVItemText[ Item: THandle ]: KOLString read TVGetItemText write TVSetItemText;
+ {* |<#treeview>
+ Text of tree view item. }
+ function TVItemPath( Item: THandle; Delimiter: KOLChar ): KOLString;
+ {* |<#treeview>
+ Returns full path from the root item to given item. Path is calculated
+ as a concatenation of all parent nodes text strings, separated by
+ given delimiter character.
+ |<br>Please note, that returned path has no trailing delimiter, this
+ character is only separating different parts of the path.
+ |<br>If Item is not specified ( =0 ), path is returned
+ for Selected item. }
+
+ property TVItemRect[ Item: THandle; TextOnly: Boolean ]: TRect read TVGetItemRect;
+ {* |<#treeview>
+ Returns rectangle, occupied by an item in tree view. }
+
+ property TVItemVisible[ Item: THandle ]: Boolean read TVGetItemVisible write TVSetITemVisible;
+ {* |<#treeview>
+ Returs True, if item is visible in tree view. It is also possible to
+ assign True to this property to ensure that a tree view item is visible
+ (if False is assigned, this does nothing). }
+ function TVItemAtPos( x, y: Integer; var Where: DWORD ): THandle;
+ {* |<#treeview>
+ Returns handle of item found at specified position (relative to upper left
+ corener of client area of the tree view). If no item found, 0 is returned.
+ Variable Where receives additional flags combination, describing more
+ detailed, on which part of item or tree view given point is located,
+ such as:
+ |<pre>
+ TVHT_ABOVE Above the client area
+ TVHT_BELOW Below the client area
+ TVHT_NOWHERE In the client area, but below the last item
+ TVHT_ONITEM On the bitmap or label associated with an item
+ TVHT_ONITEMBUTTON On the button associated with an item
+ TVHT_ONITEMICON On the bitmap associated with an item
+ TVHT_ONITEMINDENT In the indentation associated with an item
+ TVHT_ONITEMLABEL On the label (string) associated with an item
+ TVHT_ONITEMRIGHT In the area to the right of an item
+ TVHT_ONITEMSTATEICON On the state icon for a tree-view item that is in a user-defined state
+ TVHT_TOLEFT To the right of the client area
+ TVHT_TORIGHT To the left of the client area
+ |</pre> }
+
+ property TVRightClickSelect: Boolean read DF.fTVRightClickSelect write SetTVRightClickSelect;
+ {* |<#treeview>
+ Set this property to True to allow change selection to an item, clicked with right mouse button. }
+ property TVEditing: Boolean read GetTVEditing;
+ {* |<#treeview>
+ Returns True, if tree view control is editing its item label. }
+ property TVItemBold[ Item: THandle ]: Boolean index TVIS_BOLD read TVGetItemStateFlg write TVSetItemStateFlg;
+ {* |<#treeview>
+ True, if item is bold. }
+ property TVItemCut[ Item: THandle ]: Boolean index TVIS_CUT read TVGetITemStateFlg write TVSetItemStateFlg;
+ {* |<#treeview>
+ True, if item is selected as part of "cut and paste" operation. }
+ property TVItemDropHighlighted[ Item: THandle ]: Boolean index TVIS_DROPHILITED read TVGetITemStateFlg write TVSetItemStateFlg;
+ {* |<#treeview>
+ True, if item is selected as drop target. }
+ property TVItemDropHilited[ Item: THandle ]: Boolean index TVIS_DROPHILITED read TVGetITemStateFlg write TVSetItemStateFlg;
+ {* The same as TVItemDropHighlighted. }
+ property TVItemExpanded[ Item: THandle ]: Boolean index TVIS_EXPANDED read TVGetITemStateFlg; // write TVSetItemStateFlg;
+ {* |<#treeview>
+ True, if item's list of child items is currently expanded. To change
+ expanded state, use method TVExpand. }
+ property TVItemExpandedOnce[ Item: THandle ]: Boolean index TVIS_EXPANDEDONCE read TVGetITemStateFlg; // write TVSetItemStateFlg;
+ {* |<#treeview>
+ True, if item's list of child items has been expanded at least once. }
+ property TVItemSelected[ Item: THandle ]: Boolean index TVIS_SELECTED read TVGetITemStateFlg write TVSetItemStateFlg;
+ {* |<#treeview>
+ True, if item is selected. }
+
+ procedure TVExpand( Item: THandle; Flags: DWORD );
+ {* |<#treeview>
+ Call it to expand/collapse item's child nodes. Possible values for Flags
+ parameter are:
+ <pre>
+ TVE_COLLAPSE Collapses the list.
+ TVE_COLLAPSERESET Collapses the list and removes the child items. Note
+ that TVE_COLLAPSE must also be specified.
+ TVE_EXPAND Expands the list.
+ TVE_TOGGLE Collapses the list if it is currently expanded or
+ expands it if it is currently collapsed.
+ </pre>
+ }
+ procedure TVSort( N: THandle );
+ {* |<#treeview>
+ By Alex Mokrov. Sorts treeview. If N = 0, entire treeview is sorted.
+ Otherwise, children of the given node only.
+ }
+
+ property TVItemImage[ Item: THandle ]: Integer index TVIF_IMAGE read TVGetItemImage write TVSetItemImage;
+ {* |<#treeview>
+ Image index for an item of tree view. To tell that there are no image
+ set, use index -2 (value -1 is reserved for callback image). }
+ property TVItemSelImg[ Item: THandle ]: Integer index TVIF_SELECTEDIMAGE read TVGetItemImage write TVSetItemImage;
+ {* |<#treeview>
+ Image index for an item of tree view in selected state. Use value -2 to
+ provide no image, -1 used for callback image. }
+ property TVItemOverlay[ Item: THandle ]: Integer index TVIS_OVERLAYMASK or $80000
+ read TVGetItemImage write TVSetItemImage;
+ {* |<#treeview>
+ Overlay image index for an item in tree view.
+ Values 1..15 can be used only - this is the Windows restriction on
+ overlay images. }
+ property TVItemStateImg[ Item: THandle ]: Integer index TVIS_STATEIMAGEMASK or $C0000
+ read TVGetItemImage write TVSetItemImage;
+ {* |<#treeview>
+ State image index for an item in tree view. Use 1-based index of the image
+ in image list ImageListState. Value 0 reserved to use as "no state image".
+ }
+
+ property TVItemData[ Item: THandle ]: Pointer read TVGetItemData write TVSetItemData;
+ {* |<#treeview>
+ Stores any program-defined pointer with the item. }
+ procedure TVEditItem( Item: THandle );
+ {* |<#treeview>
+ Begins editing given item label in tree view. }
+ procedure TVStopEdit( Cancel: Boolean );
+ {* |<#treeview>
+ Ends editing item label, started by user or explicitly by TVEditItem method. }
+
+ property OnTVBeginDrag: TOnTVBeginDrag
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnTVBeginDrag {$ELSE} EV.fOnTVBeginDrag {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnTVBeginDrag {$ELSE} EV.fOnTVBeginDrag {$ENDIF};
+ {* |<#treeview>
+ Is called for tree view, when its item is to be dragging. }
+ property OnTVBeginEdit: TOnTVBeginEdit
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnTVBeginEdit {$ELSE} EV.fOnTVBeginEdit {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnTVBeginEdit {$ELSE} EV.fOnTVBeginEdit {$ENDIF};
+ {* |<#treeview>
+ Is called for tree view, when its item label is to be editing.
+ Return TRUE to allow editing of the item. }
+ property OnTVEndEdit: TOnTVEndEdit
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnTVEndEdit {$ELSE} EV.fOnTVEndEdit {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnTVEndEdit {$ELSE} EV.fOnTVEndEdit {$ENDIF};
+ {* |<#treeview>
+ Is called when item label is edited. It is possible to cancel
+ edit, returning False as a result. }
+ property OnTVExpanding: TOnTVExpanding
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnTVExpanding {$ELSE} EV.fOnTVExpanding {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnTVExpanding {$ELSE} EV.fOnTVExpanding {$ENDIF};
+ {* |<#treeview>
+ Is called just before expanding/collapsing item. It is possible to
+ return TRUE to prevent expanding item, otherwise FALSE should be returned. }
+ property OnTVExpanded: TOnTVExpanded
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnTVExpanded {$ELSE} EV.fOnTVExpanded {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnTVExpanded {$ELSE} EV.fOnTVExpanded {$ENDIF};
+ {* |<#treeview>
+ Is called after expanding/collapsing item children. }
+ property OnTVDelete: TOnTVDelete
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnTVDelete {$ELSE} EV.fOnTVDelete {$ENDIF}
+ write SetOnTVDelete;
+ {* |<#treeview>
+ Is called just before deleting item. You may use this event to free
+ resources, associated with an item (see TVItemData property). }
+ //----------------- by Sergey Shisminzev:
+ property OnTVSelChanging: TOnTVSelChanging
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnTVSelChanging {$ELSE} EV.fOnTVSelChanging {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnTVSelChanging {$ELSE} EV.fOnTVSelChanging {$ENDIF};
+ {* |<#treeview>
+ Is called before changing the selection. The handler can return FALSE
+ to prevent changing the selection. }
+ //--------------------------------------
+
+ //======== Toolbar specific methods:
+ procedure TBAddBitmap( Bitmap: HBitmap );
+ {* |<#toolbar>
+ Adds bitmaps to a toolbar. You can pass special values as Bitmap to
+ add one of predefined system button images bitmaps:
+ |<br> THandle(-1) to add standard small icons,
+ |<br> THandle(-2) to add standard large icons,
+ |<br> THandle(-5) to add standard small view icons,
+ |<br> THandle(-6) to add standard large view icons,
+ |<br> THandle(-9) to add standard small history icons,
+ |<br> THandle(-10) to add standard large history icons,
+ (in that case use following values as indexes to the standard and view
+ bitmaps:
+ |<br>
+ STD_COPY, STD_CUT, STD_DELETE, STD_FILENEW, STD_FILEOPEN, STD_FILESAVE,
+ STD_FIND, STD_HELP, STD_PASTE, STD_PRINT, STD_PRINTPRE, STD_PROPERTIES,
+ STD_REDO, STD_REPLACE, STD_UNDO,
+ |<br>
+ VIEW_LARGEICONS, VIEW_SMALLICONS,
+ VIEW_LIST, VIEW_DETAILS, VIEW_SORTNAME, VIEW_SORTSIZE, VIEW_SORTDATE,
+ VIEW_SORTTYPE (use it as parameters BtnImgIdxArray in TBAddButtons or
+ TBInsertButtons methods, and in assigning value to TBButtonImage[ ]
+ property).
+ Added bitmaps have indeces starting from previous count of images
+ (as these are appended to existing - if any).
+ |<br>
+ Note, that if You add your own (custom) bitmap, it is not transparent.
+ Do not assume that clSilver is always equal to clBtnFace. Use API
+ function CreateMappedBitmap to load bitmap from resource and map
+ desired colors as you wish (e.g., convert clTeal to clBtnFace). Or,
+ call defined in KOL function LoadMappedBitmap to do the same more easy.
+ Unfortunately, resource identifier for bitmap to pass it to LoadMappedBitmap
+ or to CreateMappedBitmap seems must be integer, so it is necessary to
+ create rc-file manually and compile using Borland Resource Compiler to
+ figure it out. }
+
+ function TBAddButtons( const Buttons: array of PKOLChar;
+ const BtnImgIdxArray: array of Integer ): Integer;
+ {* |<#toolbar>
+ Adds buttons to toolbar. Last string in Buttons array *must* be empty
+ ('' or nil), so to add buttons without text, pass ' ' string (one space
+ char). It is not necessary to provide image indexes for all
+ buttons (it is sufficient to assign index for first button only).
+ But in place, correspondent to separator button (defined by string '-'),
+ any integer must be passed to assign follow image indexes correctly.
+ See example.
+ |*Toolbar adding buttons sample.
+ Code below shows how to call TBAddButtons method to add two buttons with
+ a separator between these buttons. idxNew and idxOld are integer
+ expressions assigning image indexes to buttons 'New' and 'Old'. This
+ indexes are zero-based and refer to bitmap images, added earlier (either
+ in creating toolbar by call of NewToolbar or later in call of TBAddBitmap).
+ !
+ ! TBAddButtons( [ '&New', '-', '&Old', '' ], [ idxNew, 0, idxOld ] );
+ !
+ |*
+ To add check buttons, use prefix '+' or '-' in button definition
+ string. If next character is '!', such buttons are grouped to a
+ radio-group. Also, it is possible to use '^' prefix (must be first) to
+ define button with small drop-down section (use also OnTBDropDown event
+ to respond to clicking drop down section of such buttons).
+ |<br>
+ This function returns command id for first added button (other
+ id's can be calculated incrementing the result by one for each
+ button, except separators, which have no command id).
+ |<br>
+ Note: for static toolbar (single in application and created
+ once) ids are started from value 100. }
+
+ function TBInsertButtons( BeforeIdx: Integer; Buttons: array of PKOLChar;
+ const BtnImgIdxArray: array of Integer ): Integer;
+ {* |<#toolbar>
+ Inserts buttons before button with given index on toolbar. Returns
+ command identifier for first button inserted (other can be calculated
+ incrementing returned value needed times. See also TBAddButtons. }
+
+ procedure TBDeleteButton( BtnID: Integer );
+ {* |<#toolbar>
+ Deletes single button given by its command id. To delete separator,
+ use TBDeleteBtnByIdx instead. }
+
+ procedure TBDeleteBtnByIdx( Idx: Integer );
+ {* |<#toolbar>
+ Deletes single button given by its index in toolbar (not by command ID). }
+
+ procedure TBClear;
+ {* |<#toolbar>
+ Deletes all buttons. Dufa }
+
+ procedure TBAssignEvents( BtnID: Integer; Events: array of TOnToolbarButtonClick );
+ {* |<#toolbar>
+ Allows to assign separate OnClick events for every toolbar button.
+ BtnID should be toolbar button ID or index of the first button to
+ assign event. If it is an ID, events are assigned to buttons in
+ creation order. Otherwise, events are assigned in placement order.
+ Anyway, separator buttons are not skipped, so pass at least nil for such
+ button as an event.
+ |<br>
+ Please note, that though not all buttons should exist before
+ assigning events to it, therefore at least the first button
+ (specified by BtnID) must be already added before calling TBAssignEvents. }
+
+ procedure TBResetImgIdx( BtnID, BtnCount: Integer );
+ {* |<#toolbar>
+ Resets image index for BtnCount buttons starting from BtnID. }
+
+ //property CurItem: Integer read DF.fTBCurItem;
+ {* |<#toolbar>
+ For toolbar, in OnClick event this property can be used to determine
+ which button was clicked (100-based button id in toolbar). It is also
+ possible to use CurIndex property (zero-based) for this purpose as
+ well, but do not assume, that CurItem always equal to CurIndex+100.
+ At least, it is possible to call TBItem2Index function to convert
+ button ID to its index in toolbar.
+ }
+ property TBCurItem: Integer read DF.fTBCurItem;
+ {* |<#toolbar>
+ Same as CurItem. }
+
+ property TBButtonCount: Integer read GetItemsCount; //TBGetButtonCount;
+ {* |<#toolbar>
+ Returns count of buttons on toolbar. The same as Count. }
+
+ property TBBtnImgWidth: Integer read DF.fTBBtnImgWidth write DF.fTBBtnImgWidth;
+ {* |<#toolbar>
+ Custom toolbar buttons width. Set it before assigning buttons bitmap.
+ Changing this property after assigning the bitmap has no effect. }
+
+ function TBItem2Index( BtnID: Integer ): Integer;
+ {* |<#toolbar>
+ Converts button command id to button index for tool bar. }
+
+ function TBIndex2Item( Idx: Integer ): Integer;
+ {* |<#toolbar>
+ Converts toolbar button index to its command ID. }
+
+ procedure TBConvertIdxArray2ID( const IdxVars: array of PDWORD );
+ {* |<#toolbar>
+ Converts toolbar button indexes to its command IDs for an array
+ of indexes (each item in the array passed is a pointer to
+ Integer, containing button index when the procedure is callled,
+ then all these indexes are relaced with a correspondent button ID).}
+
+ property TBButtonEnabled[ BtnID: Integer ]: Boolean index TB_ENABLEBUTTON
+ read TBGetBtnStt write TBSetBtnStt;
+ {* |<#toolbar>
+ Obvious. }
+
+ property TBButtonVisible[ BtnID: Integer ]: Boolean read TBGetButtonVisible
+ write TBSetButtonVisible;
+ {* |<#toolbar>
+ Allows to hide/show some of toolbar buttons. }
+
+ property TBButtonChecked[ BtnID: Integer ]: Boolean index TB_CHECKBUTTON
+ read TBGetBtnStt write TBSetBtnStt;
+ {* |<#toolbar>
+ Allows to determine 'checked' state of a button (e.g., radio-button),
+ and to check it programmatically. }
+
+ property TBButtonMarked[ BtnID: Integer ]: Boolean index TB_MARKBUTTON
+ read TBGetBtnStt write TBSetBtnStt;
+ {* |<#toolbar>
+ Returns True if toolbar button is marked (highlighted). Allows to
+ highlight buttons assigning True to this value. }
+
+ property TBButtonPressed[ BtnID: Integer ]: Boolean index TB_PRESSBUTTON
+ read TBGetBtnStt write TBSetBtnStt;
+ {* |<#toolbar>
+ Allows to detrmine if toolbar button (given by its command ID) pressed,
+ and press/unpress it programmatically. }
+
+ property TBButtonText[ BtnID: Integer ]: KOLString read TBGetButtonText write TBSetButtonText;
+ {* |<#toolbar>
+ Obtains toolbar button text and allows to change it. Be sure that text
+ is not empty for all buttons, if You want for it to be shown (if at least
+ one button has empty text, no text labels will be shown at all). At
+ least set it to ' ' for buttons, which You do not want to show labels,
+ if You want from other ones to have it. }
+
+ property TBButtonImage[ BtnID: Integer ]: Integer read TBGetBtnImgIdx write TBSetBtnImgIdx;
+ {* |<#toolbar>
+ Allows to access/change button image. Do not read this property for
+ separator buttons, returning value is not proper. If you do not know,
+ is the button a separator, using function below. }
+
+ function TBButtonSeparator( BtnID: Integer ): Boolean;
+ {* |<#toolbar>
+ Returns TRUE, if a toolbar button is separator. }
+
+ property TBButtonRect[ BtnID: Integer ]: TRect read TBGetButtonRect;
+ {* |<#toolbar>
+ Obtains rectangle occupied by toolbar button in toolbar window.
+ (It is not possible to obtain rectangle for buttons, currently
+ not visible). See also function ToolbarButtonRect. }
+
+ property TBButtonWidth[ BtnID: Integer ]: Integer read TBGetBtnWidth write TBSetBtnWidth;
+ {* |<#toolbar>
+ Allows to obtain / change toolbar button width. }
+
+ property TBButtonLParam[const Idx: Integer]: DWORD read TBGetButtonLParam write TBSetButtonLParam;
+ {* |<#toolbar>
+ Allows to access/change LParam. Dufa }
+
+ property TBButtonsMinWidth: Integer index 0
+ {$IFDEF F_P} read TBGetBtMinMaxWidth
+ {$ELSE DELPHI} read DF.fTBBtMinWidth
+ {$ENDIF F_P/DELPHI} write TBSetBtMinMaxWidth;
+ {* |<#toolbar>
+ Allows to set minimal width for all toolbar buttons. }
+ property TBButtonsMaxWidth: Integer index 1
+ {$IFDEF F_P} read TBGetBtMinMaxWidth
+ {$ELSE DELPHI} read DF.fTBBtMaxWidth
+ {$ENDIF F_P/DELPHI} write TBSetBtMinMaxWidth;
+ {* |<#toolbar>
+ Allows to set maximal width for all toolbar buttons. }
+
+ function TBButtonAtPos( X, Y: Integer ): Integer;
+ {* |<#toolbar>
+ Returns command ID of button at the given position on toolbar,
+ or -1, if there are no button at the position. Value 0 is returned
+ for separators. }
+
+ function TBBtnIdxAtPos( X, Y: Integer ): Integer;
+ {* |<#toolbar>
+ Returns index of button at the given position on toolbar.
+ This also can be index of separator button. -1 is returned if
+ there are no buttons found at the position. }
+
+ function TBBtnEvent( Idx: Integer ): TOnToolbarButtonClick;
+ {* Returns toolbar event handler assigned to a toolbar button
+ (by its index). }
+
+ function TBMoveBtn( FromIdx, ToIdx: Integer ): Boolean;
+ {* |<#toolbar>
+ By TR"]F. Moves button from one position to another. }
+
+ property TBRows: Integer read TBGetRows write TBSetRows;
+ {* |<#toolbar>
+ Returns number of rows for toolbar and allows to try to set
+ desired number of rows (but system can set another number of
+ rows in some cases). This property has no effect if tboWrapable
+ style not present in Options when toolbar is created. }
+
+ procedure TBSetTooltips( BtnID1st: Integer; const Tooltips: array of PKOLChar );
+ {* |<#toolbar>
+ Allows to assign tooltips to several buttons. Until this procedure
+ is not called, tooltips list is not created and no code is added
+ to executable. This method of tooltips maintainance for toolbar buttons
+ is useful both for static and dynamic toolbars (meaning "dynamic" -
+ toolbars with buttons, deleted and inserted at run-time). }
+
+ function TBBtnTooltip( BtnID: Integer ): KOLString;
+ {* |<#toolbar> Returns tooltip assigned to a toolbar button. }
+
+ property TBAutoSizeButtons: Boolean read GetTBAutoSizeButtons write SetTBAutoSizeButtons;
+
+ property OnTBDropDown: TOnEvent index idx_FOnDropDown
+ read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnDropDown {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnDropDown {$ENDIF};
+ {* |<#toolbar>
+ This event is called for drop down buttons, when user click drop part
+ of drop down button. To determine for which button event is called,
+ look at CurItem or CurIndex property. It is also possible to use
+ common (with combobox) property OnDropDown. }
+
+ property OnTBClick: TOnEvent
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnClick {$ELSE} EV.fOnClick {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} SetOnClick {$ELSE} EV.fOnClick{$ENDIF};
+ {* |<#toolbar>
+ The same as OnClick. }
+
+ property OnTBCustomDraw: TOnTBCustomDraw read DF.fOnTBCustomDraw write SetOnTBCustomDraw;
+ {* |<#toolbar>
+ An event (mainly) to customize toolbar background. }
+ //----------------------------------------------------------------------
+ // DateTimePicker
+ property OnDTPUserString: TDTParseInputEvent
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnDTPUserString {$ELSE} EV.FOnDTPUserString {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnDTPUserString {$ELSE} EV.FOnDTPUserString{$ENDIF};
+ {* Special event to parse input from the application. Option dtpoParseInput
+ must be set when control is created. }
+ property DateTime: TDateTime read GetDateTime write SetDateTime;
+ {* DateTime for DateTimePicker control only. }
+ property Date: TDateTime read GetDate write SetDate;
+ {* Date only for DateTimePicker control only. }
+ property Time: TDateTime read GetTime write SetTime;
+ {* Time only for DateTimePicker control only. }
+ property SystemTime: TSystemTime read Get_SystemTime write Set_SystemTime;
+ {* Date and Time as TSystemTime. When assing, use year 0 to set "no value". }
+ property DateTimeRange: TDateTimeRange read GetDateTimeRange
+ write SetDateTimeRange;
+ {* DateTimePicker range. If first date in the agrument assigned is NAN,
+ minimum system allowed value is used as the left bound, and if the second is
+ NAN, maximum system allowed is used as the right one. }
+ property DateTimePickerColors[ Index: TDateTimePickerColor ]: TColor
+ read GetDateTimePickerColor write SetDateTimePickerColor;
+ property DateTimeFormat: KOLString write SetDateTimeFormat;
+
+ //----------------------------------------------------------------------
+
+ //----------------------------------------------------------------------
+ // ScrollBar
+ property SBMin: Longint read DF.fSBMinMax.X write SetSBMin;
+ {* Minimum scrolling area position. }
+ property SBMax: Longint read DF.fSBMinMax.Y write SetSBMax;
+ {* Maximum scrolling area position (size of the text or image to be scrolling).
+ For case when SCROLL_OLD defined, this value should be set as scrolling
+ object size without SBPageSize. }
+ property SBMinMax: TPoint read DF.fSBMinMax write SetSBMinMax;
+ {* The property to adjust SBMin and SBMax for a single call (set X to a minimum
+ and Y to a maximum value). }
+ property SBPosition: Integer read DF.fSBPosition write SetSBPosition;
+ {* Current scroll position. When set, should be between SBMin and
+ SBMax - max(0, SBPageSize-1) }
+ property SBPageSize: Integer read DF.fSBPageSize write SetSBPageSize;
+ {* }
+
+ property OnSBBeforeScroll: TOnSBBeforeScroll
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnSBBeforeScroll {$ELSE} EV.FOnSBBeforeScroll {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnSBBeforeScroll {$ELSE} EV.FOnSBBeforeScroll {$ENDIF};
+ {* }
+ property OnSBScroll: TOnSBScroll
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnSBScroll {$ELSE} EV.FOnSBScroll {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_OnSBScroll {$ELSE} EV.FOnSBScroll {$ENDIF};
+ {* }
+
+ function SBSetScrollInfo(const SI: TScrollInfo): Integer;
+ function SBGetScrollInfo(var SI: TScrollInfo): Boolean;
+ function GetSBMinMax: TPoint;
+ function GetSBPageSize: Integer;
+ function GetSBPosition: Integer;
+ //----------------------------------------------------------------------
+
+ // "Through", or "transparent" methods to simplify initial
+ // adjustment of controls and make non-visual designing of
+ // forms more easy. All these functions return @Self as a
+ // result, so, it is possible to use such methods immediately
+ // in constructing statement, concatenating it with dots, e.g.:
+ //
+ // NewButton( MyForm, 'Click here' ).PlaceUnder.ResizeParentBottom;
+ //
+ {$ENDIF GDI}
+ function PlaceRight: PControl;
+ {* Places control right (to previously created on the same parent). }
+ function PlaceDown: PControl;
+ {* Places control below (to previously created on the same parent).
+ Left position is not changed (thus is, kept equal to Parent.Margin). }
+ function PlaceUnder: PControl;
+ {* Places control below (to previously created one, aligning its
+ Left position to Left position of previous control). }
+ function SetSize( W, H: Integer ): PControl;
+ {* Changes size of a control. If W or H less or equal to 0,
+ correspondent size is not changed. }
+ {$IFDEF GDI}
+ function Size( W, H: Integer ): PControl;
+ {* Like SetSize, but provides automatic resizing of parent control
+ (recursively). Especially useful for aligned controls. }
+ function SetClientSize( W, H: Integer ): PControl;
+ {* Like SetSize, but works setting W = ClientWidth, H = ClientHeight.
+ Use this method for forms, which can not be resized (dialogs). }
+
+ {$ENDIF GDI}
+ function AutoSize( AutoSzOn: Boolean ): PControl;
+ {$IFDEF GDI}
+ function MakeWordWrap: PControl;
+
+ {* Determines if to autosize control (like label, button, etc.) }
+ function IsAutoSize: Boolean;
+ {* TRUE, if a control is autosizing. }
+ function AlignLeft( P: PControl ): PControl;
+ {* assigns Left := P.Left }
+ function AlignTop( P: PControl ): PControl;
+ {* assigns Top := P.Top }
+ function ResizeParent: PControl;
+ {* Resizes parent, calling ResizeParentRight and ResizeParentBottom. }
+ function ResizeParentRight: PControl;
+ {* Resizes parent right edge (Margin of parent is added to right
+ coordinate of a control). If called second time (for the same
+ parent), resizes only for increasing of right edge of parent. }
+
+ function ResizeParentBottom: PControl;
+ {* Resizes parent bottom edge (Margin of parent is added to
+ bottom coordinate of a control). }
+ function CenterOnParent: PControl;
+ {* Centers control on parent, or if applied to a form, centers
+ form on screen. }
+ function CenterOnForm( Form1: PControl ): PControl;
+ {* Centers form on another form. If Form1 not present, centers on screen. }
+
+ function Shift( dX, dY : Integer ): PControl;
+ {* Moves control respectively to current position (Left := Left + dX,
+ Top := Top + dY). }
+ {$ENDIF GDI}
+ function SetPosition( X, Y: Integer ): PControl;
+ {* Moves control directly to the specified position. }
+ {$IFDEF GDI}
+
+ function Tabulate: PControl;
+ {* Call it once for form/applet to provide tabulation between controls on
+ form/on all forms using TAB / SHIFT+TAB and arrow keys. }
+ function TabulateEx: PControl;
+ {* Call it once for form/applet to provide tabulation between controls on
+ form/on all forms using TAB / SHIFT+TAB and arrow keys. Arrow keys are
+ used more smart, allowing go to nearest control in certain direction. }
+
+ function SetAlign( AAlign: TControlAlign ): PControl;
+ {* Assigns passed value to property Align, aligning control on parent,
+ and returns @Self (so it is "transparent" function, which can be
+ used to adjust control at the creation, e.g.:
+ ! MyLabel := NewLabel( MyForm, 'Label1' ).SetAlign( caBottom );
+ See also property Align. }
+ //{-2.95}//function PreventResizeFlicks: PControl;
+ { *
+ If called, prevents resizing flicks for child controls, aligned to
+ right and bottom (but with a lot of code added to executable - about 3,5K).
+ There is sensible to set DoubleBuffered to True also to eliminate the
+ most of flicks.
+ |<br>
+ This method been applied to a form, prevents, resizing flicks for
+ form and all controls on the form. If it is called for applet window,
+ all forms are affected. And if You want, You can apply it for certain
+ control only - in such case only given control and its children will
+ be resizing without flicks (e.g., using splitter control). } //{-2.95}
+
+ property Checked: Boolean read GetChecked write Set_Checked;
+ {* |<#checkbox>
+ |<#radiobox>
+ |<#bitbtn>
+ For checkbox and radiobox - if it is checked. Do not assign
+ value for radiobox - use SetRadioChecked instead. }
+ function SetChecked(const Value: Boolean): PControl;
+ {* |<#checkbox>
+ Use it to check/uncheck check box control or push button.
+ Do not apply it to check radio buttons - use SetRadioChecked
+ method below. }
+ function SetRadioChecked : PControl;
+ {* |<#radiobox>
+ Use it to check radio button item correctly (unchecking all
+ alternative ones). Actually, method Click is called, and control
+ itself is returned. }
+ property Check3: TTriStateCheck read GetCheck3 write SetCheck3;
+ {* |<#checkbox>
+ State of checkbox with BS_AUTO3STATE style. }
+ procedure Click;
+ {* |<#button>
+ |<#checkbox>
+ |<#radiobox>
+ Emulates click on control programmatically, sending WM_COMMAND
+ message with BN_CLICKED code. This method is sensible only for
+ buttons, checkboxes and radioboxes. }
+
+ function Perform( msgcode: DWORD; wParam, lParam: Integer): Integer; stdcall;
+ {* Sends message to control's window (created if needed). }
+ function Postmsg( msgcode: DWORD; wParam, lParam: Integer): Boolean; stdcall;
+ {* Sends message to control's window (created if needed). }
+ procedure AttachProc( Proc: TWindowFunc );
+ {* It is possible to attach dynamically any message handler to window
+ procedure using this method. Last attached procedure is called first.
+ If procedure returns True, further processing of a message is stopped.
+ Attached procedure can be detached using DetachProc (but do not
+ attach/detach procedures during handling of attached procedure -
+ this can hang application). }
+ procedure AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean );
+ {* The same as AttachProc, but a handler is executed even after terminating
+ the main message loop processing (i.e. after assigning true to
+ AppletTerminated global variable. }
+ function IsProcAttached( Proc: TWindowFunc ): Boolean;
+ {* Returns True, if given procedure is already in chain of attached
+ ones for given control window proc. }
+ procedure DetachProc( Proc: TWindowFunc );
+ {* Detaches procedure attached earlier using AttachProc. }
+
+ property OnDropFiles: TOnDropFiles
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnDropFiles {$ELSE} EV.FOnDropFiles {$ENDIF}
+ write SetOnDropFiles;
+ {* Assign this event to your handler, if You want to accept drag and drop
+ files from other applications such as explorer onto your control. When
+ this event is assigned to a control or form, this has effect also for
+ all its child controls too. }
+
+ property CustomData: Pointer read fCustomData write fCustomData;
+ {* Can be used to exend the object when new type of control added. Memory,
+ pointed by this pointer, released automatically in the destructor. }
+ property CustomObj: PObj read fCustomObj write fCustomObj;
+ {* Can be used to exend the object when new type of control added. Object,
+ pointed by this pointer, released automatically in the destructor. }
+ procedure SetAutoPopupMenu( PopupMenu: PObj );
+ {* To assign a popup menu to the control, call SetAutoPopupMenu method of
+ the control with popup menu object as a parameter. }
+
+ function SupportMnemonics: PControl;
+ {* This method provides supporting mnemonic keys in menus, buttons, checkboxes,
+ toolbar buttons. }
+ property OnScroll: TOnScroll
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnScroll {$ELSE} EV.FOnScroll {$ENDIF}
+ write SetOnScroll;
+ {* }
+ public
+ {$IFDEF USE_DROPDOWNCOUNT}
+ property DropDownCount: Cardinal read DF.fDropDownCount write DF.fDropDownCount;
+ {$ENDIF}
+ protected
+ {$IFDEF USE_GRAPHCTLS}
+ {} fKeyboardProcess: TOnMessage; // for graphic controls ???
+ {} fSetFocus: procedure(Ctl: PControl);
+ {} fPushedBtn: PControl;
+ {} fSaveCursor: HCursor;
+ function DoGraphCtlPrepaint: TRect;
+ procedure GraphicLabelPaint( DC: HDC );
+ procedure GraphicCheckBoxPaint( DC: HDC );
+ procedure GraphicCheckBoxMouse( var Msg: TMsg );
+ procedure GraphicRadioBoxPaint( DC: HDC );
+ procedure GraphicButtonPaint( DC: HDC );
+ procedure GraphicButtonMouse( var Msg: TMsg );
+ function GraphButtonKeyboardProcess( var Msg: TMsg; var Rslt: Integer ): Boolean;
+ procedure LeaveGraphButton( Sender: PObj );
+ procedure GraphicEditPaint( DC: HDC );
+ procedure GraphicEditMouse( var Msg: TMsg );
+ procedure DestroyGraphEdit( Sender: PObj );
+ procedure LeaveGraphEdit( Sender: PObj );
+ procedure ChangeGraphEdit( Sender: PObj );
+ procedure GraphCtlDrawFocusRect( DC: HDC; const R: TRect );
+ {$IFDEF GRAPHCTL_HOTTRACK}
+ procedure MouseLeaveFromParentOfGraphCtl( Sender: PObj );
+ {$ENDIF GRAPHCTL_HOTTRACK}
+ procedure GroupBoxPaint( DC: HDC );
+ {$ENDIF USE_GRAPHCTLS}
+ {$IFDEF KEY_PREVIEW}
+ public
+ property KeyPreview: Boolean
+ read {$IFDEF USE_FLAGS} GetKeyPreview {$ELSE} fKeyPreview {$ENDIF}
+ write {$IFDEF USE_FLAGS} SetKeyPreview {$ELSE} fKeyPreview {$ENDIF};
+ //property KeyPreviewing: Boolean read fKeyPreviewing write fKeyPreviewing;
+ {$ENDIF KEY_PREVIEW}
+ protected
+ fOldWidth: Word;
+ fOldHeight: Word;
+ fClickDisabled: Byte;
+ fAnchors: Byte;
+ fNestedMsgHandling: SmallInt;
+ {* level of nested message handling for a control. Only when it is 0 at
+ the end of message handling and fBeginDestroying set, the control is
+ destroyed. }
+ fUpdateCount: SmallInt;
+ public
+ property AnchorLeft: Boolean index ANCHOR_LEFT read GetAnchor write SetAnchor; //+Sormart
+ property AnchorTop: Boolean index ANCHOR_TOP read GetAnchor write SetAnchor; //+Sormart
+ property AnchorRight: Boolean index ANCHOR_RIGHT read GetAnchor write SetAnchor;
+ property AnchorBottom: Boolean index ANCHOR_BOTTOM read GetAnchor write SetAnchor;
+ function Anchor( aLeft, aTop, aRight, aBottom: Boolean ): PControl;
+ public
+ {$IFDEF USE_CONSTRUCTORS}
+ //------------------------------------------------------------
+ // constructors here:
+ constructor CreateWindowed( AParent: PControl; AClassName: PKOLChar; ACtl3D: Boolean );
+ constructor CreateApplet( const ACaption: AnsiString );
+ constructor CreateForm( AParent: PControl; const ACaption: AnsiString );
+ constructor CreateControl( AParent: PControl; AClassName: PAnsiChar; AStyle: DWORD;
+ {} ACtl3D: Boolean; Actions: PCommandActions );
+ constructor CreateButton( AParent: PControl; const ACaption: AnsiString );
+ constructor CreateBitBtn( AParent: PControl; const ACaption: AnsiString;
+ {} AOptions: TBitBtnOptions; ALayout: TGlyphLayout; AGlyphBitmap: HBitmap;
+ {} AGlyphCount: Integer);
+ constructor CreateLabel( AParent: PControl; const ACaption: AnsiString );
+ constructor CreateWordWrapLabel( AParent: PControl; const ACaption: AnsiString );
+ constructor CreateLabelEffect( AParent: PControl; ACaption: AnsiString; AShadowDeep: Integer );
+ constructor CreatePaintBox( AParent: PControl );
+ constructor CreateGradientPanel( AParent: PControl; AColor1, AColor2: TColor );
+ constructor CreateGradientPanelEx( AParent: PControl; AColor1, AColor2: TColor;
+ {} AStyle: TGradientStyle; ALayout: TGradientLayout );
+ constructor CreateGroupbox( AParent: PControl; const ACaption: AnsiString );
+ constructor CreateCheckbox( AParent: PControl; const ACaption: AnsiString );
+ constructor CreateRadiobox( AParent: PControl; const ACaption: AnsiString );
+ constructor CreateEditbox( AParent: PControl; AOptions: TEditOptions );
+ constructor CreatePanel( AParent: PControl; AStyle: TEdgeStyle );
+ constructor CreateSplitter( AParent: PControl; AMinSizePrev, AMinSizeNext: Integer;
+ {} EdgeStyle: TEdgeStyle );
+ constructor CreateListbox( AParent: PControl; AOptions: TListOptions );
+ constructor CreateCombobox( AParent: PControl; AOptions: TComboOptions );
+ constructor CreateCommonControl( AParent: PControl; AClassName: PAnsiChar; AStyle: DWORD;
+ {} ACtl3D: Boolean; Actions: PCommandActions );
+ constructor CreateRichEdit( AParent: PControl; AOptions: TEditOptions );
+ constructor CreateRichEdit1( AParent: PControl; AOptions: TEditOptions );
+ constructor CreateProgressbar( AParent: PControl );
+ constructor CreateProgressbarEx( AParent: PControl; AOptions: TProgressbarOptions );
+ constructor CreateListView( AParent: PControl; AStyle: TListViewStyle; AOptions: TListViewOptions;
+ {} AImageListSmall, AImageListNormal, AImageListState: PImageList );
+ constructor CreateTreeView( AParent: PControl; AOptions: TTreeViewOptions;
+ {} AImgListNormal, AImgListState: PImageList );
+ constructor CreateTabControl( AParent: PControl; ATabs: array of String;
+ {}AOptions: TTabControlOptions; AImgList: PImageList; AImgList1stIdx: Integer );
+ constructor CreateToolbar( AParent: PControl; AAlign: TControlAlign; AOptions: TToolbarOptions;
+ {} ABitmap: HBitmap; AButtons: array of PChar;
+ {} ABtnImgIdxArray: array of Integer );
+ {$ENDIF USE_CONSTRUCTORS}
+
+ {$IFDEF USE_CUSTOMEXTENSIONS}
+ {$I CUSTOM_TCONTROL_EXTENSION.inc}
+ {$ENDIF}
+ // If an option USE_CUSTOMEXTENSIONS is enabled (at the beginning of this
+ // unit), You can freely extend TControl definition by your own fields,
+ // methods and properties. This provides You with capability to extend
+ // TControl implementing another kinds of visual controls without deriving
+ // new descendant objects from TControl. This way is provided to avoid too
+ // large grow of executable size. You also can derive your own controls
+ // from TControl using standard OOP capabilities. In such case an option
+ // USE_CONSTRUCTORS should be turned on (see it at the start of this unit).
+ // If You choose this "flat" model of extending the TControl with your
+ // own properties, fieds, methods, events, etc. You should provide three
+ // inc-files: CUSTOM_TCONTROL_EXTENSION.inc, containing such definitions
+ // for TControl, CUSTOM_KOL_EXTENSION.inc, containing needed global
+ // declarations, and CUSTOM_CODE_EXTENSION.inc, the implementation of those
+ // two.
+ // Because KOL is always grow and constantly is extending by me, I also can
+ // add my own complements for TControl. To avoid naming conflicts, I suggest
+ // to use the same naming rule for all of You. Name your fields, properies, etc.
+ // using a form idx_SomeName, where idx is a prefix, containing several
+ // (at least one) letters and digits. E.g. ZK65_OnSomething.
+
+ protected // rare used fields are moved here from top to make code smaller a bit
+ //fFocusHandle: HWnd; // to store handle of focused control of form ?
+ FParentWnd: HWnd; // <<-- ++ for InitOrthaned !!
+ fParentCoordX: SmallInt;
+ fParentCoordY: SmallInt;
+ {$IFDEF USE_MDI}
+ fMDIClient: PControl;
+ fCreateWindowProc: function(
+ lpClassName, lpWindowName: PKOLChar;
+ dwStyle: DWORD; X, Y, nWidth, nHeight: Integer;
+ hwndParent: HWnd; hInstance: HInst; lParam: Integer ): HWnd;
+ stdcall;
+ {* MDI client window control }
+ {$ENDIF}
+ //fMDIChildren: PList;
+ //{* List of MDI children. It is filled for MDI client window. }
+
+ {$IFDEF USE_fNCDestroyed}
+ {} fNCDestroyed: Boolean;
+ {$ENDIF USE_fNCDestroyed}
+ public
+ {$IFDEF USE_MDI}
+ property MDIClient: PControl read fMDIClient; //Get_MDIClient;
+ {* For MDI forms only: returns MDI client window control, containng all MDI
+ children. Use this window to send specific messages to rule MDI children. }
+ {$ENDIF}
+ {$IFDEF OBSOLETE_FIELDS}
+ {} fPaintLater: Boolean;
+ {$ENDIF OBSOLETE_FIELDS}
+ // last changes (1-Jul-06) from ECM [Michalichenko Eugeny, rest in peace, friend]:
+ //======== ListBox
+ private
+ function GetLBTopIndex: Integer;
+ procedure SetLBTopIndex(const Value: Integer);
+ public
+ function LBItemAtPos(X,Y: Integer): Integer;
+ {* |<#listbox>
+ Return index of item at the given position. }
+ property LBTopIndex: Integer read GetLBTopIndex write SetLBTopIndex;
+ {* |<#listbox>
+ Index of the first visible item in a list box}
+ public
+ //================== RichEdit specific: ==================
+ {$IFNDEF NOT_USE_RICHEDIT}
+ property MaxTextSize: DWORD read GetMaxTextSize write SetMaxTextSize;
+ {* |<#richedit>
+ This property valid also for simple edit control, not only for RichEdit.
+ But for usual edit control, maximum text size available is 32K. For
+ RichEdit, limit is 4Gb. By default, RichEdit is limited to
+ 32767 bytes (to set maximum size available to 2Gb, assign MaxInt value
+ to a property). Also, to get current text size of RichEdit, use property
+ TextSize or RE_TextSize[ ]. }
+ property TextSize: Integer read GetTextSize;
+ {* |<#richedit>
+ Common for edit and rich edit controls property, which returns size of
+ text in edit control. Also, for any other control (or form, or applet
+ window) returns size (in characters) of Caption or Text (what is, the
+ same property actually). }
+ property RE_TextSize[ Units: TRichTextSize ]: Integer read REGetTextSize;
+ {* |<#richedit>
+ For RichEdit control, it returns text size, measured in desired units
+ (rtsChars - characters, including OLE objects, counted as a single
+ character; rtsBytes - presize length of text image (if it would be stored
+ in file or stream). Please note, that for RichEdit1.0, only size in
+ characters can be obtained. }
+ function RE_TextSizePrecise: Integer;
+ {* |<#richedit>
+ By Savva. Returns length of rich edit text. }
+
+ property RE_CharFmtArea: TRichFmtArea read DF.fRECharArea write DF.fRECharArea;
+ {* |<#richedit>
+ By default, this property is raSelection. Changing it, You determine in
+ for which area characters format is applyed, when changing
+ character formatting properties below (not paragraph formatting).
+ |&A=<a href=#RE_CharFmtArea target=main>%0</a>
+ }
+ property RE_CharFormat: TCharFormat read REGetCharformat write RESetCharFormat;
+ {* |<#richedit>
+ In differ to follow properties, which allow to control certain formatting
+ attributes, this property provides low level access for formatting current
+ character area (see RE_CharFmtArea). It returns TCharFormat structure,
+ filled in with formatting attributes, and by assigning another value to
+ this property You can change desired attributes as You wish. Even if
+ RichEdit1.0 is used, TCharFormat2 is returned (but extended fields are
+ ignored for RichEdit1.0). }
+ property RE_Font: PGraphicTool read REGetFont write RESetFont;
+ {* |<#richedit>
+ Font of the first character in current selection (when retrieve).
+ When set (or subproperties of RE_Font are set), all font attributes are
+ applied to entire <A area>. To apply only needed attributes, use another
+ properties: RE_FmtBold, RE_FmtItalic, RE_FmtStrikeout, RE_FmtUnderline,
+ RE_FmtName, etc.
+ |<br>
+ Note, that font size is measured in twips, which is about 1/10 of pixel. }
+ property RE_FmtBold: Boolean index CFM_BOLD read REGetFontEffects write RESetFontEffect;
+ {* |<#richedit>
+ Formatting flag. When retrieve, returns True, if fsBold style RE_Font.FontStyle
+ is valid for a first character in the selection. When set, changes fsBold
+ style (True - set, False - reset) for all characters in <A area>. }
+ property RE_FmtBoldValid: Boolean index CFM_BOLD read REGetFontMask;
+ {* }
+ property RE_FmtItalic: Boolean index CFM_ITALIC read REGetFontEffects write RESetFontEffect;
+ {* |<#richedit>
+ Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsItalic
+ style valid for the first character of the selection, and when set, changes
+ only fsItalic style for an <A area>. }
+ property RE_FmtItalicValid: Boolean index CFM_ITALIC read REGetFontMask;
+ {* }
+ property RE_FmtStrikeout: Boolean index CFM_STRIKEOUT read REGetFontEffects write RESetFontEffect;
+ {* |<#richedit>
+ Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsStrikeout
+ style valid for the first selected character, and when set, changes only
+ fsStrikeout style for an <A area>. }
+ property RE_FmtStrikeoutValid: Boolean index CFM_STRIKEOUT read REGetFontMask;
+ {* }
+ property RE_FmtUnderline: Boolean index CFM_UNDERLINE read REGetFontEffects write RESetFontEffect;
+ {* |<#richedit>
+ Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsUnderline
+ style valid for the first selected character, and when set, changes
+ fsUnderline style for an <A area>. }
+ property RE_FmtUnderlineValid: Boolean index CFM_UNDERLINE read REGetFontMask;
+ {* }
+ property RE_FmtUnderlineStyle: TRichUnderline
+ read REGetUnderlineEx write RESetUnderlineEx;
+ {* |<#richedit>
+ Extended underline style. To check, if this property is valid for
+ entire selection, examine RE_FmtUnderlineValid value. }
+ property RE_FmtProtected: Boolean index CFM_PROTECTED read REGetFontEffects write RESetFontEffect;
+ {* |<#richedit>
+ Formatting flag. When retrieving, shows, is the first character of the selection
+ is protected from changing it by user (True) or not (False). To get know,
+ if retrived value is valid for entire selection, check the property
+ RE_FmtProtectedValid. When set, makes all characters in <A area> protected (
+ True) or not (False). }
+ property RE_FmtProtectedValid: Boolean index CFM_PROTECTED read REGetFontMask;
+ {* |<#richedit>
+ True, if property RE_FmtProtected is valid for entire selection, when
+ retrieving it. }
+ property RE_FmtHidden: Boolean index CFM_HIDDEN read REGetFontEffects write RESetFontEffect;
+ {* |<#richedit>
+ For RichEdit3.0, makes text hidden (not displayed). }
+ property RE_FmtHiddenValid: Boolean index CFM_HIDDEN read REGetFontMask;
+ {* |<#richedit>
+ Returns True, if RE_FmtHidden style is valid for entire selection. }
+
+ property RE_FmtLink: Boolean index $20 {CFM_LINK} read REGetFontEffects write RESetFontEffect;
+ {* |<#richedit>
+ Returns True, if the first selected character is a part of link (URL). }
+ // by Sergey Shisminzev
+
+ property RE_FmtLinkValid: Boolean index $20 {CFM_LINK} read REGetFontMask;
+ {* }
+ property RE_FmtFontSize: Integer index (12 shl 16) or CFM_SIZE read REGetFontAttr write RESetFontAttr;
+ {* |<#richedit>
+ Formatting value: font size, in twips (1/1440 of an inch, or 1/20 of a
+ printer's point, or about 1/10 of pixel). When retrieving, returns
+ RE_Font.FontHeight.
+ When set, changes font size for entire <A area> (but does not change
+ other font attributes). }
+ property RE_FmtFontSizeValid: Boolean read REGetFontSizeValid;
+ {* |<#richedit>
+ Returns True, if property RE_FmtFontSize is valid for entire selection,
+ when retrieving it. }
+ property RE_FmtAutoBackColor: Boolean index CFM_BACKCOLOR read REGetFontEffects write RESetFontEffect;
+ {* |<#richedit>
+ True, when automatic back color is used. }
+ property RE_FmtAutoBackColorValid: Boolean index CFM_BACKCOLOR read REGetFontMask;
+ {* }
+ property RE_FmtFontColor: Integer index (20 shl 16) or CFM_COLOR read REGetFontAttr write RESetFontAttr1;
+ {* |<#richedit>
+ Formatting value (font color). When retrieving, returns RE_Font.Color.
+ When set, changes font color for entire <A area> (but does not change
+ other font attributes). }
+ property RE_FmtFontColorValid: Boolean index CFM_COLOR read REGetFontMask;
+ {* |<#richedit>
+ Returns True, if property RE_FmtFontColor valid for entire selection,
+ when retrieving it. }
+ property RE_FmtAutoColor: Boolean index CFM_COLOR read REGetFontEffects write RESetFontEffect;
+ {* |<#richedit>
+ True, when automatic text color is used (in such case, RE_FmtFontColor
+ assignment is ignored for current area). }
+ property RE_FmtAutoColorValid: Boolean index CFM_COLOR read REGetFontMask;
+ {* }
+ property RE_FmtBackColor: Integer index ((64
+ {$IFDEF UNICODE_CTRLS} + 32 {$ENDIF}
+ ) shl 16) or CFM_BACKCOLOR read REGetFontAttr write RESetFontAttr1;
+ {* |<#richedit>
+ Formatting value (back color). Only available for Rich Edit 2.0 and higher.
+ When set, changes background color for entire <A area> (but does not change
+ other font attributes). }
+ property RE_FmtBackColorValid: Boolean index CFM_BACKCOLOR read REGetFontMask;
+ {* }
+ property RE_FmtFontOffset: Integer index (16 shl 16) or CFM_OFFSET read REGetFontAttr write RESetFontAttr;
+ {* |<#richedit>
+ Formatting value (font vertical offset from baseline, positive values
+ correspond to subscript). When retrieving, returns offset for first
+ character in the selection. When set, changes font offset for entire
+ <A area>. To get know, is retrieved value valid for entire selction,
+ check RE_FmtFontOffsetValid property. }
+ property RE_FmtFontOffsetValid: Boolean index CFM_OFFSET read REGetFontMask;
+ {* |<#richedit>
+ Returns True, if property RE_FmtFontOffset is valid for entire selection,
+ when retrieving it. }
+ property RE_FmtFontCharset: Integer index (25 shl 16) or CFM_CHARSET read REGetFontAttr write RESetFontAttr;
+ {* |<#richedit>
+ Returns charset for first character in current selection, when retrieved
+ (and to get know, if this value is valid for entire selection, check
+ property RE_FmtFontCharsetValid). When set, changes charset for all
+ characters in <A area>, but does not alter other formatting attributes. }
+ property RE_FmtFontCharsetValid: Boolean index CFM_CHARSET read REGetFontMask;
+ {* |<#richedit>
+ Returns True, only if rerieved property RE_FmtFontCharset is valid for
+ entire selection. }
+ property RE_FmtFontName: KOLString read REGetFontName write RESetFontName;
+ {* |<#richedit>
+ Returns font face name for first character in the selection, when retrieved,
+ and sets font name for entire <A area>, wnen assigned to (without
+ changing of other formatting attributes). To get know, if retrived
+ font name valid for entire selection, examine property RE_FmtFontNameValid. }
+ property RE_FmtFontNameValid: Boolean index CFM_FACE read REGetFontMask;
+ {* |<#richedit>
+ Returns True, only if the font name is the same for entire selection,
+ thus is, if rerieved property value RE_FmtFontName is valid for entire
+ selection. }
+
+ property RE_ParaFmt: TParaFormat read REGetParaFmt write RESetParaFmt;
+ {* |<#richedit>
+ Allows to retrieve or set paragraph formatting attributes for currently
+ selected paragraph(s) in RichEdit control. See also following properties,
+ which allow to do the same for certain paragraph format attributes
+ separately. }
+ property RE_TextAlign: TRichTextAlign read REGetTextAlign write RESetTextAlign;
+ {* |<#richedit>
+ Returns text alignment for current selection and allows to change it
+ (without changing other formatting attributes). }
+ property RE_TextAlignValid: Boolean index PFM_ALIGNMENT read REGetParaAttrValid;
+ {* |<#richedit>
+ Returns True, if property RE_TextAlign is valid for entire selection. If
+ False, it is concerning only start of selection. }
+ property RE_Numbering: Boolean read REGetNumbering write RESetNumbering;
+ {* |<#richedit>
+ Returns True, if selected text is numbered (or has style of list with
+ bullets). To get / change numbering style, see properties
+ RE_NumStyle and RE_NumBrackets. }
+ property RE_NumStyle: TRichNumbering read REGetNumStyle write RESetNumStyle;
+ {* |<#richedit>
+ Advanced numbering style, such as rnArabic etc. If You use it, do not
+ change RE_Numbering property simultaneously - this can cause changing
+ style to rnBullets only. }
+ property RE_NumStart: Integer read REGetNumStart write RESetNumStart;
+ {* |<#richedit>
+ Starting number for advanced numbering style. If this property is not
+ set, numbering is starting by default from 0. For rnLRoman and rnURoman
+ this cause, that first item has no number to be shown (ancient Roman
+ people did not invent '0'). }
+ property RE_NumBrackets: TRichNumBrackets read REGetNumBrackets write RESetNumBrackets;
+ {* |<#richedit>
+ Brackets style for advanced numbering. rnbPlain is default
+ brackets style, and every time, when RE_NumStyle is changed,
+ RE_NumBrackets is reset to rnbPlain. }
+ property RE_NumTab: Integer read REGetNumTab write RESetNumTab;
+ {* |<#richedit>
+ Tab between start of number and start of paragraph text. If too small too
+ view number, number is not displayed. (Default value seems to be sufficient
+ though). }
+ property RE_NumberingValid: Boolean index PFM_NUMBERING read REGetParaAttrValid;
+ {* |<#richedit>
+ Returns True, if RE_Numbering, RE_NumStyle, RE_NumBrackets, RE_NumTab,
+ RE_NumStart properties are valid for entire selection. }
+ property RE_Level: Integer read REGetLevel;
+ {* |<#richedit>
+ Outline level (for numbering paragraphs?). Read only. }
+ property RE_SpaceBefore: Integer index 0 or PFM_SPACEBEFORE read REGetSpacing write RESetSpacing;
+ {* |<#richedit>
+ Spacing before paragraph. }
+ property RE_SpaceBeforeValid: Boolean index PFM_SPACEBEFORE read REGetParaAttrValid;
+ {* |<#richedit>
+ True, if RE_SpaceBefore value is valid for all selected paragraph (if
+ False, this value is valid only for first paragraph. }
+ property RE_SpaceAfter: Integer index 4 or PFM_SPACEAFTER read REGetSpacing write RESetSpacing;
+ {* |<#richedit>
+ Spacing after paragraph. }
+ property RE_SpaceAfterValid: Boolean index PFM_SPACEAFTER read REGetParaAttrValid;
+ {* |<#richedit>
+ True, only if RE_SpaceAfter value is valid for all selected paragraphs. }
+ property RE_LineSpacing: Integer index 8 or PFM_LINESPACING read REGetSpacing write RESetSpacing;
+ {* |<#richedit>
+ Linespacing in paragraph (this value is based on RE_SpacingRule property). }
+ property RE_SpacingRule: Integer read REGetSpacingRule write RESetSpacingRule;
+ {* |<#richedit>
+ Linespacing rule. Do not know what is it. }
+ property RE_LineSpacingValid: Boolean index PFM_LINESPACING read REGetParaAttrValid;
+ {* |<#richedit>
+ True, only if RE_LineSpacing and RE_SpacingRule values are valid for
+ entire selection. }
+ property RE_Indent: Integer index (20 shl 16) or PFM_OFFSET read REGetParaAttr write RESetParaAttr;
+ {* |<#richedit>
+ Returns left indentation for paragraph in current selection and allows
+ to change it (without changing other formatting attributes). }
+ property RE_IndentValid: Boolean index PFM_OFFSET read REGetParaAttrValid;
+ {* |<#richedit>
+ Returns True, if RE_Indent property is valid for entire selection. }
+ property RE_StartIndent: Integer index (12 shl 16) or PFM_STARTINDENT read REGetParaAttr write RESetParaAttr;
+ {* |<#richedit>
+ Returns left indentation for first line in paragraph for current
+ selection, and allows to change it (without changing other formatting
+ attributes). }
+ property RE_StartIndentValid: Boolean read REGetStartIndentValid;
+ {* |<#richedit>
+ Returns True, if property RE_StartIndent is valid for entire selection. }
+ property RE_RightIndent: Integer index (16 shl 16) or PFM_RIGHTINDENT read REGetParaAttr write RESetParaAttr;
+ {* |<#richedit>
+ Returns right indent for paragraph in current selection, and allow to
+ change it (without changing other formatting attributes). }
+ property RE_RightIndentValid: Boolean index PFM_RIGHTINDENT read REGetParaAttrValid;
+ {* |<#richedit>
+ Returns True, if property RE_RightIndent is valid for entire selection only. }
+ property RE_TabCount: Integer read REGetTabCount write RESetTabCount;
+ {* |<#richedit>
+ Number of tab stops in current selection. This value can not be set greater
+ then MAX_TAB_COUNT (32). }
+ property RE_Tabs[ Idx: Integer ]: Integer read REGetTabs write RESetTabs;
+ {* |<#richedit>
+ Tab stops for RichEdit control. }
+ property RE_TabsValid: Boolean index PFM_TABSTOPS read REGetParaAttrValid;
+ {* |<#richedit>
+ Returns True, if properties RE_Tabs[ ] and RE_TabCount are valid for
+ entire selection. }
+
+ // following does not work now :
+ property RE_BorderWidth[ Side: TBorderEdge ]: Integer index 2 read REGetBorder write RESetBorder;
+ { * |<#richedit>
+ Border width. }
+ property RE_BorderSpace[ Side: TBorderEdge ]: Integer index 0 read REGetBorder write RESetBorder;
+ { * |<#richedit>
+ Border space. }
+ property RE_BorderStyle[ Side: TBorderEdge ]: Integer index 4 read REGetBorder write RESetBorder;
+ { * |<#richedit>
+ Border style. }
+ property RE_BorderValid: Boolean index PFM_BORDER read REGetParaAttrValid;
+ { * |<#richedit>
+ Returns True, if border style, space and width are the same for all
+ paragraphs in selection. }
+ property RE_Table: Boolean index $C000 read REGetParaEffect write RESetParaEffect;
+ { * |<#richedit>
+ True, if current paragraph is a part of table (row, cell or cell end).
+ seems working as read only property. }
+ // end of experiment section
+
+ function RE_FmtStandard: PControl;
+ {* |<#richedit>
+ "Transparent" method (returns @Self as a result), which (when called)
+ provides "standard" keyboard interface for formatting Rich text (just
+ call this method, for example:
+ ! RichEd1 := NewRichEdit( Panel1, [ ] ).SetAlign( caClient ).RE_FmtStandard;
+ Following keys will be maintained additionally:
+ |<pre>
+ CTRL+I - switch "Italic",
+ CTRL+B - switch "Bold",
+ CTRL+U - switch "Underline",
+ CTRL+SHIFT+U - swith underline type
+ and turn underline on (note, that some of underline styles
+ can not be shown properly in RichEdit v2.0 and lower,
+ though RichEdit2.0 stores data successfully).
+ CTRL+O - switch "StrikeOut",
+ CTRL+'gray+' - increase font size,
+ CTRL+'gray-' - decrease font size,
+ CTRL+SHIFT+'gray+' - superscript,
+ CTRL+SHIFT+'gray-' - subscript.
+ CTRL+SHIFT+Z - ReDo
+ |</pre>
+ And, though following standard formatting keys are provided by RichEdit
+ control itself in Windows2000, some of these are not functioning
+ automatically in earlier Windows versions, even for RichEdit2.0. So,
+ functionality of some of these (marked with (*) ) are added here too:
+ |<pre>
+ CTRL+L - align paragraph left, (*)
+ CTRL+R - align paragraph right, (*)
+ CTRL+E - align paragraph center, (*)
+ CTRL+A - select all, (*)
+ double-click on word - select word,
+ CTRL+Right - to next word,
+ CTRL+Left - to previous word,
+ CTRL+Home - to the beginning of text,
+ CTRL+End - to the end of text.
+ CTRL+Z - UnDo
+ |</pre>
+ If You originally assign some (plain) text to Text property, switching "underline"
+ can also change other font attributes, e.g., "bold" - if fsBold style is
+ in default Font. To prevent such behavior, select entire text first (see
+ SelectAll) and make assignment to RE_Font property, e.g.:
+ ! RichEd1.SelectAll;
+ ! RichEd1.RE_Font := RichEd1.RE_Font;
+ ! RichEd1.SelLength := 0;
+ |<br>
+ And, some other notices about formatting. Please remember, that only True
+ Type fonts can be succefully scaled and transformed to get desired effects
+ (e.g., bold). By default, RichEdit uses System font face name, which can
+ even have problems with fsBold style. Please remember also, that assigning
+ RE_Font to RE_Font just initializying formatting attributes, making all
+ those valid in entire text, but does not change font attributes. To use
+ True Type font, directly assign face name You wish, e.g.:
+ ! RichEd1.SelectAll;
+ ! RichEd1.RE_Font := RichEd1.RE_Font;
+ ! RichEd1.RE_Font.FontName := 'Arial';
+ ! RichEd1.SelLength := 0;
+ }
+ procedure RE_CancelFmtStandard;
+ {* Cancels RE_FmtStandard (detaching window procedure handler). }
+ property RE_AutoKeyboard: Boolean index 1 read REGetLangOptions write RESetLangOptions;
+ {* |<#richedit>
+ True if autokeyboard on (lovely "feature" of automatic switching keyboard
+ language when caret is over another language text). For older RichEdit,
+ is 'on' always, for newest - 'off' by default. }
+ property RE_AutoFont: Boolean index 2 read REGetLangOptions write RESetLangOptions;
+ {* |<#richedit>
+ True if autofont on (automatic switching font when keyboard layout is
+ changes). By default, is 'on' always. It is suggested to turn this option
+ off for Unicode control. }
+ property RE_AutoFontSizeAdjust: Boolean index 16 read REGetLangOptions write RESetLangOptions;
+ {* |<#richedit>
+ See IMF_AUTOFONTSIZEADJUST option in SDK:
+ Font-bound font sizes are scaled from insertion point size according to
+ script. For example, Asian fonts are slightly larger than Western ones.
+ This option is turned on by default. }
+ property RE_DualFont: Boolean index 128 read REGetLangOptions write RESetLangOptions;
+ {* |<#richedit>
+ See IMF_DUALFONT option in SDK:
+ Sets the control to dual-font mode. Used for Asian language support.
+ The control uses an English font for ASCII text and a Asian font for
+ Asian text. }
+ property RE_UIFonts: Boolean index 32 read REGetLangOptions write RESetLangOptions;
+ {* |<#richedit>
+ See IMF_UIFONTS option in SDK:
+ Use user-interface default fonts. This option is turned off by default. }
+ property RE_IMECancelComplete: Boolean index 4 read REGetLangOptions write RESetLangOptions;
+ {* |<#richedit>
+ See IMF_IMECANCELCOMPLETE option in SDK:
+ This flag determines how the control uses the composition string of an
+ IME if the user cancels it. If this flag is set, the control discards
+ the composition string. If this flag is not set, the control uses the
+ composition string as the result string. }
+ property RE_IMEAlwaysSendNotify: Boolean index 8 read REGetLangOptions write RESetLangOptions;
+ {* |<#richedit>
+ See IMF_IMEALWAYSSENDNOTIFY option in SDK:
+ Controls how Rich Edit notifies the client during IME composition:
+ |<br>
+ 0: No EN_CHANGED or EN_SELCHANGE notifications during undetermined state.
+ Send notification when final string comes in. (default)
+ |<br>
+ 1: Send EN_CHANGED and EN_SELCHANGE events during undetermined state. }
+
+ property RE_OverwriteMode: Boolean read REGetOverwite write RESetOverwrite;
+ {* |<#richedit>
+ This property allows to control insert/overwrite mode. First, to examine, if
+ insert or overwrite mode is current (but it is necessary either to
+ access this property, at least once, immediately after creating RichEdit
+ control, or to assign event OnRE_InsOvrMode_Change to your handler).
+ Second, to set desired mode programmatically - by assigning value to
+ this property (You also have to initialize monitoring procedure by either
+ reading RE_OverwriteMode property or assigning handler to event
+ OnRE_InsOvrMode_Change immediately following RichEdit control creation). }
+ property OnRE_InsOvrMode_Change: TOnEvent index idx_FOnREInsModeChg
+ read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnREInsModeChg {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnREInsModeChg {$ENDIF};
+ {* |<#richedit>
+ This event is called, whenever key INSERT is pressed in control (and for
+ RichEdit, this means, that insert mode is changed). }
+ property RE_DisableOverwriteChange: Boolean read DF.fReOvrDisable write RESetOvrDisable;
+ {* |<#richedit>
+ It is possible to disable switching between "insert" and "overwrite" mode
+ by user (therefore, event OnRE_InsOvrMode_Change continue works, but it
+ just called when key INSERT is pressed, though RE_OverwriteMode property
+ is not actually changed if switching is disabled). }
+
+ function RE_LoadFromStream( Stream: PStream; Length: Integer;
+ {} Format: TRETextFormat; SelectionOnly: Boolean ): Boolean;
+ {* |<#richedit>
+ Use this method rather then assignment to RE_Text property, if
+ source is stored in file or stream (to minimize resources during
+ loading of RichEdit content). Data is loading starting from current
+ position in stream and no more then Length bytes are loaded (use -1
+ value to load to the end of stream). Loaded data replaces entire
+ content of RichEdit control, or selection only, depending on SelectionOnly
+ flag.
+ |<br>
+ If You want to provide progress (e.g. in form of progress bar), assign
+ OnProgress event to your handler - and to examine current position of
+ loading, read TSream.Position property of soiurce stream). }
+ function RE_SaveToStream( Stream: PStream; Format: TRETextFormat; SelectionOnly: Boolean ): Boolean;
+ {* |<#richedit>
+ Use this method rather then RE_TextProperty to store data to file
+ or stream (to minimize resources during saving of RichEdit content).
+ Data is saving starting from current position in a stream (until
+ end of RichEdit data). If SelectionOnly flag is True, only selected
+ part of RichEdit text is saved.
+ |<br>
+ Like for RE_LoadFromStream, it is possible to assign your method to
+ OnProgress event (but to calculate progress of save-to-stream operation,
+ compare current stream position with RE_Size[ rsBytes ] property
+ value). }
+
+ property OnProgress: TOnEvent index idx_FOnProgress
+ read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnProgress {$ENDIF}
+ write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnProgress {$ENDIF};
+ {* |<#richedit>
+ This event is called during RE_SaveToStream, RE_LoadFromStream (and also
+ during RE_SaveToFile, RE_LoadFromFile and while accessing or changing
+ RE_Text property). To calculate relative progress, it is possible to
+ examine current position in stream/file with its total size while reading,
+ or with rich edit text size, while writing (property RE_TextSize[ rsBytes ]).
+ }
+ function RE_LoadFromFile( const Filename: KOLString; Format: TRETextFormat;
+ {} SelectionOnly: Boolean ): Boolean;
+ {* |<#richedit>
+ Use this method rather then other assignments to RE_Text property,
+ if a source for RichEdit is the file. See also RE_LoadFromStream. }
+ function RE_SaveToFile( const Filename: KOLString; Format: TRETextFormat;
+ {} SelectionOnly: Boolean ): Boolean;
+ {* |<#richedit>
+ Use this method rather then other similar, if You want to store
+ entire content of RichEdit or selection only of RichEdit to a file. }
+
+ property RE_Text[ Format: TRETextFormat; SelectionOnly: Boolean ]: KOLString read REReadText write REWriteText;
+ {* |<#richedit>
+ This property allows to get / replace content of RichEdit control
+ (entire text or selection only). Using different formats, it is
+ possible to exclude or replace undesired formatting information
+ (see TRETextFormat specification). To get or replace entire text
+ in reText mode (plain text only), it is possible to use habitual
+ for edit controls Text property.
+ |<br>
+ Note: it is possible to append text to the end of RichEdit control
+ using method Add, but only if property RE_Text is accessed at least
+ once:
+ ! RichEdit1.RE_Text[ reText, True ];
+ (This line can be written immediatelly after creating RichEdit control). }
+
+ procedure RE_Append( const S: KOLString; ACanUndo: Boolean );
+ {* }
+ procedure RE_InsertRTF( const S: KOLString );
+ {* }
+ property RE_Error: Integer read DF.fREError;
+ {* |<#richedit>
+ Contains error code, if access to RE_Text failed. }
+
+ procedure RE_HideSelection( aHide: Boolean );
+ {* |<#richedit>
+ Allows to hide / show selection in RichEdit. }
+
+ function RE_SearchText( const Value: KOLString; MatchCase, WholeWord, ScanForward: Boolean;
+ SearchFrom, SearchTo: Integer ): Integer;
+ {* |<#richedit>
+ Searches given string starting from SearchFrom position up to SearchTo
+ position (to the end of text, if SearchTo is -1). Returns zero-based
+ character position of the next match, or -1 if there are no more matches.
+ To search in bacward direction, set ScanForward to False, and pass
+ SearchFrom > SearchTo (or even SearchFrom = -1 and SearchTo = 0). }
+ {$IFNDEF DISABLE_DEPRECATED}
+ {$IFNDEF _FPC}
+ {$IFNDEF _D2} //------- KOLWideString not supported in D2
+ function RE_WSearchText( const Value: KOLWideString; MatchCase, WholeWord, ScanForward: Boolean;
+ SearchFrom, SearchTo: Integer ): Integer;
+ {* |<#richedit>
+ Searches given string starting from SearchFrom position up to SearchTo
+ position (to the end of text, if SearchTo is -1). Returns zero-based
+ character position of the next match, or -1 if there are no more matches.
+ To search in bacward direction, set ScanForward to False, and pass
+ SearchFrom > SearchTo (or even SearchFrom = -1 and SearchTo = 0). }
+ {$ENDIF}
+ {$ENDIF}
+ {$ENDIF DISABLE_DEPRECATED}
+
+ property RE_AutoURLDetect: Boolean read REGetAutoURLDetect write RESetAutoURLDetect;
+ {* |<#richedit>
+ If set to True, automatically detects URLs (and highlights it with
+ blue color, applying fsItalic and fsUnderline font styles (while
+ typing and loading). Default value is False. Note: if event OnRE_URLClick
+ or event OnRE_OverURL are set, property RE_AutoURLDetect is set to True
+ automatically. }
+
+ property RE_URL: PKOLChar read DF.fREUrl;
+ {* |<#richedit>
+ Detected URL (valid in OnRE_OverURL and OnRE_URLClick event handlers). }
+ property OnRE_OverURL: TOnEvent index 0 read {$IFDEF EVENTS_DYNAMIC} REGetOnURL {$ELSE}
+ {$IFDEF F_P} REGetOnURL
+ {$ELSE DELPHI} EV.fOnREOverURL
+ {$ENDIF F_P/DELPHI} {$ENDIF} write RESetOnURL;
+ {* |<#richedit>
+ Is called when mouse is moving over URL. This can be used to set
+ cursor, for example, depending on type of URL (to determine URL type
+ read property RE_URL). }
+ property OnRE_URLClick: TOnEvent index 8 read {$IFDEF EVENTS_DYNAMIC} REGetOnURL {$ELSE}
+ {$IFDEF F_P} REGetOnURL
+ {$ELSE DELPHI} EV.fOnREURLClick
+ {$ENDIF F_P/DELPHI} {$ENDIF} write RESetOnURL;
+ {* |<#richedit>
+ Is called when click on URL detected. }
+
+ //property RE_SelectionBar: Boolean read REGetSelectionBar write RESetSelectionBar;
+ //{* ??? - don't know that is this... }
+ function RE_NoOLEDragDrop: PControl;
+ {* |<#richedit>
+ Just prevents drop OLE objects to the rich edit control. Seems not
+ working for some cases. }
+
+ //function RE_Wyswig: PControl;
+
+ function RE_Bottomless: PControl;
+ // finished ?
+
+ property RE_Transparent: Boolean read REGetTransparent write RESetTransparent;
+ {* |<#richedit>
+ Use this property to make richedit control transparent, instead of
+ Ed_Transparent or Transparent. But do not place such transparent
+ richedit control directly on form - it can be draw incorrectly when
+ form is activated and rich editr control is not current active control.
+ Use at least panel as a parent instead.
+ }
+ property RE_Zoom: TSmallPoint read REGetZoom write RESetZoom;
+ {* |<#richedit>
+ To set zooming for rich edit control (3.0 and above), pass X as numerator
+ and Y as denominator. Resulting X/Y must be between 1/64 and 64. }
+ {$ENDIF NOT_USE_RICHEDIT}
+
+ //========== both for Edit and RichEdit: =====================
+ function CanUndo: Boolean;
+ {* |<#richedit>
+ |<#edit>
+ |<#memo>
+ Returns True, if the edit (or RichEdit) control can correctly process
+ the EM_UNDO message. }
+ procedure EmptyUndoBuffer;
+ {* |<#richedit>
+ |<#edit>
+ |<#memo>
+ Reset the undo flag of an edit control, preventing undoing all previous
+ changes. }
+ function Undo: Boolean;
+ {* |<#richedit>
+ |<#edit>
+ |<#memo>
+ For a single-line edit control, the return value is always TRUE. For a
+ multiline edit control and RichEdit control, the return value is TRUE if
+ the undo operation is successful, or FALSE if the undo operation fails. }
+
+ public
+ property PropInt[ PropName: PKOLChar ]: Integer read Get_Prop_Int write Set_Prop_Int;
+ {* For any windowed control: use it to store desired property in window
+ properties. }
+ {$IFNDEF NOT_USE_RICHEDIT}
+ function RE_Redo: Boolean;
+ procedure FreeCharFormatRec;
+ {* |<#richedit>
+ Only for RichEdit control: Returns True if successful. }
+ {$ENDIF NOT_USE_RICHEDIT}
+ public
+ aAutoSzX: Byte;
+ aAutoSzY: Byte;
+ protected
+ fAlign: TControlAlign;
+ fAligning:TAlignings;
+{$ENDIF GDI}
+ public
+ property Align: TControlAlign read FAlign write Set_Align;
+ {* Align style of a control. If this property is not used in your
+ application, there are no additional code added. Aligning of
+ controls is made in KOL like in VCL. To align controls when
+ initially create ones, use "transparent" function SetAlign
+ ("transparent" means that it returns @Self as a result).
+ |<br>
+ Note, that it is better not to align combobox caClient, caLeft or
+ caRight (better way is to place a panel with Border = 0 and
+ EdgeStyle = esNone, align it as desired and to place a combobox on it
+ aligning caTop or caBottom). Otherwise, big problems could be under
+ Win9x/Me, and some delay could occur under any other systems.
+ |<br> Do not attempt to align some kinds of controls (like combobox)
+ caLeft or caRight, this can cause infinite recursion. }
+ property SizeRedraw: Boolean
+ read {$IFDEF USE_FLAGS} Get_SizeRedraw {$ELSE} fSizeRedraw {$ENDIF}
+ write {$IFDEF USE_FLAGS} Set_SizeRedraw {$ELSE} fSizeRedraw {$ENDIF};
+ procedure ResetEvent( idx: Integer );
+ {$IFDEF FINAL_MARKER}
+ protected
+ ffinal_offset: Boolean;
+ {$ENDIF}
+ end;
+
+ {$IFDEF USE_MHTOOLTIP}
+ {$DEFINE interface_part}
+ {$I KOLMHToolTip_interface.inc}
+ {$UNDEF interface_part}
+ {$ENDIF}
+
+ {$IFDEF USE_MHTOOLTIP}
+ {$DEFINE interface_2}
+ {$I KOLMHToolTip_intf2.inc}
+ {$UNDEF interface_2}
+ {$ENDIF}
+
+{$IFDEF EVENTS_DYNAMIC}
+var EmptyEvents: TEvents;
+{$ENDIF}
+
+function DummyProc123_TRUE( Dummy: Pointer; Sender: PControl; param3: Integer ): Boolean;
+function DummyProc123_0( Dummy: Pointer; Sender: PObj; param3: Integer ): Integer;
+function DummyProc4_TRUE( Dummy: Pointer; Sender: PControl; p3, p4: Integer ): Boolean;
+function DummyProc5_TRUE( Dummy: Pointer; Sender: PControl; p3, p4, p5: Integer ): Boolean;
+procedure DummyOnLVDataProc( Dummy: Pointer; Sender: PControl; Idx, SubItem: Integer;
+ var Txt: KOL_String; var ImgIdx: Integer; var State: DWORD;
+ var Store: Boolean );
+function DummyProc4_0( Dummy: Pointer; Sender: PControl; p3, p4: Integer ): Integer;
+function DummyOnDrawItemProc( Dummy:Pointer; Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer;
+ DrawAction: TDrawAction; ItemState: TDrawState ): Boolean;
+function DummyOnLVCustomDrawProc( Dummy: Pointer; Sender: PControl; DC: HDC; Stage: DWORD;
+ ItemIdx, SubItemIdx: Integer; const Rect: TRect;
+ ItemState: TDrawState; var TextColor, BackColor: TColor ): DWORD;
+function DummyOnSBBeforeScrollProc(Dummy: Pointer; Sender: PControl;
+ OldPos, NewPos: Integer; Cmd: Word; var AllowChange: Boolean): Boolean;
+
+{$IFDEF USE_GRAPHCTLS}
+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;
+{$IFDEF _D4orHigher}
+function FormNewTabControl( Form: PControl ): PControl;
+{$ENDIF}
+
+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 );
+{$IFDEF _D4orHigher}
+procedure FormTBSetTooltips( Form: PControl );
+{$ENDIF}
+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 );
+// scrolbar
+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 );
+
+
+{$IFDEF WIN_GDI}
+function ToolbarButtonRect( Toolbar: PControl; BtnID: Integer ): TRect;
+{* Use this function instead of reading TControl.TBButtonRect, if you want
+ to have it working the same way when standard toolbar is used or GRushControl
+ toolbar provided in ToGRush.pas unit.
+}
+procedure ToolbarSetTooltips( Toolbar: PControl; BtnID1st: Integer; const Tooltips: array of PKOLChar );
+{* Use this function instead of TContol.TBSetTooltips in your project, when
+ you use ToGRush unit.
+}
+function ToolbarButtonEnabled( Toolbar: PControl; BtnID: Integer ): Boolean;
+{* Use this function instead of reading the property TControl.TBButtonEnabled
+ when tou use ToGRush unit. }
+procedure EnableToolbarButton( Toolbar: PControl; BtnID: Integer; Enable: Boolean );
+{* Use this procedure instead of writing the property TControl.TBButtonEnabled
+ when you use ToGRush unit. }
+function ToolbarButtonVisible( Toolbar: PControl; BtnID: Integer ): Boolean;
+{* Use this function instead of reading the property TControl.TBButtonVisible
+ when tou use ToGRush unit. }
+procedure ShowHideToolbarButton( Toolbar: PControl; BtnID: Integer; Show: Boolean );
+{* Use this procedure instead of writing the property TControl.TBButtonVisible
+ when you use ToGRush unit. }
+function ToolbarButtonChecked( Toolbar: PControl; BtnID: Integer): Boolean;
+{* }
+procedure ToolbarButtonSetChecked( Toolbar: PControl; BtnID: Integer; Checked: Boolean );
+{* }
+procedure ToolbarAddButtons( Toolbar: PControl; const Buttons: array of PKOLChar;
+ const BtnImgIdxArray: array of Integer; Bitmap: HBitmap );
+{* }
+
+function Scrollbar_GetMinPos( sb: PControl ): Integer;
+procedure Scrollbar_SetMinPos( sb: PControl; m: Integer );
+procedure Scrollbar_SetAll( sb: PControl; min, max, pg, cur: Integer );
+function Scrollbar_GetMaxPos( sb: PControl ): Integer;
+procedure Scrollbar_SetMaxPos( sb: PControl; m: Integer );
+function Scrollbar_GetCurPos( sb: PControl ): Integer;
+procedure Scrollbar_SetCurPos( sb: PControl; newp: Integer );
+procedure Scrollbar_SetPageSz( sb: PControl; psz: Integer );
+function Scrollbar_GetPageSz( sb: PControl ): Integer;
+procedure Scrollbar_SetLineSz( sb: PControl; lnz: Integer );
+function Scrollbar_GetLineSz( sb: PControl ): Integer;
+{$ENDIF WIN_GDI}
+
+var ToolbarsIDcmd: Integer = 100;
+
+type
+ TOnPaintBkgnd = procedure( Sender: PControl; DC: HDC; Rect: PRect );
+ {* Global event definition. Used to define Global_OnPaintBackground
+ event placeholder. }
+
+procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect );
+
+var
+ Global_OnPaintBkgnd: TOnPaintBkgnd = DefaultPaintBackground;
+ {* Global event. It is assigned in XBackgounds.pas add-on to replace
+ PaintBackground method for all TVisual objects, allowing great
+ visualization effect: transparent controls over [animated] bitmap
+ background. Idea:
+ | <a href=mailto:"bw@sunv.com">Wei Bao</a>. Implementation:
+ | <a href=mailto:"bonanzas@xcl.cjb.net">Kladov Vladimir</a>. }
+
+function GetShiftState: DWORD;
+{* Returns shift state. }
+
+{$IFDEF WIN_GDI}
+function WndProcMouse( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+function WndProcKeybd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+function WndProcDummy( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
+function WndProcBtnReturnClick( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+{$ENDIF}
+function AutoMinimizeApplet(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+{* By Sergey Shishmintzev
+ Attach this handler to your modal dialog form handle to provide automatic
+ minimization of all other forms in the application together with the dialog. }
+
+procedure InitCommonControlSizeNotify( Ctrl: PControl );
+procedure InitCommonControlCommonNotify( Ctrl: PControl );
+
+procedure DummyAttachProcExtension ( DynHandlers: PList );
+procedure TransparentAttachProcExtension ( DynHandlers: PList );
+
+{$IFNDEF SMALLEST_CODE}
+var Global_AttachProcExtension: procedure( DynHandlers: PList ) = DummyAttachProcExtension;
+{$ENDIF}
+{$ENDIF WIN_GDI}
+var HelpFilePath: PKOLChar;
+ {* Path to application help file. If not assigned, application path with
+ extension replaced to '.hlp' used. To use '.chm' file (HtmlHelp),
+ call AssignHtmlHelp with a path to a html help file (or a name). }
+
+{$IFDEF WIN_GDI}
+procedure AssignHtmlHelp( const HtmlHelpPath: KOLString );
+procedure HtmlHelpCommand( Wnd: HWnd; const HelpFilePath: KOLString; Cmd, Data: Integer );
+{* Use this wrapper procedure to call HtmlHelp API function. }
+//+++++++++++ HTML HELP DEFINITIONS SECTION:
+// this section is from
+// HTML Help API Interface Unit
+// Copyright (c) 1999 The Helpware Group
+// provided for KOL by Alexey Babenko
+const
+ HH_DISPLAY_TOPIC = $0000; {**}
+ HH_HELP_FINDER = $0000; // WinHelp equivalent
+ HH_DISPLAY_TOC = $0001; // not currently implemented
+ HH_DISPLAY_INDEX = $0002; // not currently implemented
+ HH_DISPLAY_SEARCH = $0003; // not currently implemented
+ HH_SET_WIN_TYPE = $0004;
+ HH_GET_WIN_TYPE = $0005;
+ HH_GET_WIN_HANDLE = $0006;
+ HH_ENUM_INFO_TYPE = $0007; // Get Info type name, call repeatedly to enumerate, -1 at end
+ HH_SET_INFO_TYPE = $0008; // Add Info type to filter.
+ HH_SYNC = $0009;
+ HH_RESERVED1 = $000A;
+ HH_RESERVED2 = $000B;
+ HH_RESERVED3 = $000C;
+ HH_KEYWORD_LOOKUP = $000D;
+ HH_DISPLAY_TEXT_POPUP = $000E; // display string resource id or text in a popup window
+ HH_HELP_CONTEXT = $000F; {**}// display mapped numeric value in dwData
+ HH_TP_HELP_CONTEXTMENU = $0010; // text popup help, same as WinHelp HELP_CONTEXTMENU
+ HH_TP_HELP_WM_HELP = $0011; // text popup help, same as WinHelp HELP_WM_HELP
+ HH_CLOSE_ALL = $0012; // close all windows opened directly or indirectly by the caller
+ HH_ALINK_LOOKUP = $0013; // ALink version of HH_KEYWORD_LOOKUP
+ HH_GET_LAST_ERROR = $0014; // not currently implemented // See HHERROR.h
+ HH_ENUM_CATEGORY = $0015; // Get category name, call repeatedly to enumerate, -1 at end
+ HH_ENUM_CATEGORY_IT = $0016; // Get category info type members, call repeatedly to enumerate, -1 at end
+ HH_RESET_IT_FILTER = $0017; // Clear the info type filter of all info types.
+ HH_SET_INCLUSIVE_FILTER = $0018; // set inclusive filtering method for untyped topics to be included in display
+ HH_SET_EXCLUSIVE_FILTER = $0019; // set exclusive filtering method for untyped topics to be excluded from display
+ HH_INITIALIZE = $001C; // Initializes the help system.
+ HH_UNINITIALIZE = $001D; // Uninitializes the help system.
+ HH_PRETRANSLATEMESSAGE = $00fd; // Pumps messages. (NULL, NULL, MSG*).
+ HH_SET_GLOBAL_PROPERTY = $00fc; // Set a global property. (NULL, NULL, HH_GPROP)
+
+ { window properties }
+
+const
+ HHWIN_PROP_TAB_AUTOHIDESHOW = $00000001; // (1 << 0) Automatically hide/show tri-pane window
+ HHWIN_PROP_ONTOP = $00000002; // (1 << 1) Top-most window
+ HHWIN_PROP_NOTITLEBAR = $00000004; // (1 << 2) no title bar
+ HHWIN_PROP_NODEF_STYLES = $00000008; // (1 << 3) no default window styles (only HH_WINTYPE.dwStyles)
+ HHWIN_PROP_NODEF_EXSTYLES = $00000010; // (1 << 4) no default extended window styles (only HH_WINTYPE.dwExStyles)
+ HHWIN_PROP_TRI_PANE = $00000020; // (1 << 5) use a tri-pane window
+ HHWIN_PROP_NOTB_TEXT = $00000040; // (1 << 6) no text on toolbar buttons
+ HHWIN_PROP_POST_QUIT = $00000080; // (1 << 7) post WM_QUIT message when window closes
+ HHWIN_PROP_AUTO_SYNC = $00000100; // (1 << 8) automatically ssync contents and index
+ HHWIN_PROP_TRACKING = $00000200; // (1 << 9) send tracking notification messages
+ HHWIN_PROP_TAB_SEARCH = $00000400; // (1 << 10) include search tab in navigation pane
+ HHWIN_PROP_TAB_HISTORY = $00000800; // (1 << 11) include history tab in navigation pane
+ HHWIN_PROP_TAB_FAVORITES = $00001000; // (1 << 12) include favorites tab in navigation pane
+ HHWIN_PROP_CHANGE_TITLE = $00002000; // (1 << 13) Put current HTML title in title bar
+ HHWIN_PROP_NAV_ONLY_WIN = $00004000; // (1 << 14) Only display the navigation window
+ HHWIN_PROP_NO_TOOLBAR = $00008000; // (1 << 15) Don't display a toolbar
+ HHWIN_PROP_MENU = $00010000; // (1 << 16) Menu
+ HHWIN_PROP_TAB_ADVSEARCH = $00020000; // (1 << 17) Advanced FTS UI.
+ HHWIN_PROP_USER_POS = $00040000; // (1 << 18) After initial creation, user controls window size/position
+ HHWIN_PROP_TAB_CUSTOM1 = $00080000; // (1 << 19) Use custom tab #1
+ HHWIN_PROP_TAB_CUSTOM2 = $00100000; // (1 << 20) Use custom tab #2
+ HHWIN_PROP_TAB_CUSTOM3 = $00200000; // (1 << 21) Use custom tab #3
+ HHWIN_PROP_TAB_CUSTOM4 = $00400000; // (1 << 22) Use custom tab #4
+ HHWIN_PROP_TAB_CUSTOM5 = $00800000; // (1 << 23) Use custom tab #5
+ HHWIN_PROP_TAB_CUSTOM6 = $01000000; // (1 << 24) Use custom tab #6
+ HHWIN_PROP_TAB_CUSTOM7 = $02000000; // (1 << 25) Use custom tab #7
+ HHWIN_PROP_TAB_CUSTOM8 = $04000000; // (1 << 26) Use custom tab #8
+ HHWIN_PROP_TAB_CUSTOM9 = $08000000; // (1 << 27) Use custom tab #9
+ HHWIN_TB_MARGIN = $10000000; // (1 << 28) the window type has a margin
+
+ { window parameters }
+
+const
+ HHWIN_PARAM_PROPERTIES = $00000002; // (1 << 1) valid fsWinProperties
+ HHWIN_PARAM_STYLES = $00000004; // (1 << 2) valid dwStyles
+ HHWIN_PARAM_EXSTYLES = $00000008; // (1 << 3) valid dwExStyles
+ HHWIN_PARAM_RECT = $00000010; // (1 << 4) valid rcWindowPos
+ HHWIN_PARAM_NAV_WIDTH = $00000020; // (1 << 5) valid iNavWidth
+ HHWIN_PARAM_SHOWSTATE = $00000040; // (1 << 6) valid nShowState
+ HHWIN_PARAM_INFOTYPES = $00000080; // (1 << 7) valid apInfoTypes
+ HHWIN_PARAM_TB_FLAGS = $00000100; // (1 << 8) valid fsToolBarFlags
+ HHWIN_PARAM_EXPANSION = $00000200; // (1 << 9) valid fNotExpanded
+ HHWIN_PARAM_TABPOS = $00000400; // (1 << 10) valid tabpos
+ HHWIN_PARAM_TABORDER = $00000800; // (1 << 11) valid taborder
+ HHWIN_PARAM_HISTORY_COUNT = $00001000; // (1 << 12) valid cHistory
+ HHWIN_PARAM_CUR_TAB = $00002000; // (1 << 13) valid curNavType
+
+ { button constants }
+
+const
+ HHWIN_BUTTON_EXPAND = $00000002; // (1 << 1) Expand/contract button
+ HHWIN_BUTTON_BACK = $00000004; // (1 << 2) Back button
+ HHWIN_BUTTON_FORWARD = $00000008; // (1 << 3) Forward button
+ HHWIN_BUTTON_STOP = $00000010; // (1 << 4) Stop button
+ HHWIN_BUTTON_REFRESH = $00000020; // (1 << 5) Refresh button
+ HHWIN_BUTTON_HOME = $00000040; // (1 << 6) Home button
+ HHWIN_BUTTON_BROWSE_FWD = $00000080; // (1 << 7) not implemented
+ HHWIN_BUTTON_BROWSE_BCK = $00000100; // (1 << 8) not implemented
+ HHWIN_BUTTON_NOTES = $00000200; // (1 << 9) not implemented
+ HHWIN_BUTTON_CONTENTS = $00000400; // (1 << 10) not implemented
+ HHWIN_BUTTON_SYNC = $00000800; // (1 << 11) Sync button
+ HHWIN_BUTTON_OPTIONS = $00001000; // (1 << 12) Options button
+ HHWIN_BUTTON_PRINT = $00002000; // (1 << 13) Print button
+ HHWIN_BUTTON_INDEX = $00004000; // (1 << 14) not implemented
+ HHWIN_BUTTON_SEARCH = $00008000; // (1 << 15) not implemented
+ HHWIN_BUTTON_HISTORY = $00010000; // (1 << 16) not implemented
+ HHWIN_BUTTON_FAVORITES = $00020000; // (1 << 17) not implemented
+ HHWIN_BUTTON_JUMP1 = $00040000; // (1 << 18)
+ HHWIN_BUTTON_JUMP2 = $00080000; // (1 << 19)
+ HHWIN_BUTTON_ZOOM = $00100000; // (1 << 20)
+ HHWIN_BUTTON_TOC_NEXT = $00200000; // (1 << 21)
+ HHWIN_BUTTON_TOC_PREV = $00400000; // (1 << 22)
+
+ HHWIN_DEF_BUTTONS = (HHWIN_BUTTON_EXPAND
+ OR HHWIN_BUTTON_BACK
+ OR HHWIN_BUTTON_OPTIONS
+ OR HHWIN_BUTTON_PRINT);
+
+ { Button IDs }
+
+const
+ IDTB_EXPAND = 200;
+ IDTB_CONTRACT = 201;
+ IDTB_STOP = 202;
+ IDTB_REFRESH = 203;
+ IDTB_BACK = 204;
+ IDTB_HOME = 205;
+ IDTB_SYNC = 206;
+ IDTB_PRINT = 207;
+ IDTB_OPTIONS = 208;
+ IDTB_FORWARD = 209;
+ IDTB_NOTES = 210; // not implemented
+ IDTB_BROWSE_FWD = 211;
+ IDTB_BROWSE_BACK = 212;
+ IDTB_CONTENTS = 213; // not implemented
+ IDTB_INDEX = 214; // not implemented
+ IDTB_SEARCH = 215; // not implemented
+ IDTB_HISTORY = 216; // not implemented
+ IDTB_FAVORITES = 217; // not implemented
+ IDTB_JUMP1 = 218;
+ IDTB_JUMP2 = 219;
+ IDTB_CUSTOMIZE = 221;
+ IDTB_ZOOM = 222;
+ IDTB_TOC_NEXT = 223;
+ IDTB_TOC_PREV = 224;
+
+ { Notification codes }
+
+const
+ HHN_FIRST = (0-860);
+ HHN_LAST = (0-879);
+
+ HHN_NAVCOMPLETE = (HHN_FIRST-0);
+ HHN_TRACK = (HHN_FIRST-1);
+ HHN_WINDOW_CREATE = (HHN_FIRST-2);
+
+type
+ {*** Used by command HH_GET_LAST_ERROR
+ NOTE: Not part of the htmlhelp.h but documented in HH Workshop help
+ You must call SysFreeString(xx.description) to free BSTR
+ }
+ tagHH_LAST_ERROR = packed record
+ cbStruct: Integer; // sizeof this structure
+ hr: Integer; // Specifies the last error code.
+ description: PWideChar; // (BSTR) Specifies a Unicode string containing a description of the error.
+ end;
+ HH_LAST_ERROR = tagHH_LAST_ERROR;
+ THHLastError = tagHH_LAST_ERROR;
+
+type
+ {*** Notify event info for HHN_NAVCOMPLETE, HHN_WINDOW_CREATE }
+ PHHNNotify = ^THHNNotify;
+ tagHHN_NOTIFY = packed record
+ hdr: TNMHdr;
+ pszUrl: PAnsiChar; //PCSTR: Multi-byte, null-terminated string
+ end;
+ HHN_NOTIFY = tagHHN_NOTIFY;
+ THHNNotify = tagHHN_NOTIFY;
+
+ {** Use by command HH_DISPLAY_TEXT_POPUP}
+ PHHPopup = ^THHPopup;
+ tagHH_POPUP = packed record
+ cbStruct: Integer; // sizeof this structure
+ hinst: HINST; // instance handle for string resource
+ idString: cardinal; // string resource id, or text id if pszFile is specified in HtmlHelp call
+ pszText: PAnsiChar; // used if idString is zero
+ pt: TPOINT; // top center of popup window
+ clrForeground: COLORREF; // use -1 for default
+ clrBackground: COLORREF; // use -1 for default
+ rcMargins: TRect; // amount of space between edges of window and text, -1 for each member to ignore
+ pszFont: PAnsiChar; // facename, point size, char set, BOLD ITALIC UNDERLINE
+ end;
+ HH_POPUP = tagHH_POPUP;
+ THHPopup = tagHH_POPUP;
+
+ {** Use by commands - HH_ALINK_LOOKUP, HH_KEYWORD_LOOKUP}
+ PHHAKLink = ^THHAKLink;
+ tagHH_AKLINK = packed record
+ cbStruct: integer; // sizeof this structure
+ fReserved: BOOL; // must be FALSE (really!)
+ pszKeywords: PAnsiChar; // semi-colon separated keywords
+ pszUrl: PAnsiChar; // URL to jump to if no keywords found (may be NULL)
+ pszMsgText: PAnsiChar; // Message text to display in MessageBox if pszUrl is NULL and no keyword match
+ pszMsgTitle: PAnsiChar; // Message text to display in MessageBox if pszUrl is NULL and no keyword match
+ pszWindow: PAnsiChar; // Window to display URL in
+ fIndexOnFail: BOOL; // Displays index if keyword lookup fails.
+ end;
+ HH_AKLINK = tagHH_AKLINK;
+ THHAKLink = tagHH_AKLINK;
+
+const
+ HHWIN_NAVTYPE_TOC = 0;
+ HHWIN_NAVTYPE_INDEX = 1;
+ HHWIN_NAVTYPE_SEARCH = 2;
+ HHWIN_NAVTYPE_FAVORITES = 3;
+ HHWIN_NAVTYPE_HISTORY = 4; // not implemented
+ HHWIN_NAVTYPE_AUTHOR = 5;
+ HHWIN_NAVTYPE_CUSTOM_FIRST = 11;
+
+const
+ IT_INCLUSIVE = 0;
+ IT_EXCLUSIVE = 1;
+ IT_HIDDEN = 2;
+
+type
+ PHHEnumIT = ^THHEnumIT;
+ tagHH_ENUM_IT = packed record //tagHH_ENUM_IT, HH_ENUM_IT, *PHH_ENUM_IT
+ cbStruct: Integer; // size of this structure
+ iType: Integer; // the type of the information type ie. Inclusive, Exclusive, or Hidden
+ pszCatName: PAnsiChar; // Set to the name of the Category to enumerate the info types in a category; else NULL
+ pszITName: PAnsiChar; // volitile pointer to the name of the infotype. Allocated by call. Caller responsible for freeing
+ pszITDescription: PAnsiChar; // volitile pointer to the description of the infotype.
+ end;
+ THHEnumIT = tagHH_ENUM_IT;
+
+type
+ PHHEnumCat = ^THHEnumCat;
+ tagHH_ENUM_CAT = packed record //tagHH_ENUM_CAT, HH_ENUM_CAT, *PHH_ENUM_CAT
+ cbStruct: Integer; // size of this structure
+ pszCatName: PAnsiChar; // volitile pointer to the category name
+ pszCatDescription: PAnsiChar; // volitile pointer to the category description
+ end;
+ THHEnumCat = tagHH_ENUM_CAT;
+
+type
+ PHHSetInfoType = ^THHSetInfoType;
+ tagHH_SET_INFOTYPE = packed record //tagHH_SET_INFOTYPE, HH_SET_INFOTYPE, *PHH_SET_INFOTYPE
+ cbStruct: Integer; // the size of this structure
+ pszCatName: PAnsiChar; // the name of the category, if any, the InfoType is a member of.
+ pszInfoTypeName: PAnsiChar; // the name of the info type to add to the filter
+ end;
+ THHSetInfoType = tagHH_SET_INFOTYPE;
+
+type
+ HH_INFOTYPE = DWORD;
+ THHInfoType = HH_INFOTYPE;
+ PHHInfoType = ^THHInfoType; //PHH_INFOTYPE
+
+const
+ HHWIN_NAVTAB_TOP = 0;
+ HHWIN_NAVTAB_LEFT = 1;
+ HHWIN_NAVTAB_BOTTOM = 2;
+
+const
+ HH_MAX_TABS = 19; // maximum number of tabs
+const
+ HH_TAB_CONTENTS = 0;
+ HH_TAB_INDEX = 1;
+ HH_TAB_SEARCH = 2;
+ HH_TAB_FAVORITES = 3;
+ HH_TAB_HISTORY = 4;
+ HH_TAB_AUTHOR = 5;
+ HH_TAB_CUSTOM_FIRST = 11;
+ HH_TAB_CUSTOM_LAST = HH_MAX_TABS;
+
+ HH_MAX_TABS_CUSTOM = (HH_TAB_CUSTOM_LAST - HH_TAB_CUSTOM_FIRST + 1);
+
+ { HH_DISPLAY_SEARCH Command Related Structures and Constants }
+
+const
+ HH_FTS_DEFAULT_PROXIMITY = (-1);
+
+type
+ {** Used by command HH_DISPLAY_SEARCH}
+ PHHFtsQuery = ^THHFtsQuery;
+ tagHH_FTS_QUERY = packed record //tagHH_FTS_QUERY, HH_FTS_QUERY
+ cbStruct: integer; // Sizeof structure in bytes.
+ fUniCodeStrings: BOOL; // TRUE if all strings are unicode.
+ pszSearchQuery: PAnsiChar; // String containing the search query.
+ iProximity: LongInt; // Word proximity.
+ fStemmedSearch: Bool; // TRUE for StemmedSearch only.
+ fTitleOnly: Bool; // TRUE for Title search only.
+ fExecute: Bool; // TRUE to initiate the search.
+ pszWindow: PAnsiChar; // Window to display in
+ end;
+ THHFtsQuery = tagHH_FTS_QUERY;
+
+ { HH_WINTYPE Structure }
+
+type
+ {** Used by commands HH_GET_WIN_TYPE, HH_SET_WIN_TYPE}
+ PHHWinType = ^THHWinType;
+ tagHH_WINTYPE = packed record //tagHH_WINTYPE, HH_WINTYPE, *PHH_WINTYPE;
+ cbStruct: Integer; // IN: size of this structure including all Information Types
+ fUniCodeStrings: BOOL; // IN/OUT: TRUE if all strings are in UNICODE
+ pszType: PAnsiChar; // IN/OUT: Name of a type of window
+ fsValidMembers: DWORD; // IN: Bit flag of valid members (HHWIN_PARAM_)
+ fsWinProperties: DWORD; // IN/OUT: Properties/attributes of the window (HHWIN_)
+
+ pszCaption: PAnsiChar; // IN/OUT: Window title
+ dwStyles: DWORD; // IN/OUT: Window styles
+ dwExStyles: DWORD; // IN/OUT: Extended Window styles
+ rcWindowPos: TRect; // IN: Starting position, OUT: current position
+ nShowState: Integer; // IN: show state (e.g., SW_SHOW)
+
+ hwndHelp: HWND; // OUT: window handle
+ hwndCaller: HWND; // OUT: who called this window
+
+ paInfoTypes: PHHInfoType; // IN: Pointer to an array of Information Types
+
+ { The following members are only valid if HHWIN_PROP_TRI_PANE is set }
+
+ hwndToolBar: HWND; // OUT: toolbar window in tri-pane window
+ hwndNavigation: HWND; // OUT: navigation window in tri-pane window
+ hwndHTML: HWND; // OUT: window displaying HTML in tri-pane window
+ iNavWidth: Integer; // IN/OUT: width of navigation window
+ rcHTML: TRect; // OUT: HTML window coordinates
+
+ pszToc: PAnsiChar; // IN: Location of the table of contents file
+ pszIndex: PAnsiChar; // IN: Location of the index file
+ pszFile: PAnsiChar; // IN: Default location of the html file
+ pszHome: PAnsiChar; // IN/OUT: html file to display when Home button is clicked
+ fsToolBarFlags: DWORD; // IN: flags controling the appearance of the toolbar (HHWIN_BUTTON_)
+ fNotExpanded: BOOL; // IN: TRUE/FALSE to contract or expand, OUT: current state
+ curNavType: Integer; // IN/OUT: UI to display in the navigational pane
+ tabpos: Integer; // IN/OUT: HHWIN_NAVTAB_TOP, HHWIN_NAVTAB_LEFT, or HHWIN_NAVTAB_BOTTOM
+ idNotify: Integer; // IN: ID to use for WM_NOTIFY messages
+ tabOrder: packed array[0..HH_MAX_TABS] of Byte; // IN/OUT: tab order: Contents, Index, Search, History, Favorites, Reserved 1-5, Custom tabs
+ cHistory: Integer; // IN/OUT: number of history items to keep (default is 30)
+ pszJump1: PAnsiChar; // Text for HHWIN_BUTTON_JUMP1
+ pszJump2: PAnsiChar; // Text for HHWIN_BUTTON_JUMP2
+ pszUrlJump1: PAnsiChar; // URL for HHWIN_BUTTON_JUMP1
+ pszUrlJump2: PAnsiChar; // URL for HHWIN_BUTTON_JUMP2
+ rcMinSize: TRect; // Minimum size for window (ignored in version 1)
+
+ cbInfoTypes: Integer; // size of paInfoTypes;
+ pszCustomTabs: PAnsiChar; // multiple zero-terminated strings
+ end;
+ HH_WINTYPE = tagHH_WINTYPE;
+ THHWinType = tagHH_WINTYPE;
+
+const
+ HHACT_TAB_CONTENTS = 0;
+ HHACT_TAB_INDEX = 1;
+ HHACT_TAB_SEARCH = 2;
+ HHACT_TAB_HISTORY = 3;
+ HHACT_TAB_FAVORITES = 4;
+
+ HHACT_EXPAND = 5;
+ HHACT_CONTRACT = 6;
+ HHACT_BACK = 7;
+ HHACT_FORWARD = 8;
+ HHACT_STOP = 9;
+ HHACT_REFRESH = 10;
+ HHACT_HOME = 11;
+ HHACT_SYNC = 12;
+ HHACT_OPTIONS = 13;
+ HHACT_PRINT = 14;
+ HHACT_HIGHLIGHT = 15;
+ HHACT_CUSTOMIZE = 16;
+ HHACT_JUMP1 = 17;
+ HHACT_JUMP2 = 18;
+ HHACT_ZOOM = 19;
+ HHACT_TOC_NEXT = 20;
+ HHACT_TOC_PREV = 21;
+ HHACT_NOTES = 22;
+
+ HHACT_LAST_ENUM = 23;
+
+type
+ {*** Notify event info for HHN_TRACK }
+ PHHNTrack = ^THHNTrack;
+ tagHHNTRACK = packed record //tagHHNTRACK, HHNTRACK;
+ hdr: TNMHdr;
+ pszCurUrl: PAnsiChar; // Multi-byte, null-terminated string
+ idAction: Integer; // HHACT_ value
+ phhWinType: PHHWinType; // Current window type structure
+ end;
+ HHNTRACK = tagHHNTRACK;
+ THHNTrack = tagHHNTRACK;
+
+///////////////////////////////////////////////////////////////////////////////
+//
+// Global Control Properties.
+//
+const
+ HH_GPROPID_SINGLETHREAD = 1; // VARIANT_BOOL: True for single thread
+ HH_GPROPID_TOOLBAR_MARGIN = 2; // long: Provides a left/right margin around the toolbar.
+ HH_GPROPID_UI_LANGUAGE = 3; // long: LangId of the UI.
+ HH_GPROPID_CURRENT_SUBSET = 4; // BSTR: Current subset.
+ HH_GPROPID_CONTENT_LANGUAGE = 5; // long: LandId for desired content.
+
+type
+ tagHH_GPROPID = HH_GPROPID_SINGLETHREAD..HH_GPROPID_CONTENT_LANGUAGE;
+ HH_GPROPID = tagHH_GPROPID;
+ THHGPropID = HH_GPROPID;
+
+{$ENDIF WIN_GDI}
+
+{$IFDEF WIN_GDI}
+function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush;
+
+var
+ Global_GetCtlBrushHandle: function( Sender: PControl ): HBrush = SimpleGetCtlBrushHandle;
+ {* Is called to obtain brush handle. }
+{$ENDIF WIN_GDI}
+
+ Global_Align: procedure( Sender: PObj ) = DummyObjProc;
+ {* Is set to perform aligning of control, and only if property Align
+ is changed for TControl, or SetAlign method is called for it. }
+
+{$IFDEF WIN_GDI}
+function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
+ : Integer; stdcall;
+{* Global message handler for window. Redirects all messages to
+ destination windows, obtaining target TControl object address from
+ window itself, using GetProp API call. }
+{$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+var AppletRunning: Boolean;
+ {* Is set to True while message loop is processing (in Run procedure). }
+ AppletTerminated: Boolean;
+ {* Is set to True when message loop is terminated. }
+ Applet: PControl;
+ {* Applet window object. Actually, can be set to main form if program
+ not needed in special applet button window (useful to make applet
+ button invisible on taskbar, or to have several forms with single
+ applet button - crete it in that case using NewApplet). }
+ AppButtonUsed: Boolean;
+ {* True if special window to represent applet button (may be invisible)
+ is used. If no, every form is represented with its own taskbar button
+ (always visible). }
+
+{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+ ScreenCursor: HCursor;
+ {* Set this global variable to override any cursor settings of current
+ form or control. }
+
+function ScreenWidth: Integer;
+{* Returns screen width in pixels. }
+function ScreenHeight: Integer;
+{* Returns screen height in pixels. }
+
+type
+ TStatusOption = ( soNoSizeGrip, soTop );
+ {* Options available for status bars. }
+ TStatusOptions = Set of TStatusOption;
+ {* Status bar options. }
+
+procedure DrawFormattedText( Ctl: PControl; DC: HDC; var R: TRect; Flags: DWORD {EditCtl: Boolean} );
+{* This procedure can be useful to draw control's text in custom-defined controls. }
+
+type TCommandActionsParam = {$IFDEF PACK_COMMANDACTIONS} PAnsiChar
+ {$ELSE} PCommandActions {$ENDIF};
+
+{$IFDEF USE_GRAPHCTLS}
+
+{$IFDEF GRAPHCTL_XPSTYLES}
+var DoNotDrawGraphCtlsUsingXPStyles: Boolean;
+procedure DrawFormattedTextXP( Theme: THandle; Ctl: PControl; DC: HDC;
+ var R: TRect; CtlType, CtlStates, Flags1, Flags2: Integer );
+{* This procedure can be useful to draw control's text in custom-defined controls. }
+{$ENDIF}
+
+function _NewGraphCtl( AParent: PControl; ATabStop: Boolean;
+ ACommandActions: TCommandActionsParam ): PControl;
+{* Creates graphic control basics. }
+
+function NewGraphLabel( AParent: PControl; const ACaption: AnsiString ): PControl;
+{* Creates graphic label, which does not require a window handle. }
+
+function NewWordWrapGraphLabel( AParent: PControl; const ACaption: KOLString ): PControl;
+{* Creates graphic label, which does not require a window handle. }
+
+function NewGraphPaintBox( AParent: PControl ): PControl;
+{* Creates graphic paint box (just the same as graphic label, but with empty Caption). }
+
+function NewGraphCheckBox( AParent: PControl; const ACaption: KOLString ): PControl;
+{* Creates graphic checkbox. }
+
+function NewGraphRadioBox( AParent: PControl; const ACaption: KOLString ): PControl;
+{* Creates graphic radiobox. }
+
+function NewGraphButton( AParent: PControl; const ACaption: KOLString ): PControl;
+{* Creates graphic button. }
+
+function NewGraphEditbox( AParent: PControl; Options: TEditOptions ): PControl;
+{* Creates graphic edit box. To do editing, this box should be replaced with
+ real edit box with a handle (actually, it is enough to place an edit box
+ on the same Parent having the same BoundsRect). }
+{$ENDIF USE_GRAPHCTLS}
+{$ENDIF WIN_GDI}
+
+procedure Run( var AppletCtl: PControl );
+{* |<#appbutton>
+ Call this procedure to process messages loop of your program.
+ Pass here pointer to applet button object (if You have created it
+ - see NewApplet) or your main form object of type PControl (created
+ using NewForm).
+ |<br><br>
+ |<h1 align=center><font color=#FF8040><a name="visual_objects_constructors"></a>
+ Visual objects constructing functions
+ |</font></h1>
+ Following constructing functions for visual controls are available:
+ |#control
+}
+
+{$IFDEF WIN_GDI}
+
+procedure TerminateExecution( var AppletCtl: PControl );
+
+procedure AppletMinimize;
+{* Minimizes the application (Applet should be assigned to have effect). }
+procedure AppletHide;
+{* Minimizes and hides application. }
+procedure AppletRestore;
+{* Restores Applet when minimized. }
+
+{YS+}
+procedure RegisterIdleHandler( const OnIdle: TOnEvent );
+{* Registers new Idle handler. Idle handler is called each time when
+ message queue becomes empty. }
+procedure UnRegisterIdleHandler( const OnIdle: TOnEvent );
+{* Unregisters Idle handler. }
+{YS-}
+
+{* ComCtrl32 controls initialization. }
+procedure InitCommonControls; stdcall;
+procedure DoInitCommonControls( dwICC: DWORD );
+{* Calls extended initialization for Common Controls (from ComCtrl32).
+ Pass one of following constants:
+ |<pre>
+ ICC_LISTVIEW_CLASSES = $00000001; // listview, header
+ ICC_TREEVIEW_CLASSES = $00000002; // treeview, tooltips
+ ICC_BAR_CLASSES = $00000004; // toolbar, statusbar, trackbar, tooltips
+ ICC_TAB_CLASSES = $00000008; // tab, tooltips
+ ICC_UPDOWN_CLASS = $00000010; // updown
+ ICC_PROGRESS_CLASS = $00000020; // progress
+ ICC_HOTKEY_CLASS = $00000040; // hotkey
+ ICC_ANIMATE_CLASS = $00000080; // animate
+ ICC_WIN95_CLASSES = $000000FF;
+ ICC_DATE_CLASSES = $00000100; // month picker, date picker, time picker, updown
+ ICC_USEREX_CLASSES = $00000200; // comboex
+ ICC_COOL_CLASSES = $00000400; // rebar (coolbar) control
+ ICC_INTERNET_CLASSES = $00000800;
+ ICC_PAGESCROLLER_CLASS = $00001000; // page scroller
+ ICC_NATIVEFNTCTL_CLASS = $00002000; // native font control
+ |</pre>
+ }
+
+const
+ ICC_LISTVIEW_CLASSES = $00000001; // listview, header
+ ICC_TREEVIEW_CLASSES = $00000002; // treeview, tooltips
+ ICC_BAR_CLASSES = $00000004; // toolbar, statusbar, trackbar, tooltips
+ ICC_TAB_CLASSES = $00000008; // tab, tooltips
+ ICC_UPDOWN_CLASS = $00000010; // updown
+ ICC_PROGRESS_CLASS = $00000020; // progress
+ ICC_HOTKEY_CLASS = $00000040; // hotkey
+ ICC_ANIMATE_CLASS = $00000080; // animate
+ ICC_WIN95_CLASSES = $000000FF;
+ ICC_DATE_CLASSES = $00000100; // month picker, date picker, time picker, updown
+ ICC_USEREX_CLASSES = $00000200; // comboex
+ ICC_COOL_CLASSES = $00000400; // rebar (coolbar) control
+ ICC_INTERNET_CLASSES = $00000800;
+ ICC_PAGESCROLLER_CLASS = $00001000; // page scroller
+ ICC_NATIVEFNTCTL_CLASS = $00002000; // native font control
+
+function OleInit: Boolean;
+{* Calls OleInitialize (once - all other calls are simulated by incrementing
+ call counter. Every OleInit shoud be complemented with correspondent OleUninit.
+ (Though, it is possible to call API function OleUnInitialize once to
+ cancel all OleInit calls). }
+procedure OleUnInit;
+{* Decrements counter and calls OleUnInitialize when it is zeroed. }
+var OleInitCount: Integer;
+
+function StringToOleStr(const Source: Ansistring): PWideChar;
+{* }
+
+function SysAllocStringLen(psz: PWideChar; len: Integer): PWideChar; stdcall;
+procedure SysFreeString( psz: PWideChar ); stdcall;
+
+{$ENDIF WIN_GDI}
+{ -- Contructors for visual controls -- }
+
+{$IFDEF GDI}
+{$IFDEF COMMANDACTIONS_OBJ}
+function NewCommandActionsObj: PCommandActionsObj;
+function NewCommandActionsObj_Packed( fromPack: PAnsiChar ): PCommandActionsObj;
+{$ENDIF}
+
+function _NewWindowed( AParent: PControl; ControlClassName: PKOLChar;
+ Ctl3D: Boolean; ACommandActions: TCommandActionsParam): PControl;
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION _NewWindowed( AParent: PControl; ControlClassName: PAnsiChar;
+ widget: PGtkWidget; need_eventbox: Boolean ): PControl;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+function NewApplet( const Caption: KOLString ): PControl;
+{* |<#control>
+ Creates applet button window, which has to be parent of all other forms
+ in your project (but this is *not must*). See also comments about NewForm.
+ |<br>
+ Following methods, properties and events are useful to work with applet
+ control:
+ |#appbutton }
+{$ENDIF WIN_GDI}
+
+function NewForm( AParent: PControl; const Caption: KOLString ): PControl;
+{* |<#control>
+ Creates form window object and returns pointer to it. If You use only one form,
+ and You are not going to do applet button on task bar invisible, it is not
+ necessary to create also special applet button window - just pass
+ your (main) form object to Run procedure. In that case, it is a good
+ idea to assign pointer to your main form object to Applet variable
+ immediately following creating it - because some objects (e.g. TTimer)
+ want to have Applet assigned to something.
+ |<br>
+ |&D=<a href="tcontrol.htm#%1" target=_top> %0 </a>
+ Following methods, properties and events are useful to work with forms
+ (ones common for all visual objects, such as <D Left>, <D Top>, <D Width>,
+ <D Height>, etc. are not listed here - look TControl for it):
+ |#form }
+
+function NewAlienPanel( AParentWnd: HWnd; EdgeStyle: TEdgeStyle ): PControl;
+
+{$IFDEF GDI}
+function _NewControl( AParent: PControl; ControlClassName: PKOLChar;
+ Style: DWORD; Ctl3D: Boolean; Actions: TCommandActionsParam ): PControl;
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION _NewControl( AParent: PControl; ControlClassName: PAnsiChar;
+ Style: DWORD; Ctl3D: Boolean; widget: PGtkWidget; need_eventbox: Boolean ): PControl;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
+{* |<#control>
+ Creates button on given parent control or form.
+ Please note, that in Windows, buttons can not change its <D Font> color
+ and to be <D Transparent>.
+ |<br> Following methods, properies and events are (especially) useful with
+ a button:
+ |#button }
+
+{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+function NewBitBtn( AParent: PControl; const Caption: KOLString;
+ Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap; GlyphCount: Integer ): PControl;
+{* |<#control>
+ Creates image button (actually implemented as owner-drawn). In Options,
+ it is possible to determine, whether bitmap or image list used to contain
+ one or more (up to 5) images, correspondent to certain BitBtn state.
+ |<br>
+ For case of imagelist (option bboImageList), it is possible to use a
+ number of glyphs from the image list, starting from image index given
+ by GlyphCount parameter. Number of used glyphs is passed in that case
+ in high word of GlyphCount parameter (if 0, one image is used therefore).
+ For bboImageList, BitBtn can be Transparent (and in that case bboNoBorder
+ style can be useful to draw custom buttons of non-rectangular shape).
+ |<br>
+ For case of bitmap BitBtn, image is stretched down (if too big), but can
+ not be transparent. It is not necessary for bitmap BitBtn to pass correct
+ GlyphCount - it is calculated on base of bitmap size, if 0 is passed.
+ |<br>
+ And, certainly, BitBtn can be without glyph image (text only). For that
+ case, it is therefore is more flexible and power than usual Button (but
+ requires more code). E.g., BitBtn can change its <D Font>, <D Color>,
+ and to be totally <D Transparent>.
+ Moreover, BitBtn can be <D Flat>, bboFixed, <D SpeedButton> and
+ have property <D RepeatInterval>.
+ |<br>
+ Note: if You use bboFixed Style, use OnChange event instead of OnClick,
+ because <D Checked> state is changed immediately however OnClick occure
+ only when mouse or space key released (and can be not called at all if
+ mouse button is released out of BitBtn bounds). Also, bboFixed defines
+ only which glyph to show (the border if it is not turned off behaves as
+ usual for a button, i.e. it becomes lowered and then raised again at any click).
+ Here You can find references to other properties, events and methods
+ applicable to BitBtn:
+ |#bitbtn }
+
+{$ENDIF GDI}
+function NewLabel( AParent: PControl; const Caption: KOLString ): PControl;
+{* |<#control>
+ Creates static text control (native Windows STATIC control).
+ Use property <D Caption> at run time to change label text. Also
+ it is possible to adjust label <D Font>, <D Brush> or <D Color>.
+ Label can be <D Transparent>. If You want to have rotated text
+ label, call NewLabelEffect instead and change its <D Font>.FontOrientation.
+ Other references certain for a label:
+ |#label }
+{$IFDEF GDI}
+
+function NewWordWrapLabel( AParent: PControl; const Caption: KOLString ): PControl;
+{* |<#control>
+ Creates multiline static text control (native Windows STATIC control),
+ which can wrap long text onto several lines. See also NewLabel.
+ See also:
+ |#wwlabel
+ |#label }
+
+function NewLabelEffect( AParent: PControl; const Caption: KOLString; ShadowDeep: Integer ): PControl;
+{* |<#control>
+ Creates 3D-label with capability to rotate its text <D Caption>, which
+ is controlled by changing <D Font>.FontOrientation property. If You want
+ to get flat effect label (e.g. to rotate it only), pass <D ShadowDeep> = 0.
+ Please note, that drawing procedure uses <D Canvas> property, so using of
+ LabelEffect leads to increase size of executable.
+ See also:
+ |#3dlabel
+ |#label }
+
+{$ENDIF GDI}
+function NewPaintbox( AParent: PControl ): PControl;
+{* |<#control>
+ Creates owner-drawn STATIC control. Set its <D OnPaint> event to
+ perform custom painting.
+ |#paintbox }
+{$IFDEF GDI}
+
+function NewImageShow( AParent: PControl; AImgList: PImageList; ImgIdx: Integer ): PControl;
+{* |<#control>
+ Creates an image show control, implemented as a paintbox which is used to
+ draw an image from the imagelist. At run-time, use property CurIndex to
+ select another image from the imagelist, and a property ImageListNormal to
+ use another image list. When the control is created, its size becomes
+ equal to dimensions of imagelist (if any). }
+
+function NewScrollBar( AParent: PControl; BarSide: TScrollerBar ): PControl;
+{* |<#control>
+ Creates simple scroll bar. }
+
+function NewScrollBox( AParent: PControl; EdgeStyle: TEdgeStyle;
+ Bars: TScrollerBars ): PControl;
+{* |<#control>
+ Creates simple scrolling box, which can be used any way you wish, e.g. to scroll
+ certain large image. To provide automatic scrolling of a set of child controls,
+ use advanced scroll box, created with NewScrollBoxEx. }
+
+procedure NotifyScrollBox( Self_, Child: PControl );
+
+function NewScrollBoxEx( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
+{* |<#control>
+ Creates extended scrolling box control, which automatically scrolls child
+ controls (if any). }
+
+function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;
+{* |<#control>
+ Creates gradient-filled STATIC control. To adjust colors at the
+ run time, change <D Color1> and <D Color2> properties (which initially are
+ assigned from Color1, Color2 parameters), and call <D Invalidate> method
+ to repaint control. }
+
+function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;
+ Style: TGradientStyle; Layout: TGradientLayout ): PControl;
+{* |<#control>
+ Creates gradient-filled STATIC control. To adjust colors at the
+ run time, change <D Color1> and <D Color2> properties (which initially are
+ assigned from Color1, Color2 parameters), and call <D Invalidate> method
+ to repaint control. Depending on style and first line/point layout, can
+ looking different. Idea: Vladimir Stojiljkovic. }
+
+function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
+{* |<#control>
+ Creates panel, which can be parent for other controls (though, any
+ control can be used as a parent for other ones, but panel is specially
+ designed for such purpose). }
+
+{$IFDEF USE_MDI}
+function NewMDIClient( AParent: PControl; WindowMenu: THandle ): PControl;
+{* |<#control>
+ Creates MDI client window, which is a special type of child window,
+ containing all MDI child windows, created calling NewMDIChild function.
+ On a form, MDI client behaves like a panel, so it can be placed and sized
+ (or aligned) like any other controls. To minimize flick during resizing
+ main form having another aligned controls, place MDI client window on
+ a panel and align it caClient in the panel.
+ |<br>Note:
+ MDI client must be a single on the form. }
+
+function NewMDIChild( AParent: PControl; const ACaption: KOLString ): PControl;
+{* |<#control>
+ Creates MDI client window. AParent should be a MDI client window,
+ created with NewMDIClient function. }
+{$ENDIF USE_MDI}
+
+function NewSplitter( AParent: PControl; MinSizePrev, MinSizeNext: Integer ): PControl;
+{* |<#control>
+ Creates splitter control, which will separate previous one (i.e. last
+ created one before splitter on the same parent) from created
+ next, allowing to user to adjust size of separated controls by dragging
+ the splitter in desired direction. Created splitter becomes vertical
+ or horizontal depending on Align style of previous control on the same
+ parent (if caLeft/caRight then vertical, if caTop/caBottom then horizontal).
+ |<br>
+ Please note, what if previous control has no Align equal to caLeft/caRight
+ or caTop/caBottom, splitter will not be able to function normally. If
+ previous control does not exist, it is yet possible to use splitter as
+ a resizeable panel (but set its initial Align value first - otherwise it
+ is not set by default. Also, change Cursor property as You wish in that
+ case, since it is not set too in case, when previous control does not
+ exist).
+ |<br>
+ Additional parameters determine, which minimal size (width or height -
+ correspondently to split direction) is allowed for left (top) control
+ and to rest of client area of parent, correspondently. (It is possible
+ later to set second control for checking its size with MinSizeNext
+ value - using TControl.SecondControl property). If -1 passed,
+ correspondent control size is not checked during dragging of splitter.
+ Usually 0 is more suitable value (with this value, it is garantee, that
+ splitter will be always available even if mouse was released far from the
+ edge of form).
+ |<br>
+ It is possible for user to press Escape any time while dragging splitter
+ to abort all adjustments made starting from left mouse button push and
+ begin of drag the splitter. But remember please, that such event is
+ controlled using timer, and therefore correspondent keyboard events
+ are received by currently focused control. Be sure, that pressing Escape
+ will not affect to any control on form, which could be focused, otherwise
+ filter keyboard messages (by yourself) to prevent undesired handling of
+ Escape key by certain controls while splitting. (Use Dragging property
+ to check if splitter is dragging by user with mouse).
+ |<br>
+ See also:
+ NewSplitterEx
+ |#splitter }
+
+function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;
+ EdgeStyle: TEdgeStyle ): PControl;
+{* |<#control>
+ Creates splitter control. Difference from NewSplitter is what it is possible
+ to determine if a splitter will be beveled or not. See also NewSplitter. }
+
+function NewGroupbox( AParent: PControl; const Caption: KOLString ): PControl;
+{* |<#control>
+ Creates group box control. Note, that to group radio items, group
+ box is not necessary - any parent can play role of group for radio items.
+ See also NewPanel. }
+
+function NewCheckbox( AParent: PControl; const Caption: KOLString ): PControl;
+{* |<#control>
+ Creates check box control. Special properties, methods, events:
+ |#checkbox }
+
+function NewCheckBox3State( AParent: PControl; const Caption: KOLString ): PControl;
+{* |<#control>
+ Creates check box control with 3 states. Special properties, methods,
+ events:
+ |#checkbox }
+
+function NewRadiobox( AParent: PControl; const Caption: KOLString ): PControl;
+{* |<#control>
+ Creates radio box control. Alternative radio items must have the
+ same parent window (regardless of its kind, either groupbox (NewGroupbox),
+ panel (NewPanel) or form itself). Following properties, methods and events
+ are specially for radiobox controls:
+ |#radiobox }
+
+function NewEditbox( AParent: PControl; Options: TEditOptions ): PControl;
+{* |<#control>
+ Creates edit box control. To create multiline edit box, similar to
+ TMemo in VCL, apply eoMultiline in Options. Following properties, methods,
+ events are special for edit controls:
+ |#edit }
+
+{$IFNDEF NOT_USE_RICHEDIT}
+var FRichEditModule: Integer;
+ RichEditClass: PKOLChar;
+
+const RichEditLibnames: array[ 0..3 ] of PKOLChar =
+ ( 'msftedit', 'riched20',
+ 'riched32', 'riched' );
+ RichEditClasses: array[ 0..3 ] of PKOLChar =
+ ( 'RichEdit50W', 'RichEdit20A',
+ 'RichEdit', 'RichEdit' );
+var RichEditIdx: Byte = High( RichEditLibnames );
+
+function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;
+{* |<#control>
+ Creates rich text edit control. A rich edit control is a window in which
+ the user can enter and edit text. The text can be assigned character and
+ paragraph formatting, and can include embedded OLE objects. Rich edit
+ controls provide a programming interface for formatting text. However, an
+ application must implement any user interface components necessary to make
+ formatting operations available to the user.
+ |<br>
+ Note: eoPassword, eoMultiline options have no effect for RichEdit control.
+ Some operations are supersided with special versions of those, created
+ especially for RichEdit, but in some cases it is necessary to use
+ another properties and methods, specially designed for RichEdit (see
+ methods and properties, which names are starting from RE_...).
+ |<br>
+ Following properties, methods, events are special for edit controls:
+ |#richedit
+ }
+
+function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;
+{* |<#control>
+ Like NewRichEdit, but to work with older RichEdit control version 1.0
+ (window class 'RichEdit' forced to use instead of 'RichEdit20A', even
+ if library RICHED20.DLL found and loaded successfully). One more
+ difference - OleInit is not called, so the most of OLE capabilities
+ of RichEdit could not working. }
+{$ENDIF NOT_USE_RICHEDIT}
+
+function NewListbox( AParent: PControl; Options: TListOptions ): PControl;
+{* |<#control>
+ Creates list box control. Following properties, methods and events are
+ special for Listbox:
+ |#listbox }
+
+function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;
+{* |<#control>
+ Creates new combo box control. Note, that it is not possible to align
+ combobox caLeft or caRight: this can cause infinite recursion in the
+ application.
+ |<br>Following properties, methods and events are
+ special for Combobox:
+ |#combo }
+
+function _NewCommonControl( AParent: PControl; ClassName: PKOLChar; Style: DWORD;
+ Ctl3D: Boolean; Actions: TCommandActionsParam
+ ): PControl;
+
+function NewProgressbar( AParent: PControl ): PControl;
+{* |<#control>
+ Creates progress bar control. Following properties are special for
+ progress bar:
+ |#progressbar
+ See also NewProgressEx. }
+
+function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;
+{* |<#control>
+ Can create progress bar with smooth style (progress is not segmented
+ onto bricks) or/and vertical progress bar - using additional parameter.
+ For list of properties, suitable for progress bars, see NewProgressbar. }
+
+function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;
+ ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;
+{* |<#control>
+ Creates list view control. It is very powerful control, which can partially
+ compensate absence of grid controls (in lvsDetail view mode). Properties,
+ methods and events, special for list view control are:
+ |#listview }
+
+function NewTreeView( AParent: PControl; Options: TTreeViewOptions;
+ ImgListNormal, ImgListState: PImageList ): PControl;
+{* |<#control>
+ Creates tree view control. See tree view methods and properties:
+ |#treeview }
+
+function NewTabControl( AParent: PControl; const Tabs: array of PKOLChar; Options: TTabControlOptions;
+ ImgList: PImageList; ImgList1stIdx: Integer ): PControl;
+{* |<#control>
+ Creates new tab control (like notebook). To place child control on a certain
+ page of TabControl, use property Pages[ Idx ], for example:
+ ! Label1 := NewLabel( TabControl1.Pages[ 0 ], 'Label1' );
+ |
+ To determine number of pages at run time, use property <D Count>;
+ |<br> to determine which page is currently selected (or to change
+ selection), use property <D CurIndex>;
+ |<br> to feedback to switch between tabs assign your handler to OnSelChange
+ event;
+ |<br>Note, that by default, tab control is created with a border lowered to
+ tab control's parent. To remove it, you can apply WS_EX_TRANSPARENT extended
+ style (see TControl.ExStyle property), but painting of some child controls
+ can be strange a bit in this case (no border drawing for edit controls was
+ found, but not always...). You can also apply style WS_THICKFRAME (TControl.Style
+ property) to make the border raised.
+ |<br> Other methods and properties, suitable for tab control, are:
+ |#tabcontrol }
+{$IFNDEF OLD_ALIGN}
+function NewTabEmpty( AParent: PControl; Options: TTabControlOptions;
+ ImgList: PImageList ): PControl;
+{* |<#control>
+ Creates new empty tab control for using metods TC_Insert (to create Pages as Panel),
+ or TC_InsertControl (if you want using your custom Pages).}
+{$ENDIF}
+
+var ToolbarDfltWidth: WORD = 1000;
+ ToolbarDfltHeight: WORD = 26;
+
+function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
+ Bitmap: HBitmap; const Buttons: array of PKOLChar;
+ const BtnImgIdxArray: array of Integer ) : PControl;
+{* |<#control>
+ Creates toolbar control. Bitmap (if present) must contain images for all buttons
+ excluding separators (defined by string '-' in Buttons array) and system images,
+ otherwise last buttons will no have images at all. Image width for every button
+ is assumed to be equal to Bitmap height (if last of "squares" has
+ insufficient width, it will not be used). To define fixed buttons, use
+ characters '+' or '-' as a prefix for button string (even empty). To
+ create groups of (radio-)buttons, use also '!' follow '+' or '-'. (These rules
+ are similar used in menu creation). To define drop down button, use (as
+ first) prefix '^'. (Do not forget to set <D OnTBDropDown> event for this
+ case). If You want to assign images to buttons not in the same order
+ how these are placed in Bitmap (or You use system bitmap), define for every
+ button (in BtnImgIdxArray array) indexes for every button (excluding
+ separator buttons). Otherwise, it is possible to define index only for first
+ button (e.g., [0]). It is also possible to change TBImages[ ] property
+ for such purpose, or do the same in method TBSetBtnImgIdx).
+ |<br>
+ Following properties, methods and event are specially designed to work with
+ toolbar control:
+ |#toolbar
+ |<br>
+ If your project uses Align property to align controls, this can conflict with
+ toolbar native aligning. To solve such problem, place toolbar to parent panel,
+ which has its own Align property assigned to desired value.
+ |<br>
+ To create toolbar with buttons, drawn from top to bottom, instead from left
+ to right, combine caLeft / caRight in Align parameter and style tboWrapable
+ when create toolbar. To adjust width of vertically aligned toolbar, it is
+ possible to call ResizeParentLeft for it. E.g.:
+
+ ! P0 := NewPanel( W, esRaised ) .SetSize( 30, 0 ) .SetAlign( caLeft );
+ ! // ^^^^^^^^^^^^^^^^^ //////
+ !TB := NewToolbar( P0, caLeft, [ tboNoDivider, tboWrapable ], DWORD(-1),
+ ! // ////// ///////////
+ ! [ ' ', ' ', ' ', '-', ' ', ' ' ],
+ ! [ STD_FILEOPEN ] ).ResizeParentRight;
+ !//Note, that caLeft is *must*, and tboWrapable style too. SetSize for
+ !//parent panel is not necessary, but only if ResizeParentRight is called
+ !//than for Toolbar.
+ |<br><br>
+ One more note: if You create toolbar without text labels (passing ' ' for
+ each button You add), include also option tboTextRight to fix incorrect
+ sizing of buttons under Windows9x.
+ |<br>
+ And, certainly, if you use image lists rather then bitmap, all written
+ above about Bitmap become absolutely incorrect.
+ }
+
+function NewDateTimePicker( AParent: PControl; Options: TDateTimePickerOptions )
+ : PControl;
+{* |<#control>
+ Creates date and time picker common control.
+}
+
+{ -- Constructor for Image List objet -- }
+
+function NewImageList( AOwner: PControl ): PImageList;
+{* Constructor of TImageList object. Unlike other non-visual objects, image list
+ can be parented by TControl object (but this does not *must*), and in that
+ case it is destroyed automatically when its parent control is destroyed.
+ Every control can have several TImageList objects, linked to a simple list.
+ But if any TImageList object is destroyed, all following ones are destroyed
+ too (at least, now I implemented it so). }
+
+{$ENDIF WIN_GDI}
+
+type
+ TTimerKind = ( tkReal, tkProcess, tkProfiler ); // only for UNIX!
+ PTimer = ^TTimer;
+{ ----------------------------------------------------------------------
+ TTimer object
+----------------------------------------------------------------------- }
+ TTimer = object( TObj )
+ {* Easy timer incapsulation object. It uses separate topmost window,
+ common for all timers in the application, to handle WM_TIMER message.
+ This allows using timers in non-windowed application (but anyway it
+ should contain message handling loop for a thread).
+ |<br>
+ Note: in UNIX, there are no special windows created, certainly. }
+ protected
+ fHandle : Integer;
+ fEnabled: Boolean;
+ fInterval: Integer;
+ fOnTimer: TOnEvent;
+ {$IFDEF LIN}
+ {$IFNDEF GTK}
+ {$IFNDEF QT}
+ fPrev, fNext: PTimer; // двусвязный список всех _активных_ таймеров
+ fTimeStart: clock_t;
+ fExpireNext: clock_t;
+ fExpireTotal: Int64;
+ fTimerHandled: Boolean;
+ fResolution: Integer;
+ fPeriodic: Boolean;
+ fMultimedia: Boolean;
+ {$ENDIF QT}
+ {$ENDIF GTK}
+ {$ENDIF}
+ procedure SetEnabled(const Value: Boolean); {$IFDEF WIN} virtual; {$ENDIF}
+ procedure SetInterval(const Value: Integer);
+ protected
+ destructor Destroy; virtual;
+ {* Destructor. }
+ public
+ property Handle : Integer read fHandle;
+ {* Windows timer object handle. }
+ property Enabled : Boolean read fEnabled write SetEnabled;
+ {* True, is timer is on. Initially, always False. }
+ property Interval : Integer read fInterval write SetInterval;
+ {* Interval in milliseconds (1000 is default and means 1 second).
+ Note: in UNIX, if an Interval can be set to a value large then 30 minutes,
+ add a conditional definition SUPPORT_LONG_TIMER to the project options. }
+ property OnTimer : TOnEvent read fOnTimer write fOnTimer;
+ {* Event, which is called when time interval is over. }
+ {$IFDEF LIN}
+ {$IFNDEF GTK}
+ {$IFNDEF QT}
+ property Resolution: Integer read fResolution write fResolution; // dummy property, just for compatibility
+ property Periodic: Boolean read fPeriodic write fPeriodic;
+ {$ENDIF QT}
+ {$ENDIF GTK}
+ {$ENDIF LIN}
+ end;
+
+function NewTimer( Interval: Integer ): PTimer;
+{* Constructs initially disabled timer with interval 1000 (1 second). }
+
+{$IFDEF WIN}
+type
+ PMMTimer = ^TMMTimer;
+
+ TMMTimer = object( TTimer )
+ {* Multimedia timer incapsulation object. Does not require Applet or special
+ window to handle it. System creates a thread for each high resolution
+ timer, so using many such objects can degrade total PC performance. }
+ protected
+ FResolution: Integer;
+ FPeriodic: Boolean;
+ procedure SetEnabled(const Value: Boolean); virtual;
+ public
+ destructor Destroy; virtual;
+ {* }
+ property Resolution: Integer read FResolution write FResolution;
+ {* Minimum timer resolution. The less the more accuracy (0 is exactly
+ Interval milliseconds between timer shots). It is recommended to set
+ this property greater to prevent entire system from reducing overhead.
+ If you change this value, reset and then set Enabled again to apply
+ changes. }
+ property Periodic: Boolean read FPeriodic write FPeriodic;
+ {* TRUE, if timer is periodic (default). Otherwise, timer is one-shot
+ (set it Enabled every time in such case for each shot). If you change
+ this property, reset and set Enabled property again to get effect. }
+ end;
+
+function NewMMTimer( Interval: Integer ): PMMTimer;
+{* Creates multimedia timer object. Initially, it has Resolution = 0,
+ Periodic = TRUE and Enabled = FALSE. Do not forget also to assign your
+ event handler to OnTimer to do something on timer shot. }
+{$ENDIF WIN}
+
+{$IFDEF LIN}
+function NewMMTimer( Interval: Integer ): PTimer;
+{$ENDIF LIN}
+
+{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+{ -- TTrayIcon object -- }
+
+type
+ TOnTrayIconMouse = procedure( Sender: PObj; Message : Word ) of object;
+ {* Event type to be called when Applet receives a message from an icon,
+ added to the taskbar tray. }
+
+ PTrayIcon = ^TTrayIcon;
+{ ----------------------------------------------------------------------
+ TTrayIcon - icon in tray area of taskbar
+----------------------------------------------------------------------- }
+ TTrayIcon = object(TObj)
+ {* Object to place (and change) a single icon onto taskbar tray. }
+ protected
+ FIcon: HIcon;
+ FActive: Boolean;
+ FTooltip: KOLString;
+ FOnMouse: TOnTrayIconMouse;
+ FControl: PControl;
+ fAutoRecreate: Boolean;
+ FNoAutoDeactivate: Boolean;
+ FWnd: HWnd;
+ procedure SetIcon(const Value: HIcon);
+ procedure SetActive(const Value: Boolean);
+ procedure SetTrayIcon( const Value : DWORD );
+ procedure SetTooltip(const Value: KOLString);
+ procedure SetAutoRecreate(const Value: Boolean);
+ protected
+ destructor Destroy; virtual;
+ {* Destructor. Use Free method instead (as usual). }
+ public
+ property Icon : HIcon read FIcon write SetIcon;
+ {* Icon to be shown on taskbar tray. If not set, value of Active
+ property has no effect. It is also possible to assign a value
+ to Icon property after assigning True to Active to install
+ icon first time or to replace icon with another one (e.g. to
+ get animation effect).
+ |<br>
+ Previously allocated icon (if any) is not deleted using
+ DeleteObject. This is normal for icons, loaded from resource
+ (e.g., by LoadIcon API call). But if icon was created (e.g.) by
+ CreateIconIndirect, your code is responsible for destroying
+ of it). }
+ property Active : Boolean read FActive write SetActive;
+ {* Set it to True to show assigned Icon on taskbar tray. Default
+ is False. Has no effect if Icon property is not assigned.
+ TrayIcon is deactivated automatically when Applet is finishing
+ (but only if Applet window is used as a "parent" for tray
+ icon object). }
+ property Tooltip : KOLString read FTooltip write SetTooltip;
+ {* Tooltip string, showing automatically when mouse is moving
+ over installed icon. Though "huge string" type is used, only
+ first 63 characters are considered. Also note, that only in
+ most recent versions of Windows multiline tooltips are supported. }
+ property OnMouse : TOnTrayIconMouse read FOnMouse write FOnMouse;
+ {* Is called then mouse message is taking place concerning installed
+ icon. Only type of message can be obtained (e.g. WM_MOUSEMOVE,
+ WM_LBUTTONDOWN etc.) }
+ property AutoRecreate: Boolean read fAutoRecreate write SetAutoRecreate;
+ {* If set to TRUE, auto-recreating of tray icon is proveded in case,
+ when Explorer is restarted for some (unpredictable) reasons. Otherwise,
+ your tray icon is disappeared forever, and if this is the single way
+ to communicate with your application, the user nomore can achieve it. }
+ property NoAutoDeactivate: Boolean read FNoAutoDeactivate write FNoAutoDeactivate;
+ {* If set to true, tray icon is not removed from tray automatically on
+ WM_CLOSE message receive by owner control. Set Active := FALSE in
+ your code for such case before accepting closing the form. }
+ property Wnd: HWnd read FWnd write FWnd;
+ {* A window to use as a base window for tray icon messages. Overrides
+ parent Control handle is assigned. Note, that if Wnd property used,
+ message handling is not done automatically, and you should do this in
+ your code, or at least for one tray icon object, call AttachProc2Wnd. }
+ procedure AttachProc2Wnd;
+ {* Call this method for a tray icon object in case if Wnd used rather then
+ control. It is enough to call this method once for each Wnd used, even
+ if several other tray icons are also based on the same Wnd. See also
+ DetachProc2Wnd method. }
+ procedure DetachProc2Wnd;
+ {* Call this method to detach window procedure attached via AttachProc2Wnd.
+ Do it once for a Wnd, used as a base to handle tray icon messages.
+ Caution! If you do not call this method before destroying Wnd, the
+ application will not functioning normally. }
+ end;
+ {* When You create invisible application, which should be represented by
+ only the tray icon, prepare a handle for the window, resposible for
+ messages handling. Remember, that window handle is created automatically
+ only when a window is showing first time. If window's property Visible is
+ set to False, You should to call CreateWindow manually.
+ <br>
+ There is a known bug exist with similar invisible tray-iconized applications.
+ When a menu is activated in response to tray mouse event, if there was
+ not active window, belonging to the application, the menu is not disappeared
+ when mouse is clicked anywhere else. This bug is occure in Windows9x/ME.
+ To avoid it, activate first your form window. This last window shoud have
+ status visible (but, certainly, there are no needs to place it on visible
+ part of screen - change its position, so it will not be visible for user,
+ if You wish).
+ <br>
+ Also, to make your application "invisible" but until special event is occure,
+ use Applet separate from the main form, and make for both Visible := False.
+ This allows for You to make your form visible any time You wish, and without
+ making application button visible if You do not wish.
+ }
+ {= Когда Вы делаете невидимое приложение, которое должно быть представлено
+ только иконкой в трее, обеспечьте ненулевой Handle для окна, отвечающего
+ за обработку сообщений. Помните, что Handle окна создается автоматически
+ только в тот момент, когда оно должно появиться в первый раз. Если свойство
+ окна Visible установлено в FALSE, необходимо вызвать CreateWindow самостоятельно.
+ <br>
+ Существует известный BUG с подобными невидимыми минимизированными в трей
+ приложениями. Когда в ответ на событие мыши активизирвано выпадающее меню,
+ оно не исчезает по щелчку мыши вне этого меню. Происходит это в Windows9x/ME.
+ чтобы решить эту проблему, сначала активизируйте свое окно (форму). Это окно
+ должно быть видимым (но, конечно, его можно разместить вне пределов видимой
+ части экрана, так что пользователю его видно не будет).
+ <br>
+ Так же, чтобы сделать приложение невидимым, по крайней мере, пока это не
+ потребуется, используйте отдельный представитель класса TControl - глобальную
+ переменную Applet, и присвойте FALSE ее свойству Visible.
+ }
+
+function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon;
+{* Constructor of TTrayIcon object. Pass main form or applet as Wnd
+ parameter. }
+
+{ -- JustOne -- }
+
+type
+ TOnAnotherInstance = procedure( const CmdLine: KOLString ) of object;
+ {* Event type to use in JustOneNotify function. }
+
+function JustOne( Wnd: PControl; const Identifier : KOLString ) : Boolean;
+{* Returns True, if this is a first instance. For all other instances
+ (application is already running), False is returned. }
+
+function JustOneNotify( Wnd: PControl; const Identifier : KOLString;
+ const aOnAnotherInstance: TOnAnotherInstance ) : Boolean;
+{* Returns True, if this is a first instance. For all other instances
+ (application is already running), False is returned. If handler
+ aOnAnotherInstance passed, it is called (in first instance) every time
+ when another instance of an application is started, receiving command
+ line used to run it. }
+
+{ -- string (mainly) utility procedures and functions. -- }
+
+{$IFDEF GDI}
+function MsgBox( const S: KOLString; Flags: DWORD ): DWORD;
+{* Displays message box with the same title as Applet.Caption. If applet
+ is not running, and Applet global variable is not assigned, caption
+ 'Error' is displayed (but actually this is not an error - the system
+ does so, if nil is passed as a title).
+ |<br>
+ Returns ID_... result (correspondently to flags passed (MB_OK, MBYESNO,
+ etc. -> ID_OK, ID_YES, ID_NO, etc.) }
+procedure MsgOK( const S: KOLString );
+{* Displays message box with the same title as Applet.Caption (or 'Error',
+ if Applet is not running). }
+function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD;
+{* Displays message box like MsgBox, but uses Applet.Handle as a parent
+ (so the message has no button on a task bar). }
+procedure ShowMessage( const S: KOLString );
+{* Like ShowMsg, but has only styles MB_OK and MB_SETFOREGROUND. }
+{$ENDIF GDI}
+{$IFDEF WIN}
+{$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}
+{$ENDIF WIN}
+
+function SysErrorMessage(ErrorCode: Integer): KOLString;
+{* Creates and returns a string containing formatted system error message.
+ It is possible then to display this message or write it to a log
+ file, e.g.:
+ ! ShowMsg( SysErrorMessage( GetLastError ) );
+
+ |&R=<a name="%0"></a><font color=#FF8040><h1>%0</h1></font>
+ <R 64-bit integer numbers>
+}
+{$ENDIF WIN_GDI}
+type
+ I64 = record
+ {* 64 bit integer record. Use it and correspondent functions below in KOL
+ projects to avoid dependancy from Delphi version (earlier versions of
+ Delphi had no Int64 type). }
+ Lo, Hi: DWORD;
+ end;
+ PI64 = ^I64;
+ {* }
+
+{$IFNDEF _D4orHigher}
+ Int64 = I64;
+ PInt64 = PI64;
+{$ENDIF}
+
+function MakeInt64( Lo, Hi: DWORD ): I64;
+{* }
+{$IFNDEF PAS_ONLY}
+function Int2Int64( X: Integer ): I64;
+{* }
+procedure IncInt64( var I64: I64; Delta: Integer );
+{* I64 := I64 + Delta; }
+procedure DecInt64( var I64: I64; Delta: Integer );
+{* I64 := I64 - Delta; }
+function Add64( const X, Y: I64 ): I64;
+{* Result := X + Y; }
+function Sub64( const X, Y: I64 ): I64;
+{* Result := X - Y; }
+function Neg64( const X: I64 ): I64;
+{* Result := -X; }
+function Mul64i( const X: I64; Mul: Integer ): I64;
+{* Result := X * Mul; }
+function Div64i( const X: I64; D: Integer ): I64;
+{* Result := X div D; }
+function Mod64i( const X: I64; D: Integer ): Integer;
+{* Result := X mod D; }
+function Sgn64( const X: I64 ): Integer;
+{* Result := sign( X ); i.e.:
+ |<br>
+ if X < 0 then -1
+ |<br>
+ if X = 0 then 0
+ |<br>
+ if X > 0 then 1 }
+function Cmp64( const X, Y: I64 ): Integer;
+{* Result := sign( X - Y ); i.e.
+ |<br>
+ if X < Y then -1
+ |<br>
+ if X = Y then 0
+ |<br>
+ if X > Y then 1 }
+function Int64_2Str( X: I64 ): AnsiString;
+{* }
+function Int64_2Hex( X: I64; MinDigits: Integer ): KOLString;
+{* }
+function Str2Int64( const S: AnsiString ): I64;
+{* }
+function Int64_2Double( const X: I64 ): Double;
+{* }
+function Double2Int64( D: Double ): I64;
+{$ENDIF PAS_ONLY}
+{*
+
+ <R Floating point numbers>
+}
+
+const
+ NAN = 0.0 / 0.0;
+ Infinity = 1.0 / 0.0;
+
+function IsNan(const AValue: Double): Boolean;
+{* Checks if an argument passed is NAN. }
+function IsInfinity(const AValue: Double): Boolean;
+{* Checks if an argument passed is Infinite. }
+function IntPower(Base: Extended; Exponent: Integer): Extended;
+{* Result := Base ^ Exponent; }
+function NextPowerOf2( n: DWORD ): DWORD;
+{* 0->1, 1->1, 2->2, 3->4, 4->4, 5->8, ... }
+function Str2Double( const S: KOLString ): Double;
+{* }
+function Str2Extended( const S: KOLString ): Extended;
+{* }
+function Double2Str( D: Double ): KOLString;
+{* }
+function Extended2Str( E: Extended ): KOLString;
+{* }
+function Extended2StrDigits( D: Double; n: Integer ): KOLString;
+{* Converts floating point number to string, leaving exactly n digits
+ following floating point. }
+function Double2StrEx( D: Double ): KOLString;
+{* experimental, do not use }
+{$IFNDEF PAS_ONLY}
+function TruncD( D: Double ): Double;
+{$ENDIF}
+{* Result := trunc( D ) as Double;
+|<hr>
+
+ <R Small bit arrays (max 32 bits in array)>
+ See also TBits object.
+}
+
+function IfThenElseBool( t, e, Cond: Boolean ): Boolean;
+function IfThenElseInt( t, e: Integer; Cond: Boolean ): Integer;
+function IfThenElseStr( const t, e: AnsiString; Cond: Boolean ): AnsiString;
+{$IFDEF _D5orHigher}
+function IfThenElse( t, e: Boolean; Cond: Boolean ): Boolean; overload;
+function IfThenElse( t, e: Integer; Cond: Boolean ): Integer; overload;
+function IfThenElse( t, e: AnsiString; Cond: Boolean ): AnsiString; overload;
+function IfThenElse( t, e: Double; Cond: Boolean ): Double; overload;
+{$ENDIF}
+
+function GetBits( N: DWORD; first, last: Byte ): DWord;
+{* Retuns bits straing from <first> and to <last> inclusively. }
+function GetBitsL( N: DWORD; from, len: Byte ): DWord;
+{* Retuns len bits starting from index <from>.
+|<hr>
+
+ <R Arithmetics, geometry and other utility functions>
+
+ See also units KolMath.pas, CplxMath.pas and Err.pas.
+}
+//[MulDiv DECLARATION]
+{$IFNDEF FPC}
+function MulDiv( A, B, C: Integer ): Integer;
+{* Returns A * B div C. Small and fast. }
+{$ENDIF}
+
+ function MakeRect( Left, Top, Right, Bottom: Integer ): TRect; stdcall;
+ {* Use it instead of VCL Rect function }
+ function RectsEqual( const R1, R2: TRect ): Boolean;
+ {* Returns True if rectangles R1 and R2 have the same bounds }
+ function RectsIntersected( const R1, R2: TRect ): Boolean;
+ {* Returns TRUE if rectangles R1 and R2 have at least one common point.
+ Note, that right and bottom bounds of rectangles are not their part,
+ so, if such points are lying on that bounds, FALSE is returned. }
+ function PointInRect( const P: TPoint; const R: TRect ): Boolean;
+ {* Returns True if point P is located in rectangle R (including
+ left and top bounds but without right and bottom bounds of the
+ rectangle). }
+ function OffsetPoint( const T: TPoint; dX, dY: Integer ): TPoint;
+ {* }
+ function OffsetSmallPoint( const T: TSmallPoint; dX, dY: SmallInt ): TSmallPoint;
+ {* }
+ function Point2SmallPoint( const T: TPoint ): TSmallPoint;
+ {* }
+ function SmallPoint2Point( const T: TSmallPoint ): TPoint;
+ {* }
+ function MakePoint( X, Y: Integer ): TPoint;
+ {* Use instead of VCL function Point }
+ function MakeSmallPoint( X, Y: Integer ): TSmallPoint;
+ {* Use to construct TSmallPoint }
+ function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer;
+ {* }
+ function MakeDateTimeRange( D1, D2: TDateTime ): TDateTimeRange;
+ {* Returns TDateTimeRange from two TDateTime bounds. }
+ procedure Swap( var X, Y: Integer );
+ {* exchanging values }
+ function Min( X, Y: Integer ): Integer;
+ {* minimum of two integers }
+ function Max( X, Y: Integer ): Integer;
+ {* maximum of two integers }
+{$IFDEF REDEFINE_ABS}
+ function Abs( X: Integer ): Integer;
+ {* absolute value }
+{$ENDIF}
+ function Sgn( X: Integer ): Integer;
+ {* sign of X: if X < 0, -1 is returned, if > 0, then +1, otherwise 0. }
+ function iSqrt( X: Integer ): Integer;
+ {* square root }
+ function iCbrt( X: DWORD ): Integer;
+ {* cubic root
+ |<hr>
+ <R String to number and number to string conversions>
+}
+function Int2Hex( Value : DWord; Digits : Integer ) : KOLString;
+{* Converts integer Value into string with hex number. Digits parameter
+ determines minimal number of digits (will be completed by adding
+ necessary number of leading zeroes). }
+function Int2Str( Value : Integer ) : KOLString;
+{* Obvious. }
+procedure Int2PChar( s: PAnsiChar; Value: Integer );
+{* Converts Value to string and puts it into buffer s. Buffer must have
+ enough size to store the number converted: buffer overflow does
+ not checked anyway! }
+function UInt2Str( Value: DWORD ): AnsiString;
+{* The same as Int2Str, but for unsigned integer value. }
+function Int2StrEx( Value, MinWidth: Integer ): KOLString;
+{* Like Int2Str, but resulting string filled with leading spaces to provide
+ at least MinWidth characters. }
+function Int2Rome( Value: Integer ): KOLString;
+{* Represents number 1..8999 to Rome numer. }
+function Int2Ths( I: Integer ): KOLString;
+{* Converts integer into string, separating every three digits from each
+ other by character ThsSeparator. (Convert to thousands). You }
+function Int2Digs( Value, Digits: Integer ): KOLString;
+{* Converts integer to string, inserting necessary number of leading zeroes
+ to provide desired length of string, given by Digits parameter. If
+ resulting string is greater then Digits, string is not truncated anyway. }
+function Num2Bytes( Value : Double ) : KOLString;
+{* Converts double float to string, considering it as a bytes count.
+ If Value is sufficiently large, number is represented in kilobytes (with
+ following letter K), or in megabytes (M), gigabytes (G) or terabytes (T).
+ Resulting string number is truncated to two decimals (.XX) or to one (.X),
+ if the second is 0. }
+function S2Int( S: PKOLChar ): Integer;
+{* Converts null-terminated string to Integer. Scanning stopped when any
+ non-digit character found. Even empty string or string not containing
+ valid integer number silently converted to 0. }
+function Str2Int(const Value : KOLString) : Integer;
+{* Converts string to integer. First character, which can not be
+ recognized as a part of number, regards as a separator. Even
+ empty string or string without number silently converted to 0. }
+function Hex2Int( const Value : KOLString) : Integer;
+{* Converts hexadecimal number to integer. Scanning is stopped
+ when first non-hexadicimal character is found. Leading dollar ('$')
+ character is skept (if present). Minus ('-') is not concerning as
+ a sign of number and also stops scanning.}
+function cHex2Int( const Value : KOLString) : Integer;
+{* As Hex2Int, but also checks for leading '0x' and skips it. }
+function Octal2Int( const Value: AnsiString ) : Integer;
+{* Converts octal number to integer. Scanning is stopped on first
+ non-octal digit (any char except 0..7). There are no checking if
+ there octal numer in the parameter. If the first char is not octal
+ digit, 0 is returned. }
+function Binary2Int( const Value: AnsiString ) : Integer;
+{* Converts binary number to integer. Like Octal2Int, but only digits
+ 0 and 1 are allowed. }
+type Radix_int = {$IFDEF _D5orHigher} Int64 {$ELSE} Integer {$ENDIF};
+function ToRadix( number: Radix_int; radix, min_digits: Integer ): KOLString;
+{* Converts unsigned number to string representing it literally in a numeric
+ base given by radix parameter. }
+function FromRadixStr( var Rslt: Radix_int; s: PKOLChar; radix: Integer ): PKOLChar;
+{* Converts unsigned number from string representation in a numeric base given by
+ a radix parameter. Returns a pointer to a character next to the last digit of
+ the number. }
+function FromRadix( const s: AnsiString; radix: Integer ): Radix_int;
+{* Converts unsigned number from string representation in a numeric base given by
+ a radix parameter. See also: FromRadixStr function. }
+function InsertSeparators( const s: KOLString; chars_between: Integer;
+ Separator: KOLChar ): KOLString;
+{* Inserts given Separator between symbols in s, separating each portion of
+ chars_between characters with a Separator starting from right side. See also:
+ Int2Ths function. }
+{$IFDEF WIN}
+{$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).
+|<hr>
+
+ <R Working with null-terminated and ansi strings>
+}
+{$ENDIF _FPC}
+{$ENDIF WIN}
+function StrComp(const Str1, Str2: PAnsiChar): Integer;
+{* Compares two strings fast. -1: Str1<Str2; 0: Str1=Str2; +1: Str1>Str2 }
+
+{$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 Str1<Str2; 0 when Str1=Str2; +1 when Str1>Str2 }
+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 Str1<Str2; 0 when Str1=Str2; +1 when Str1>Str2 }
+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. }
+
+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. }
+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. }
+function StrScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar;
+{* 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. }
+function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean;
+{* Returns True, if string Str is starting from Pattern, i.e. if
+ Copy( Str, 1, StrLen( Pattern ) ) = Pattern. Str must not be nil! }
+function StrIsStartingFromNoCase( Str, Pattern: 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. }
+function TrimRight(const S: KOLString): KOLString;
+{* Removes spaces, tabulates and other control characters from the
+ end of string S. }
+function Trim( const S : KOLString): KOLString;
+{* Makes TrimLeft and TrimRight for given string. }
+function RemoveSpaces( const S: KOLString ): KOLString;
+{* Removes all characters less or equal to ' ' in S and returns it. }
+procedure Str2LowerCase( S: PAnsiChar );
+{* Converts null-terminated string to lowercase (inplace). }
+function LowerCase(const S: Ansistring): Ansistring;
+{* Obvious. }
+function UpperCase(const S: Ansistring): Ansistring;
+{* Obvious. }
+function AnsiUpperCase(const S: Ansistring): Ansistring;
+{* Obvious. }
+function AnsiLowerCase(const S: Ansistring): Ansistring;
+{* Obvious. }
+function KOLUpperCase(const S: KOLString): KOLString;
+{* Obvious. }
+function KOLLowerCase(const S: KOLString): KOLString;
+{* Obvious. }
+{$IFDEF _D3orHigher}
+function WUpperCase(const S: KOLWideString): KOLWideString;
+{* Obvious. }
+function WLowerCase(const S: KOLWideString): KOLWideString;
+{* Obvious. }
+{$ENDIF}
+{$IFNDEF _D2}
+{$IFNDEF _FPC}
+function WAnsiUpperCase(const S: KOLWideString): KOLWideString;
+{* Obvious. }
+function WAnsiLowerCase(const S: KOLWideString): KOLWideString;
+{* Obvious. }
+function WStrComp(const S1, S2: KOLWideString): Integer;
+{* }
+function _WStrComp(S1, S2: PWideChar): Integer;
+{* }
+function _WStrLComp(S1, S2: PWideChar; Len: Integer): Integer;
+{* }
+function WStrScan(Str: PWideChar; Chr: WideChar): PWideChar;
+{* Fast search of given character in a string. Pointer to found character
+ (or nil) is returned. }
+function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar;
+{* StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr
+ does not occur in Str, StrRScan returns NIL. The null terminator is
+ considered to be part of the string. }
+{$ENDIF _FPC}
+{$ENDIF _D2}
+//--- set of functions to work either with AnsiString or with KOLWideString
+// depending on UNICODE_CTRLS symbol ----------------------------------------
+function AnsiCompareStr(const S1, S2: KOLString): Integer;
+{* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare
+ operation is controlled by the current Windows locale. The return value
+ is the same as for CompareStr. }
+function _AnsiCompareStr(S1, S2: PKOLChar): Integer;
+{* The same, but for PChar ANSI strings }
+function AnsiCompareStrNoCase(const S1, S2: KOLString): Integer;
+{* 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;
+{* The same, but for PChar ANSI strings }
+function AnsiCompareText( const S1, S2: KOLString ): Integer;
+{* }
+function AnsiEq( const S1, S2 : KOLString ) : Boolean;
+{* Returns True, if AnsiLowerCase(S1) = AnsiLowerCase(S2). I.e., if ANSI
+ stringsare equal to each other without caring of characters case
+ sensitivity. }
+
+//--- set of functions to work always with AnsiString
+// even if UNICODE_CTRLS symbol is defined ----------------------------------
+function AnsiCompareStrA(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 _AnsiCompareStrA_Slow(S1, S2: PAnsiChar): Integer;
+function _AnsiCompareStrA_Fast(S1, S2: PAnsiChar): Integer;
+var _AnsiCompareStrA: function(S1, S2: PAnsiChar): Integer =
+ {$IFDEF SPEED_FASTER} _AnsiCompareStrA_Fast
+ {$ELSE} _AnsiCompareStrA_Slow {$ENDIF};
+{* The same, but for PChar ANSI strings }
+function _AnsiCompareStrA_Fast2(S1, S2: PAnsiChar): Integer;
+function _AnsiCompareStrNoCaseA_Fast2(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(S1, S2: PAnsiChar): Integer;
+function _AnsiCompareStrNoCaseA_Fast(S1, S2: PAnsiChar): Integer;
+var _AnsiCompareStrNoCaseA: function(S1, S2: PAnsiChar): Integer =
+ {$IFDEF SPEED_FASTER} _AnsiCompareStrNoCaseA_Fast
+ {$ELSE} _AnsiCompareStrNoCaseA_Slow {$ENDIF};
+{* The same, but for PChar ANSI strings }
+function AnsiCompareTextA( const S1, S2: AnsiString ): Integer;
+{* }
+
+{$IFDEF WIN}
+{$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;
+{$ENDIF WIN}
+
+function CopyEnd( const S : KOLString; Idx : Integer ) : KOLString;
+{* Returns copy of source string S starting from Idx up to the end of
+ string S. Works correctly for case, when Idx > Length( S ) (returns
+ empty string for such case). }
+function CopyTail( const S : KOLString; Len : Integer ) : KOLString;
+{* Returns last Len characters of the source string. If Len > Length( S ),
+ entire string S is returned. }
+procedure DeleteTail( var S : KOLString; Len : Integer );
+{* Deletes last Len characters from string. }
+function IndexOfChar( const S : KOLString; Chr : KOLChar ) : Integer;
+{* Returns index of given character (1..Length(S)), or
+ -1 if a character not found. }
+function IndexOfCharsMin( const S, Chars : KOLString ) : Integer;
+{* Returns index (in string S) of those character, what is taking place
+ in Chars string and located nearest to start of S. If no such
+ characters in string S found, -1 is returned. }
+{$IFDEF _D3orHigher}
+function WIndexOfChar( const S : KOLWideString; Chr : WideChar ) : Integer;
+function WIndexOfCharsMin( const S, Chars : KOLWideString ) : Integer;
+{$ENDIF}
+{$IFNDEF _D2}
+{$IFNDEF _FPC}
+function IndexOfWideCharsMin( const S, Chars : KOLWideString ) : Integer;
+{* Returns index (in wide string S) of those wide character, what
+ is taking place in Chars wide string and located nearest to start of S.
+ If no such characters in string S found, -1 is returned. }
+{$ENDIF _FPC}
+{$ENDIF _D2}
+
+function IndexOfStr( const S, Sub : KOLString ) : Integer;
+{* Returns index of given substring in source string S. If found,
+ 1..Length(S)-Length(Sub), if not found, -1. }
+function Parse( var S : KOLString; const Separators : KOLString ) : KOLString;
+{* Returns first characters of string S, separated from others by
+ one of characters, taking place in Separators string, assigning
+ a tail of string (after found separator) to source string. If
+ no separator characters found, source string S is returned, and
+ source string itself becomes empty. }
+{$IFDEF _D3orHigher}
+function ParseW( var S : KOLWideString; const Separators : KOLWideString ) : KOLWideString;
+{$ENDIF}
+
+{$IFNDEF _FPC}
+{$IFNDEF _D2}
+function WParse( var S : KOLWideString; const Separators : KOLWideString ) : KOLWideString;
+{* Returns first wide characters of wide string S, separated from others
+ by one of wide characters, taking place in Separators wide string,
+ assigning a tail of wide string (following found separator) to the
+ source one. If there are no separator characters found, source wide
+ string S is returned, and source wide string itself becomes empty. }
+{$ENDIF _D2}
+{$ENDIF _FPC}
+function ParsePascalString( var S : KOLString; const Separators : KOLString ) : KOLString;
+{* Returns first characters of string S, separated from others by
+ one of characters, taking place in Separators string, assigning
+ a tail of string (after the found separator) to source string. If
+ there are no separator characters found, the source string S is returned,
+ and the source string itself becomes empty. Additionally: if the first (after
+ a blank space) is the quote "'" or '#', pascal string is assumung first
+ and is converted to usual string (without quotas) before analizing
+ of other separators. }
+function String2PascalStrExpr( const S : KOLString ) : KOLString;
+{* Converts string to Pascal-like string expression (concatenation of
+ strings with quotas and characters with leading '#'). }
+function StrEq( const S1, S2 : AnsiString ) : Boolean;
+{* Returns True, if LowerCase(S1) = LowerCase(S2). I.e., if strings
+ are equal to each other without caring of characters case sensitivity
+ (ASCII only). }
+{$IFNDEF _D2}
+{$IFNDEF _FPC}
+function WAnsiEq( const S1, S2 : KOLWideString ) : Boolean;
+{* Returns True, if AnsiLowerCase(S1) = AnsiLowerCase(S2). I.e., if ANSI
+ stringsare equal to each other without caring of characters case
+ sensitivity. }
+{$ENDIF _FPC}
+{$ENDIF _D2}
+
+function StrIn( const S : AnsiString; const A : array of AnsiString ) : Boolean;
+{* Returns True, if S is "equal" to one of strings, taking place
+ in A array. To check equality, StrEq function is used, i.e.
+ comaprison is taking place without case sensitivity. }
+{$IFNDEF _FPC}
+type TSetOfChar = Set of AnsiChar;
+{$IFNDEF _D2}
+function WStrIn( const S : KOLWideString; const A : array of KOLWideString ) : Boolean;
+{* Returns True, if S is "equal" to one of strings, taking place
+ in A array. To check equality, WAnsiEq function is used, i.e.
+ comaprison is taking place without case sensitivity. }
+function CharIn( C: KOLChar; const A: TSetOfChar ): Boolean;
+{* To replace expressions like S[1] in [ '0'..'z' ] to CharIn( S[ 1 ], [ '0'..'z' ] )
+ (and to avoid problems with Unicode version of code). }
+{$ENDIF _D2}
+{$ENDIF _FPC}
+function StrIs( const S : AnsiString; const A : Array of AnsiString; var Idx: Integer ) : Boolean;
+{* Returns True, if S is "equal" to one of strings, taking place
+ in A array, and in such Case Idx also is assigned to an index of A element
+ equal to S. To check equality, StrEq function is used, i.e.
+ comaprison is taking place without case sensitivity. }
+function IntIn( Value: Integer; const List: array of Integer ): Boolean;
+{* Returns TRUE, if Value is found in a List. }
+function _StrSatisfy( S, Mask : PKOLChar ) : Boolean;
+{* }
+function _2StrSatisfy( S, Mask: PKOLChar ): Boolean;
+{* }
+function StrSatisfy( const S, Mask : KOLString ) : Boolean;
+{* Returns True, if S is satisfying to a given Mask (which can contain
+ wildcard symbols '*' and '?' interpeted correspondently as 'any
+ set of characters' and 'single any character'. If there are no
+ such wildcard symbols in a Mask, result is True only if S is maching
+ to Mask string.) }
+function StrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean;
+{* Replaces first occurance of From to ReplTo in S, returns True,
+ if pattern From was found and replaced. }
+function KOLStrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean;
+{* Replaces first occurance of From to ReplTo in S, returns True,
+ if pattern From was found and replaced. }
+{$IFNDEF _FPC}
+{$IFNDEF _D2}
+function WStrReplace( var S: KOLWideString; const From, ReplTo: KOLWideString ): Boolean;
+{* Replaces first occurance of From to ReplTo in S, returns True,
+ if pattern From was found and replaced. See also function StrReplace.
+ This function is not available in Delphi2 (this version of Delphi
+ does not support KOLWideString type). }
+{$ENDIF _D2}
+{$ENDIF _FPC}
+
+function StrRepeat( const S: KOLString; Count: Integer ): KOLString;
+{* Repeats given string Count times. E.g., StrRepeat( 'A', 5 ) gives 'AAAAA'. }
+{$IFNDEF _FPC}
+{$IFNDEF _D2}
+function WStrRepeat( const S: KOLWideString; Count: Integer ): KOLWideString;
+{* Repeats given wide string Count times. E.g., StrRepeat( 'A', 5 ) gives 'AAAAA'. }
+{$ENDIF _D2}
+{$ENDIF _FPC}
+
+procedure NormalizeUnixText( var S: AnsiString );
+{* In the string S, replaces all occurances of character #10 (without leading #13)
+ to the character #13. }
+procedure Koi8ToAnsi( s: PAnsiChar );
+{* Converts Koi8 text to Ansi (in place) }
+const KOI8_Rus: array[ #$C0..#$FF ] of AnsiChar = (
+ { 'ю',
+ 'а', 'б', 'ц', 'д', 'е', 'ф', 'г', 'х', 'и', 'й', 'к', 'л', 'м', 'н', 'о', 'п',
+ 'я', 'р', 'с', 'т', 'у', 'ж', 'в', 'ь', 'ы', 'з', 'ш', 'э', 'щ', 'ч', 'ъ',
+ 'Ю',
+ 'А', 'Б', 'Ц', 'Д', 'Е', 'Ф', 'Г', 'Х', 'И', 'Й', 'К', 'Л', 'М', 'Н', 'О', 'П',
+ 'Я', 'Р', 'С', 'Т', 'У', 'Ж', 'В', 'Ь', 'Ы', 'З', 'Ш', 'Э', 'Щ', 'Ч', 'Ъ'}
+ #$FE,
+ #$E0, #$E1, #$F6, #$E4, #$E5, #$F4, #$E3, #$F5, #$E8, #$E9, #$EA, #$EB, #$EC, #$ED, #$EE, #$EF,
+ #$FF, #$F0, #$F1, #$F2, #$F3, #$E6, #$E2, #$FC, #$FB, #$E7, #$F8, #$FD, #$F9, #$F7, #$FA,
+ #$DE,
+ #$C0, #$C1, #$D6, #$C4, #$C5, #$D4, #$C3, #$D5, #$C8, #$C9, #$CA, #$CB, #$CC, #$CD, #$CE, #$CF,
+ #$DF, #$D0, #$D1, #$D2, #$D3, #$C6, #$C2, #$DC, #$DB, #$C7, #$D8, #$DD, #$D9, #$D7, #$DA
+ );
+
+function StrPCopy(Dest: PAnsiChar; const Source: Ansistring): PAnsiChar;
+{* Copyes string into null-terminated. }
+function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar;
+{* Copyes first MaxLen characters of the Source string into null-terminated Dest. }
+
+function DelimiterLast( const Str, Delimiters: KOLString ): Integer;
+{* Returns index of the last of delimiters given by same named parameter
+ among characters of Str. If there are no delimiters found, length of
+ Str is returned. This function is intended mainly to use in filename
+ parsing functions. }
+function __DelimiterLast( Str, Delimiters: PKOLChar ): PKOLChar;
+{* Returns address of the last of delimiters given by Delimiters parameter
+ among characters of Str. If there are no delimeters found, position of
+ the null terminator in Str is returned. This function is intended
+ mainly to use in filename parsing functions. }
+{$IFDEF _D3orHigher}
+function W__DelimiterLast( Str, Delimiters: PWideChar ): PWideChar;
+{* }
+{$ENDIF _D3orHigher}
+function SkipSpaces( P: PKOLChar ): PKOLChar;
+{* Skips all characters #1..' ' in a string.
+}
+{$IFDEF F_P}
+function DummyStrFun( const S: AnsiString ): AnsiString;
+{$ENDIF}
+
+function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;
+{* Fast compare of two memory blocks. }
+function AllocMem( Size : Integer ) : Pointer;
+{* Allocates global memory and unlocks it. }
+procedure DisposeMem( var Addr : Pointer );
+{* Locks global memory block given by pointer, and frees it.
+ Does nothing, if the pointer is nil.
+ |<hr>
+
+ <R Text in clipboard operations>
+}
+{$IFDEF WIN_GDI}
+
+function ClipboardHasText: Boolean;
+{* Returns true, if the clipboard contain text to paste from. }
+function Clipboard2Text: AnsiString;
+{* If clipboard contains text, this function returns it for You. }
+{$IFNDEF _FPC}
+{$IFNDEF _D2}
+function Clipboard2WText: KOLWideString;
+{* If clipboard contains text, this function returns it for You (as Unicode string). }
+{$ENDIF _D2}
+{$ENDIF _FPC}
+function Text2Clipboard( const S: AnsiString ): Boolean;
+{* Puts given string to a clipboard. }
+{$IFNDEF _FPC}
+{$IFNDEF _D2}
+function WText2Clipboard( const WS: KOLWideString ): Boolean;
+{* Puts given Unicode string to a clipboard.
+|<hr>
+}
+{$ENDIF _D2}
+{$ENDIF _FPC}
+
+var SearchMnemonics: function ( const S: KOLString ): KOLString
+ = {$IFDEF F_P} DummyStrFun {$ELSE}
+ {$IFDEF UNICODE_CTRLS} WAnsiUpperCase {$ELSE} AnsiUpperCase {$ENDIF} {$ENDIF};
+ MnemonicsLocale: Integer;
+
+procedure SupportAnsiMnemonics( LocaleID: Integer );
+{* Provides encoding to work with given locale. Call this global function to
+ extend TControl.SupportMnemonics capability (also should be called for a form
+ or for Applet variable).
+
+ <R Date and time handling>
+}
+{$ENDIF WIN_GDI}
+{$IFDEF WIN_GDI}
+
+{$IFnDEF _D5orHigher}
+ {$DEFINE DATE0_0001}
+{$ENDIF _D5orHigher}
+{$IFnDEF DATE0_0001}
+ {$DEFINE DATE0_1601}
+{$ENDIF} //Starting from the version 3.1415926, (so called PI-version), datetime
+ //can be correctly handled (by default) from 1-Jan-1601 to 1-Jan-38827.
+ //This made it possible to use short calls to API functions to convert date and time.
+ //If you still want to count time correctly from 1-Jan-1 B.C., or a compatibility
+ //is required for old applications, define symbol DATE0_0001 in your
+ //project options. Actually this does not mean that TDateTime forma changed,
+ //but only restrictions are in converting date to TSystemTime from TDateTime
+ //and vice versa.
+type
+ //TDateTime = Double; // well, it is already defined so in System.pas
+ {* Basic date and time type. Integer part represents year and days (as is,
+ i.e. 1-Jan-2000 is representing by value 730141, which is a number of
+ days from 1-Jan-0001 to 1-Jan-2000 inclusively). Fractional part is
+ representing hours, minutes, seconds and milliseconds of a day
+ proportionally (like in VCL TDateTime type, e.g. 0.5 = 12:00, 0.25 = 6:00,
+ etc.). }
+
+ PDayTable = ^TDayTable;
+ TDayTable = array[1..12] of Byte;
+
+ TDateFormat = ( dfShortDate, dfLongDate );
+ {* Date formats available to use in formatting date/time to string. }
+ TTimeFormatFlag = ( tffNoMinutes, tffNoSeconds, tffNoMarker, tffForce24 );
+ {* Additional flags, used for formatting time. }
+ TTimeFormatFlags = Set of TTimeFormatFlag;
+ {* Set of flags, used for formatting time. }
+
+const
+ MonthDays: array [Boolean] of TDayTable =
+ ((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
+ (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31));
+ {* The MonthDays array can be used to quickly find the number of
+ days in a month: MonthDays[IsLeapYear(Y), M]. }
+
+ SecsPerDay = 24 * 60 * 60;
+ {* Seconds per day. }
+ MSecsPerDay = SecsPerDay * 1000;
+ {* Milliseconds per day. }
+
+ Date1601 = 584389;
+ VCLDate0 = 693594;
+ {* Value to convert VCL "date 0" to KOL "date 0" and back.
+ This value corresponds to 30-Dec-1899, 0:00:00. So,
+ to convert VCL date to KOL date, just subtract this
+ value from VCL date. And to convert back from KOL date
+ to VCL date, add this value to KOL date.}
+
+function Now : TDateTime;
+{* Returns local date and time on running PC. }
+function Date: TDateTime;
+{* Returns todaylocal date. }
+procedure DecodeDateFully( DateTime: TDateTime; var Year, Month, Day, DayOfWeek: WORD );
+{* Decodes date. }
+procedure DecodeDate( DateTime: TDateTime; var Year, Month, Day: WORD );
+{* Decodes date. }
+function EncodeDate( Year, Month, Day: WORD; var DateTime: TDateTime ): Boolean;
+{* Encodes date. }
+function CompareSystemTime(const D1, D2 : TSystemTime) : Integer;
+{* Compares to TSystemTime records. Returns -1, 0, or 1 if, correspondantly,
+ D1 < D2, D1 = D2 and D1 > D2. }
+procedure IncDays( var SystemTime : TSystemTime; DaysNum : Integer );
+{* Increases/decreases day in TSystemTime record onto given days count
+ (can be negative). }
+procedure IncMonths( var SystemTime : TSystemTime; MonthsNum : Integer );
+{* Increases/decreases month number in TSystemTime record onto given
+ months count (can be negative). Correct result is not garantee if
+ day number is incorrect for newly obtained month. }
+function IsLeapYear(Year: Integer): Boolean;
+{* Returns True, if given year is "leap" (i.e. has 29 days in the February). }
+function DayOfWeek(Date: TDateTime): Integer;
+{* Returns day of week (0..6) for given date. }
+function SystemTime2DateTime(const SystemTime : TSystemTime; var DateTime : TDateTime ) : Boolean;
+{* Converts TSystemTime record to XDateTime variable. }
+function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
+{* Converts TDateTime variable to TSystemTime record. }
+function DateTime_System2Local( DTSys: TDateTime ): TDateTime;
+{* Converts DTSys representing system time (+0 Grinvich) to local time. }
+function DateTime_Local2System( DTLoc: TDateTime ): TDateTime;
+{* Converts DTLoc representing local time to system time (+0 Grinvich) }
+function FileTime2DateTime( const ft: TFileTime; var DT: TDateTime ): Boolean;
+{* }
+function DateTime2FileTime( DT: TDateTime; var ft: TFileTime ): Boolean;
+{* }
+
+procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: Word);
+{* Dividing of integer onto divisor with obtaining both result of division
+ and remainder. }
+
+function SystemDate2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;
+ const DfltDateFormat : TDateFormat;
+ const DateFormat : PKOLChar ) : KOLString;
+{* Formats date, stored in TSystemTime record into string, using given locale
+ and date/time formatting flags. (E.g.: GetUserDefaultLangID). }
+function SystemTime2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;
+ const Flags : TTimeFormatFlags;
+ const TimeFormat : PKOLChar ) : KOLString;
+{* Formats time, stored in TSystemTime record into string, using given locale
+ and date/time formatting flags. }
+
+function Date2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString;
+{* Represents date as a string correspondently to Fmt formatting string.
+ See possible pictures in definition of the function Str2DateTimeFmt
+ (the first part). If Fmt string is empty, default system date format
+ for short date string used. }
+function Time2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString;
+{* Represents time as a string correspondently to Fmt formatting string.
+ See possible pictures in definition of the function Str2DateTimeFmt
+ (the second part). If Fmt string is empty, default system time format
+ for short date string used. }
+function DateTime2StrShort( D: TDateTime ): KOLString;
+{* Formats date and time to string in short date format using current user
+ locale. }
+function Str2DateTimeFmt( const sFmtStr, sS: KOLString ): TDateTime;
+{* Restores date or/and time from string correspondently to a format string.
+ Date and time formatting string can contain following pictures (case
+ sensitive):
+ |<pre>
+ DATE PICTURES
+ d Day of the month as digits without leading zeros for single digit days.
+ dd Day of the month as digits with leading zeros for single digit days
+ ddd Day of the week as a 3-letter abbreviation as specified by a
+ LOCALE_SABBREVDAYNAME value.
+ dddd Day of the week as specified by a LOCALE_SDAYNAME value.
+ M Month as digits without leading zeros for single digit months.
+ MM Month as digits with leading zeros for single digit months
+ MMM Month as a three letter abbreviation as specified by a LOCALE_SABBREVMONTHNAME value.
+ MMMM Month as specified by a LOCALE_SMONTHNAME value.
+ y Year represented only be the last digit.
+ yy Year represented only be the last two digits.
+ yyyy Year represented by the full 4 digits.
+ gg Period/era string as specified by the CAL_SERASTRING value. The gg
+ format picture in a date string is ignored if there is no associated era
+ string. In Enlish locales, usual values are BC or AD.
+
+ TIME PICTURES
+ h Hours without leading zeros for single-digit hours (12-hour clock).
+ hh Hours with leading zeros for single-digit hours (12-hour clock).
+ H Hours without leading zeros for single-digit hours (24-hour clock).
+ HH Hours with leading zeros for single-digit hours (24-hour clock).
+ m Minutes without leading zeros for single-digit minutes.
+ mm Minutes with leading zeros for single-digit minutes.
+ s Seconds without leading zeros for single-digit seconds.
+ ss Seconds with leading zeros for single-digit seconds.
+ t One character–time marker string (usually P or A, in English locales).
+ tt Multicharacter–time marker string (usually PM or AM, in English locales).
+ |</pre>
+ E.g., 'D, yyyy/MM/dd h:mm:ss'.
+ See also Str2DateTimeShort function.
+ }
+function Str2TimeFmt(const sFmtStr, sS: KOLString): TDateTime;
+{* Same as above but for time only }
+function Str2DateTimeShort( const S: KOLString ): TDateTime;
+{* Restores date and time from string correspondently to current user locale. }
+function Str2DateTimeShortEx( const S: KOLString ): TDateTime;
+{* Like Str2DateTimeShort above, but uses locale defined date and time
+ separators to avoid recognizing time as a date in some cases.}
+function Str2TimeShort(const S: KOLString): TDateTime;
+{* Like Str2DateTimeShort but for time only.
+|<hr>
+
+ <R File and directory routines>
+}
+{$ENDIF WIN_GDI}
+
+const
+ ofOpenRead = {$IFDEF LIN} O_RDONLY {$ELSE} $80000000 {$ENDIF};
+ {* Use this flag (in combination with others) to open file for "read" only. }
+ ofOpenWrite = {$IFDEF LIN} O_WRONLY {$ELSE} $40000000 {$ENDIF};
+ {* Use this flag (in combination with others) to open file for "write" only. }
+ ofOpenReadWrite = {$IFDEF LIN} O_RDWR {$ELSE} $C0000000 {$ENDIF};
+ {* Use this flag (in combination with others) to open file for "read" and "write". }
+
+ ofShareExclusive = {$IFDEF LIN} $10 {$ELSE} $00 {$ENDIF};
+ {* Use this flag (in combination with others) to open file for exclusive use. }
+ ofShareDenyWrite = {$IFDEF LIN} $20 {$ELSE} $01 {$ENDIF};
+ {* Use this flag (in combination with others) to open file in share mode, when
+ only attempts to open it in other process for "write" will be impossible.
+ I.e., other processes could open this file simultaneously for read only
+ access. }
+ ofShareDenyRead = {$IFDEF LIN} 0 {not supported} {$ELSE} $02 {$ENDIF};
+ {* Use this flag (in combination with others) to open file in share mode, when
+ only attempts to open it for "read" in other processes will be disabled.
+ I.e., other processes could open it for "write" only access. }
+ ofShareDenyNone = {$IFDEF LIN} $30 {$ELSE} $03 {$ENDIF};
+ {* Use this flag (in combination with others) to open file in full sharing mode.
+ I.e. any process will be able open this file using the same share flag. }
+ ofCreateNew = {$IFDEF LIN} O_CREAT or O_TRUNC {$ELSE} $100 {$ENDIF};
+ {* Default creation disposition. Use this flag for creating new file (usually
+ for write access. }
+ ofCreateAlways = {$IFDEF LIN} O_CREAT {$ELSE} $200 {$ENDIF};
+ {* Use this flag (in combination with others) to open existing or creating new
+ file. If existing file is opened, it is truncated to size 0. }
+ ofOpenExisting = {$IFDEF LIN} 0 {$ELSE} $300 {$ENDIF};
+ {* Use this flag (in combination with others) to open existing file only. }
+ ofOpenAlways = {$IFDEF LIN} O_CREAT {$ELSE} $400 {$ENDIF};
+ {* Use this flag (in combination with others) to open existing or create new
+ (if such file is not yet exists). }
+ ofTruncateExisting = {$IFDEF LIN} O_TRUNC {$ELSE} $500 {$ENDIF};
+ {* Use this flag (in combination with others) to open existing file and truncate
+ it to size 0. }
+
+ ofAttrReadOnly = {$IFDEF LIN} 0 {$ELSE} $10000 {$ENDIF};
+ {* Use this flag to create Read-Only file (?). }
+ ofAttrHidden = {$IFDEF LIN} 0 {$ELSE} $20000 {$ENDIF};
+ {* Use this flag to create hidden file. }
+ ofAttrSystem = {$IFDEF LIN} 0 {$ELSE} $40000 {$ENDIF};
+ {* Use this flag to create system file. }
+ ofAttrTemp = {$IFDEF LIN} 0 {$ELSE} $1000000 {$ENDIF};
+ {* Use this flag to create temp file. }
+ ofAttrArchive = {$IFDEF LIN} 0 {$ELSE} $200000 {$ENDIF};
+ {* Use this flag to create archive file. }
+ ofAttrCompressed = {$IFDEF LIN} 0 {$ELSE} $8000000 {$ENDIF};
+ {* Use this flag to create compressed file. Has effect only on NTFS, and
+ only if ofAttrCompressed is not specified also. }
+ ofAttrOffline = {$IFDEF LIN} 0 {$ELSE} $10000000 {$ENDIF};
+ {* Use this flag to create offline file. }
+
+{$IFDEF _D3orHigher}
+function WFileCreate(const FileName: KOLWideString; OpenFlags: DWord): THandle;
+{* }
+{$ENDIF}
+function FileCreate(const FileName: KOLString; OpenFlags: DWord): THandle;
+{* Call this function to open existing or create new file. OpenFlags
+ parameter can be a combination of up to three flags (by one from
+ each group:
+ |<table border=0>
+ |&L=<tr><td valign=top>%0</td><td valign=top>
+ |&E=</td></tr>
+ <L ofOpenRead, ofOpenWrite, ofOpenReadWrite> - 1st group. Here You decide
+ wish You open file for read, write or read-and-write operations; <E>
+ <L ofShareExclusive, ofShareDenyWrite, ofShareDenyRead, ofShareDenyNone> -2nd
+ group - sharing. Here You can mark out sharing mode, which is used to
+ open file. <E>
+ <L ofCreateNew, ofCreateAlways, ofOpenExisting, ofOpenAlways, ofTruncateExisting>
+ - 3rd group - creation disposition. Here You determine, either to create new
+ or open existing file and if to truncate existing or not.
+ |</table> }
+function FileClose(Handle: THandle): Boolean;
+{* Call it to close opened earlier file. }
+function FileExists( const FileName: KOLString ) : Boolean;
+{* Returns True, if given file exists.
+ |<br>Note (by Dod):
+ It is not documented in a help for GetFileAttributes, but it seems that
+ under NT-based Windows systems, FALSE is always returned for files
+ opened for excluseve use like pagefile.sys. }
+{$IFDEF _D3orHigher}
+function WFileExists( const FileName: KOLWideString ) : Boolean;
+{* Returns True, if given file exists.
+ |<br>Note (by Dod):
+ It is not documented in a help for GetFileAttributes, but it seems that
+ under NT-based Windows systems, FALSE is always returned for files
+ opened for excluseve use like pagefile.sys. }
+{$ENDIF}
+function FileSeek(Handle: THandle; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize;
+{* Changes current position in file. }
+function FileRead(Handle: THandle; var Buffer; Count: DWord): DWord;
+{* Reads bytes from current position in file to buffer. Returns number of
+ read bytes. }
+{$IFDEF LIN}
+function GetFileSize( Handle: THandle; HiSize: PDWORD ): DWORD;
+{$ENDIF LIN}
+function File2Str(Handle: THandle): AnsiString;
+{* Reads file from current position to the end and returns result as ansi string. }
+{$IFNDEF _D2}
+function File2WStr(Handle: THandle): KOLWideString;
+{* Reads UNICODE file from current position to the end and returns result as
+ unicode string. }
+{$ENDIF}
+function FileWrite(Handle: THandle; const Buffer; Count: DWord): DWord;
+{* Writes bytes from buffer to file from current position, extending its
+ size if needed. }
+function FileEOF( Handle: THandle ) : Boolean;
+{* Returns True, if EOF is achieved during read operations or last byte is
+ overwritten or append made to extend file during last write operation. }
+function FileFullPath( const FileName : KOLString ) : KOLString;
+{* Returns full path name for given file. Validness of source FileName path
+ is not checked at all. }
+{$IFDEF WIN} //--------------- these functions have not sense in Linux: --------
+function FileShortPath( const FileName: KOLString ): KOLString;
+{* Returns short path to the file or directory. }
+function FileIconSystemIdx( const Path: KOLString ): Integer;
+{* Returns index of the index of the system icon correspondent to the file or
+ directory in system icon image list. }
+function FileIconSysIdxOffline( const Path: KOLString ): Integer;
+{* The same as FileIconSystemIdx, but an icon is calculated for the file
+ as it were offline (it is possible to get an icon for file even if
+ it is not existing, on base of its extension only). }
+function DirIconSysIdxOffline( const Path: KOLString ): Integer;
+{* The same as FileIconSysIdxOffline, but for a folder rather then for a file. }
+{$ENDIF WIN} //-----------------------------------------------------------------
+procedure LogFileOutput( const filepath, str: KOLString );
+{* Debug function. Use it to append given string to the end of the given file. }
+
+function Str2File( Filename: PKOLChar; Str: PAnsiChar ): Boolean;
+{* Save null-terminated string to file directly. If file does not exists, it is
+ created. If it exists, it is overriden. If operation failed, FALSE is returned. }
+function WStr2File( Filename: PKOLChar; Str: PWideChar ): Boolean;
+{* Save null-terminated wide string to file directly. If file does not exists, it is
+ created. If it exists, it is overriden. If operation failed, FALSE is returned. }
+function StrSaveToFile( const Filename: KOLString; const Str: AnsiString ): Boolean;
+{* Saves a string to a file without any changes. If file does not exists, it is
+ created. If it exists, it is overriden. If operation failed, FALSE is returned. }
+function StrLoadFromFile( const Filename: KOLString ): AnsiString;
+{* Reads entire file and returns its content as a string. If operation failed,
+ an empty strinng is returned.
+ |<br>by Sergey Shishmintzev: it is possible to pass Filename = 'CON' to
+ read input from redirected console output. }
+{$IFNDEF _D2}
+function WStrSaveToFile( const Filename: KOLString; const Str: KOLWideString ): Boolean;
+{* Saves a string to a file without any changes. If file does not exists, it is
+ created. If it exists, it is overriden. If operation failed, FALSE is returned. }
+function WStrLoadFromFile( const Filename: KOLString ): KOLWideString;
+{* Reads entire file and returns its content as a string. If operation failed,
+ an empty strinng is returned.
+ |<br>by Sergey Shishmintzev: it is possible to pass Filename = 'CON' to
+ read input from redirected console output. }
+{$ENDIF}
+
+function Mem2File( Filename: PKOLChar; Mem: Pointer; Len: Integer ): Integer;
+{* Saves memory block to a file (if file exists it is overriden, created new if
+ not exists). }
+function File2Mem( Filename: PKOLChar; Mem: Pointer; MaxLen: Integer ): Integer;
+{* Loads file content to memory. }
+
+{$IFDEF WIN}
+type
+ PFindFileData = ^TFindFileData;
+ TFindFileData = packed record
+ // from TWin32FindData: -------------
+ dwFileAttributes: DWORD;
+ ftCreationTime: TFileTime;
+ ftLastAccessTime: TFileTime;
+ ftLastWriteTime: TFileTime;
+ nFileSizeHigh: DWORD;
+ nFileSizeLow: DWORD;
+ dwReserved0: DWORD;
+ dwReserved1: DWORD;
+ cFileName: Array[0..MAX_PATH - 1] of KOLChar;
+ cAlternateFileName: Array[0..13] of KOLChar;
+ //-------- + handle:
+ FindHandle: THandle;
+ end;
+{$ENDIF WIN}
+function Find_First( const FilePathName: KOLString; var F: TFindFileData ): Boolean;
+function Find_Next( var F: TFindFileData ): Boolean;
+procedure Find_Close( var F: TFindFileData );
+{$IFDEF _D2orD3}
+function FileSize( const Path: KOLString ) : Integer;
+{$ELSE}
+function FileSize( const Path: KOLString ) : Int64;
+{$ENDIF}
+{* Returns file size in bytes without opening it. If file too large
+ to represent its size as Integer, -1 is returned. }
+procedure FileTime( const Path: KOLString;
+ CreateTime, LastAccessTime, LastModifyTime: PFileTime ); stdcall;
+{* Returns file times without opening it. }
+function GetUniqueFilename( PathName: KOLString ) : KOLString;
+{* If file given by PathName exists, modifies it to create unique
+ filename in target folder and returns it. Modification is performed
+ by incrementing last number in name (if name part of file does not
+ represent a number, such number is generated and concatenated to
+ it). E.g., if file aaa.aaa is already exist, the function checks
+ names aaa1.aaa, aaa2.aaa, ..., aaa10.aaa, etc. For name abc123.ext,
+ names abc124.ext, abc125.ext, etc. will be checked. }
+function FileTimeCompare( const FT1, FT2 : TFileTime ) : Integer;
+{* Compares time of file (createing, writing, accessing. Returns
+ -1, 0, 1 if correspondantly FT1<FT2, FT1=FT2, FT1>FT2. }
+function DirectoryExists(const Name: KOLString): Boolean;
+{* Returns True if given directory (folder) exists. }
+function DiskPresent( const DrivePath: KOLString ): Boolean;
+{* Returns TRUE if the disk is present }
+{$IFDEF _D3orHigher}
+function WDirectoryExists(const Name: KOLWideString): Boolean;
+{* }
+{$ENDIF}
+function CheckDirectoryContent( const Name: KOLString; SubDirsOnly: Boolean;
+ const Mask: KOLString ): Boolean;
+{* Returns TRUE if directory does not contain files (or directories only)
+ satisfying given mask. }
+function DirectoryEmpty(const Name: KOLString): Boolean;
+{* Returns True if given directory is not exists or empty. }
+function DirectoryHasSubdirs( const Path: KOLString ): Boolean;
+{* Returns TRUE if given directory exists and has subdirectories. }
+function GetStartDir: KOLString;
+{* Returns path to directory where executable is located (regardless
+ of current directory). }
+function ExePath: KOLString;
+{* Returns the path to the exe-file (in case of dll hook, this is exe-file
+ of the process in which context dll hook function is called). }
+function ModulePath: KOLString;
+{* Returns the path to the module (exe, dll) itself. }
+
+
+
+//---------------------------------------------------------
+// Following functions/procedures are created by Edward Aretino:
+// IncludeTrailingPathDelimiter, ExcludeTrailingPathDelimiter,
+// ForceDirectories, CreateDir, ChangeFileExt
+//---------------------------------------------------------
+function ExcludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
+{* If S is finished with character C, it is excluded. }
+function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
+{* If S is not finished with character C, it is added. }
+function IncludeTrailingPathDelimiter(const S: KOLString): KOLString;
+{* by Edward Aretino. Adds '\' to the end if it is not present. }
+function ExcludeTrailingPathDelimiter(const S: KOLString): KOLString;
+{* by Edward Aretino. Removes '\' at the end if it is present. }
+
+function ExtractFileDrive( const Path: KOLString ) : KOLString;
+{* Returns only drive part from exact path to a file or a directory.
+ For network paths, returns a computer name together with a following
+ name of shared directory (like '\\compname\shared\' ). }
+function ExtractFilePath( const Path: KOLString ) : KOLString;
+{* Returns only path part from exact path to file. }
+{$IFDEF _D3orHigher}
+function WExtractFilePath( const Path: KOLWideString ) : KOLWideString;
+{* Returns only path part from exact path to file. }
+{$ENDIF}
+function IsNetworkPath( const Path: KOLString ): Boolean;
+{* Returns TRUE, if Path is starting from '\\'. }
+function ExtractFileName( const Path: KOLString ) : KOLString;
+{* Extracts file name from exact path to file. }
+function ExtractFileNameWOext( const Path: KOLString ) : KOLString;
+{* Extracts file name from path to file or from filename. }
+function ExtractFileExt( const Path: KOLString ) : KOLString;
+{* Extracts extention from file name (returns it with dot '.' first) }
+function ReplaceExt( const Path, NewExt: KOLString ): KOLString;
+{* Returns Path to a file with extension replaced to a new extension.
+ Pass a new extension started with '.', e.g. '.txt'. }
+
+function ForceDirectories(Dir: KOLString): Boolean;
+{* by Edward Aretino. Creates given directory if not present. All needed
+ subdirectories are created if necessary. }
+function CreateDir(const Dir: KOLString): Boolean;
+{* by Edward Aretino. Creates given directory. }
+function ChangeFileExt(FileName: KOLString; const Extension: KOLString): KOLString;
+{* by Edward Aretino. Changes file extention. }
+function ReplaceFileExt( const Path, NewExt: KOLString ): KOLString;
+{* Returns a path with extension replaced to a given one. }
+{$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+function ExtractShortPathName( const Path: KOLString ): KOLString;
+{* }
+{$IFDEF GDI}
+function FilePathShortened( const Path: KOLString; MaxLen: Integer ): KOLString;
+{* Returns shortened file path to fit MaxLen characters. }
+function FilePathShortenPixels( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
+{* Returns shortened file path to fit MaxPixels for a given DC. If you pass
+ Canvas.Handle of any control or bitmap object, ensure that font is valid
+ for it (or call TCanvas.RequiredState( FontValid ) method before. If DC passed
+ = 0, call is equivalent to call FilePathShortened, and MaxPixels means in such
+ case maximum number of characters. }
+function MinimizeName( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
+{* Exactly the same as MinimizeName in FileCtrl.pas (VCL). }
+{$ENDIF GDI}
+
+function GetSystemDir: KOLString;
+{* Returns path to windows system directory. }
+function GetWindowsDir : KOLString;
+{* Returns path to Windows directory. }
+{$ENDIF WIN} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+function GetWorkDir : KOLString;
+{* Returns path to application's working directory. }
+function GetTempDir : KOLString;
+{* Returns path to default temp folder (directory to place temporary files). }
+function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString;
+{* Returns path to just created temporary file. }
+function GetFileListStr(FPath{e.g.'c:\tmp\'}, FMask{e.g.'*.*'}: KOLString): KOLString;
+{* List of files in string, separating each path from others with a character stored
+ in FileOpSeparator variables (#13 by default).
+ E.g.: 'c:\tmp\unit1.dcu'#13'c:\tmp\unit1.~pa' (for use with DeleteFile2Recycle())}
+function DeleteFiles( const DirPath: KOLString ): Boolean;
+{* Deletes files by file mask (given with wildcards '*' and '?'). }
+{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+var FileOpSeparator: KOLChar = {$IFDEF OLD_COMPAT}';'{$ELSE}#13{$ENDIF};
+function DoFileOp( const FromList, ToList: KOLString; FileOp: UINT; Flags: Word;
+ Title: PKOLChar): Boolean;
+{* By Unknown Mystic. FileOp can be: FO_MOVE, FO_COPY, FO_DELETE, FO_RENAME.
+ Flags can be a combination of values: FOF_MULTIDESTFILES, FOF_CONFIRMMOUSE,
+ FOF_SILENT, FOF_RENAMEONCOLLISION, FOF_NOCONFIRMATION, FOF_WANTMAPPINGHANDLE,
+ FOF_ALLOWUNDO, FOF_FILESONLY, FOF_SIMPLEPROGRESS, FOF_NOCONFIRMMKDIR,
+ FOF_NOERRORUI. Title used only with FOF_SIMPLEPROGRESS. }
+function DeleteFile2Recycle( const Filename : KOLString ) : Boolean;
+{* Deletes file to recycle bin. This operation can be very slow, when
+ called for a single file. To delete group of files at once (fast),
+ pass a list of paths to files to be deleted, separating each path
+ from others with a character stored in FileOpSeparator variable (by default #13,
+ but in case when OLD_COMPAT symbol added - ';'). E.g.: 'unit1.dcu'#13'unit1.~pa'
+ |<br>
+ FALSE is returned only in case when at least one file was not deleted
+ successfully.
+ |<br>
+ Note, that files are deleted not to recycle bin, if wildcards are
+ used or not fully qualified paths to files. }
+function CopyMoveFiles( const FromList, ToList: KOLString; Move: Boolean ): Boolean;
+{* }
+{$IFNDEF PAS_ONLY}
+function DiskFreeSpace( const Path: KOLString ): I64;
+{$ENDIF}
+{* Returns disk free space in bytes. Pass a path to root directory,
+ e.g. 'C:\'.
+ |<hr>
+
+ <R Wrappers to registry API functions>
+
+ These functions can be used independently to simplify access to Windows
+ registry. }
+{$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+function RegKeyOpenRead( Key: HKey; const SubKey: KOLString ): HKey;
+{* Opens registry key for read operations (including enumerating of subkeys).
+ Pass either handle of opened earlier key or one of constans
+ HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS
+ as a first parameter. If not successful, 0 is returned. }
+function RegKeyOpenWrite( Key: HKey; const SubKey: KOLString ): HKey;
+{* Opens registry key for write operations (including adding new values or
+ subkeys), as well as for read operations too. See also RegKeyOpenRead. }
+function RegKeyOpenCreate( Key: HKey; const SubKey: KOLString ): HKey;
+{* Creates and opens key. }
+function RegKeyGetStr( Key: HKey; const ValueName: KOLString ): KOLString;
+{* Reads key, which must have type REG_SZ (null-terminated string). If
+ not successful, empty string is returned. This function as well as all
+ other registry manipulation functions, does nothing, if Key passed is 0
+ (without producing any error). }
+function RegKeyGetStrEx( Key: HKey; const ValueName: KOLString
+ {$IFDEF OPTIONAL_REG_EXPAND_SZ} ; ExpandEnvVars: Boolean {$ENDIF} ): KOLString;
+{* Like RegKeyGetStr, but accepts REG_EXPAND_SZ type, expanding all
+ environment variables in resulting string.
+ |<br>
+ Code provided by neuron, e-mailto:neuron@hollowtube.mine.nu }
+function RegKeyGetDw( Key: HKey; const ValueName: KOLString ): DWORD;
+{* Reads key value, which must have type REG_DWORD. If ValueName passed
+ is '' (empty string), unnamed (default) value is reading. If not
+ successful, 0 is returned. }
+function RegKeySetStr(Key: HKey; const ValueName: KOLString; const Value: KOLString ): Boolean;
+{* Writes new key value as null-terminated string (type REG_SZ). If not
+ successful, returns False. }
+function RegKeySetStrEx( Key: HKey; const ValueName: KOLString; const Value: KOLString;
+ expand: Boolean): Boolean;
+{* Writes new key value as REG_SZ or REG_EXPAND_SZ. - by neuron, e-mailto:neuron@hollowtube.mine.nu }
+function RegKeySetDw( Key: HKey; const ValueName: KOLString; Value: DWORD ): Boolean;
+{* Writes new key value as dword (with type REG_DWORD). Returns False,
+ if not successful. }
+procedure RegKeyClose( Key: HKey );
+{* Closes key, opened using RegKeyOpenRead or RegKeyOpenWrite. (But does
+ nothing, if Key passed is 0). }
+function RegKeyDelete( Key: HKey; const SubKey: KOLString ): Boolean;
+{* Deletes key. Does nothing if key passed is 0 (returns FALSE). }
+function RegKeyDeleteValue( Key: HKey; const SubKey: KOLString ): Boolean;
+{* Deletes value. - by neuron, e-mailto:neuron@hollowtube.mine.nu }
+function RegKeyExists( Key: HKey; const SubKey: KOLString ): Boolean;
+{* Returns TRUE, if given subkey exists under given Key. }
+function RegKeyValExists( Key: HKey; const ValueName: KOLString ): Boolean;
+{* Returns TRUE, if given value exists under the Key.
+}
+function RegKeyValueSize( Key: HKey; const ValueName: KOLString ): Integer;
+{* Returns a size of value. This is a size of buffer needed to store
+ registry key value. For string value, size returned is equal to a
+ length of string plus 1 for terminated null character. }
+function RegKeyGetBinary( Key: HKey; const ValueName: KOLString; var Buffer; Count: Integer ): Integer;
+{* Reads binary data from a registry, writing it to the Buffer.
+ It is supposed that size of Buffer provided is at least Count bytes.
+ Returned value is actul count of bytes read from the registry and written
+ to the Buffer.
+ |<br>
+ This function can be used to get data of any type from the registry, not
+ only REG_BINARY. }
+function RegKeySetBinary( Key: HKey; const ValueName: KOLString; const Buffer; Count: Integer ): Boolean;
+{* Stores binary data in the registry. }
+function RegKeyGetDateTime(Key: HKey; const ValueName: KOLString): TDateTime;
+{* Returns datetime variable stored in registry in binary format. }
+function RegKeySetDateTime(Key: HKey; const ValueName: KOLString; DateTime: TDateTime): Boolean;
+{* Stores DateTime variable in the registry. }
+
+//-------------------------------------------------------
+// registry functions by Valerian Luft <luft@valerian.de>
+//-------------------------------------------------------
+function RegKeyGetSubKeys( const Key: HKEY; List: PKOLStrList): Boolean;
+{* The function enumerates subkeys of the specified open registry key.
+ True is returned, if successful.
+}
+function RegKeyGetValueNames(const Key: HKEY; List: PKOLStrList): Boolean;
+{* The function enumerates value names of the specified open registry key.
+ True is returned, if successful.
+}
+function RegKeyGetValueTyp (const Key:HKEY; const ValueName: KOLString) : DWORD;
+{* The function receives the type of data stored in the specified value.
+ |<br>
+ If the function fails, the return value is the Key value.
+ |<br>
+ If the function succeeds, the return value return will be one of the following:
+ |<br>
+ REG_BINARY , REG_DWORD, REG_DWORD_LITTLE_ENDIAN,
+ REG_DWORD_BIG_ENDIAN, REG_EXPAND_SZ, REG_LINK , REG_MULTI_SZ,
+ REG_NONE, REG_RESOURCE_LIST, REG_SZ
+
+|<hr>
+
+ <R Data sorting (quicksort implementation)>
+ This part contains implementation of 'quick sort' algorithm,
+ based on following code:
+
+|<pre>
+| TQSort by Mike Junkin 10/19/95.
+| DoQSort routine adapted from Peter Szymiczek's QSort procedure which
+| was presented in issue#8 of The Unofficial Delphi Newsletter.
+
+| TQSort changed by Vladimir Kladov (Mr.Bonanzas) to allow 32-bit
+| sorting (of big arrays with more than 64K elements).
+|</pre>
+
+ Finally, this sort procedure is adapted to XCL (and then to KOL)
+ requirements (no references to SysUtils, Classes etc. TQSort object
+ is transferred to a single procedure call and DoQSort method is
+ renamed to SortData - which is a regular procedure now). }
+
+{$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+procedure SortData( const Data: Pointer; const uNElem: Dword;
+ const CompareFun: TCompareEvent;
+ const SwapProc: TSwapEvent );
+{* Call it to sort any array of data of any kind, passing total
+ number of items in an array and two defined (regular) function
+ and procedure to perform custom compare and swap operations.
+ First procedure parameter is to pass it to callback function
+ CompareFun and procedure SwapProc. Items are enumerated from
+ 0 to uNElem-1. }
+
+{$IFDEF _D3orHigher}
+procedure SortArray( const Data: Pointer; const uNElem: Dword;
+ const CompareFun: TCompareArrayEvent );
+{* Like SortData, but faster and allows to sort only contigous arrays of
+ dwords (or integers or pointers occupying for 4 bytes for each item. }
+{$ENDIF}
+
+procedure SwapListItems( const L: Pointer; const e1, e2: DWORD );
+{* Use this function as the last parameter for SortData call when a PList
+ object is sorting. SwapListItems just exchanges two items of the list. }
+
+procedure SortIntegerArray( var A : array of Integer );
+{* procedure to sort array of integers. }
+
+procedure SortDwordArray( var A : array of DWORD );
+{* Procedure to sort array of unsigned 32-bit integers.
+|<hr>
+}
+{ ------------------- directory list object ---------------------------------- }
+
+type
+ TDirItemAction = ( diSkip, diAccept, diCancel );
+ TOnDirItem = procedure( Sender: PObj; var DirItem: TFindFileData; var Accept: TDirItemAction )
+ of object;
+ TSortDirRules = ( sdrNone, sdrFoldersFirst, sdrCaseSensitive, sdrByName, sdrByExt,
+ sdrBySize, sdrBySizeDescending, sdrByDateCreate, sdrByDateChanged,
+ sdrByDateAccessed, sdrInvertOrder );
+ {* List of rules (options) to sort directories. Rules are passed to Sort
+ method in an array, and first placed rules are applied first. }
+
+ PDirList = ^TDirList;
+{ ----------------------------------------------------------------------
+ TDirList - Directory scanning
+----------------------------------------------------------------------- }
+ TDirList = object( TObj )
+ {* Allows easy directory scanning. This is not visual object, but
+ storage to simplify working with directory content. }
+ protected
+ FListPositions : PList; //^^^^^^^^^^ Attention: order of FListPositions &
+ fStoreFiles: PStream; //__________ fStoreFiles is IMPORTANT!
+ FPath: KOLString;
+ fFilters: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF};
+ fOnItem: TOnDirItem;
+ function Get(Idx: Integer): PFindFileData;
+ function GetCount: Integer;
+ function GetNames(Idx: Integer): KOLString;
+ function GetIsDirectory(Idx: Integer): Boolean;
+ protected
+ function SatisfyFilter( FileName : PKOLChar; FileAttr, FindAttr : DWord ) : Boolean;
+ destructor Destroy; virtual;
+ {* Destructor. As usual, call Free method to destroy an object. }
+ public
+ property Items[ Idx : Integer ] : PFindfileData read Get; default;
+ {* Full access to scanned items (files and subdirectories). }
+ property IsDirectory[ Idx: Integer ]: Boolean read GetIsDirectory;
+ {* Returns TRUE, if specified item represents a directory, not a file. }
+ property Count : Integer read GetCount;
+ {* Number of items. }
+ property Names[ Idx : Integer ] : KOLString read GetNames;
+ {* Full long names of directory items. }
+ property Path : KOLString read FPath;
+ {* Path of scanned directory. }
+ procedure Clear;
+ {* Call it to clear list of files. }
+ procedure ScanDirectory( const DirPath, Filter : KOLString; Attr : DWord );
+ {* Call it to rescan directory or to scan another directory content
+ (method Clear is called first). Pass path to directory, file filter
+ and attributes to scan directory immediately.
+ |<br>
+ Note: Pass FILE_ATTRIBUTE_... constants or-combination as Attr
+ parameter. If 0 passed, both files and directories are listed. }
+ procedure ScanDirectoryEx( const DirPath, Filters : KOLString; Attr : DWord );
+ {* Call it to rescan directory or to scan another directory content
+ (method Clear is called first). Pass path to directory, file filter
+ and attributes to scan directory immediately.
+ |<br>
+ Note: Pass FILE_ATTRIBUTE_... constants or-combination as Attr
+ parameter. }
+ procedure Sort( Rules : array of TSortDirRules );
+ {* Sorts directory entries. If empty rules array passed, default rules
+ array DefSortDirRules is used. }
+ function FileList( const Separator {e.g.: ';', or #13}: KOLString;
+ Dirs, FullPaths: Boolean ): KOLString;
+ {* Returns a string containing all names separated with Separator.
+ If Dirs=FALSE, only files are returned. }
+ property OnItem: TOnDirItem read fOnItem write fOnItem;
+ {* This event is called on reading each item while scanning directory.
+ To use it, first create PDirList object with empty path to scan, then
+ assign OnItem event and call ScanDirectory with correct path. }
+ procedure DeleteItem( Idx: Integer );
+ {* Allows to delete an item from the directory list (not from the disk!) }
+ procedure AddItem( FindData: PFindFileData );
+ {* Allows to add arbitrary item to the list. }
+ procedure InsertItem( idx: Integer; FindData: PFindFileData );
+ {* Allows to add arbitrary item to the list. }
+ end;
+
+function NewDirList( const DirPath, Filter: KOLString; Attr: DWORD ): PDirList;
+{* Creates directory list object using easy one-string filter. If Attr = FILE_ATTRIBUTE_NORMAL,
+ only files are scanned without directories. If Attr = 0, both files and
+ directories are listed. }
+function NewDirListEx( const DirPath, Filters: KOLString; Attr: DWORD ): PDirList;
+{* Creates directory list object using several filters, separated by ';'.
+ Filters starting from '^' consider to be anti-filters, i.e. files,
+ satisfying to those masks, are skept during scanning. }
+const DefSortDirRules : array[ 0..3 ] of TSortDirRules = ( sdrFoldersFirst,
+ sdrByName, sdrBySize, sdrByDateCreate );
+{* Default rules to sort directory entries. }
+{$IFNDEF PAS_ONLY}
+function DirectorySize( const Path: KOLString ): I64;
+{* Returns directory size in bytes as large 64 bit integer. }
+{$ENDIF}
+
+{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+type
+ TOpenSaveOption = ( OSCreatePrompt,
+ OSExtensionDiffent,
+ OSFileMustExist,
+ OSHideReadonly,
+ OSNoChangedir,
+ OSNoReferenceLinks,
+ OSAllowMultiSelect,
+ OSNoNetworkButton,
+ OSNoReadonlyReturn,
+ OSOverwritePrompt,
+ OSPathMustExist,
+ OSReadonly,
+ OSNoValidate
+ //{$IFDEF OpenSaveDialog_Extended}
+ ,
+ OSTemplate,
+ OSHook
+ //{$ENDIF}
+ );
+ TOpenSaveOptions = set of TOpenSaveOption;
+ {* Options available for TOpenSaveDialog. }
+
+ POpenSaveDialog = ^TOpenSaveDialog;
+{ ----------------------------------------------------------------------
+ TOpenSaveDialog
+----------------------------------------------------------------------- }
+ TOpenSaveDialog = object( TObj )
+ {* Object to show standard Open/Save dialog. Initially provided
+ for XCL by Carlo Kok. }
+ protected
+ FFilter : KOLString;
+ fFilterIndex : Integer;
+ fOpenDialog : Boolean;
+ FInitialDir : KOLString;
+ FDefExtension : KOLString;
+ FFilename : KOLString;
+ FTitle : KOLString;
+ FOptions : TOpenSaveOptions;
+ fWnd: THandle;
+ fOpenReadOnly: Boolean;
+ public
+ TemplateName: KOLString; // do not forget to add OpenSaveDialog_Extended
+ HookProc: Pointer; // to project options conditionals!
+ NoPlaceBar: Boolean; // TRUE, if place bar is disabled in the new style
+ // dialogs (if the symbol OpenSaveDialog_Extended is
+ // not added in project options, place bar is always
+ // enabled in Windows 2000 and higher).
+ destructor Destroy; virtual;
+ {* destructor }
+ Function Execute : Boolean;
+ {* Call it after creating to perform selecting of file by user. }
+ property Filename : KOLString read FFilename write FFileName;
+ {*
+ Filename is separated by #13 when multiselect is true and the first
+ file, is the path of the files selected.
+ |<pre>
+ | C:\Projects
+ | Test1.Dpr
+ | Test2.Dpr
+ |</pre>
+ If only one file is selected, it is provided as (e.g.)
+ C:\Projects\Test1.dpr
+ |<br> For case when OSAllowMultiselect option used, after each
+ call initial value for a Filename containing several files prevents
+ system from opening the dialog. To fix this, assign another initial
+ value to Filename property in your code, when you use multiselect.
+ }
+ property InitialDir : KOLString read FInitialDir write FInitialDir;
+ {* Initial directory path. If not set, current directory (usually
+ directory when program is started) is used. }
+ property Filter : KOLString read FFilter write FFilter;
+ {* A list of pairs of filter names and filter masks, separated with '|'.
+ If a mask contains more than one mask, it should be separated with ';'.
+ E.g.:
+ ! 'All files|*.*|Text files|*.txt;*.1st;*.diz' }
+ property FilterIndex : Integer read FFilterIndex write FFilterIndex;
+ {* Index of default filter mask (0 by default, which means "first"). }
+ property OpenDialog : Boolean read FOpenDialog write FOpenDialog;
+ {* True, if "Open" dialog. False, if "Save" dialog. True is default. }
+ property Title : KOLString read Ftitle write Ftitle;
+ {* Title for dialog. }
+ property Options : TOpenSaveOptions read FOptions write FOptions;
+ {* Options. }
+ property DefExtension : KOLString read FDefExtension write FDefExtension;
+ {* Default extention. Set it to desired extension without leading period,
+ e.g. 'txt', but not '.txt'. }
+ property WndOwner: THandle read fWnd write fWnd;
+ {* Owner window handle. If not assigned, Applet.Handle is used (whenever
+ possible). Assign it, if your application has stay-on-top forms, and
+ a separate Applet object is used. }
+ property OpenReadOnly: Boolean read fOpenReadOnly;
+ {* TRUE after Execute, if Read Only check box was checked by the user.
+ Options are not affected anyway. }
+ end;
+
+const DefOpenSaveDlgOptions: TOpenSaveOptions = [ OSHideReadonly,
+ OSOverwritePrompt, OSFileMustExist, OSPathMustExist ];
+
+function NewOpenSaveDialog( const Title, StrtDir: KOLString;
+ Options: TOpenSaveOptions ): POpenSaveDialog;
+{* Creates object, which can be used (several times) to open file(s)
+ selecting dialog. }
+
+type
+ POpenDirDialog = ^TOpenDirDialog;
+
+ TOpenDirOption = ( odBrowseForComputer, odBrowseForPrinter, odDontGoBelowDomain,
+ odOnlyFileSystemAncestors, odOnlySystemDirs, odStatusText,
+ odBrowseIncludeFiles, odEditBox, odNewDialogStyle );
+ {* Flags available for TOpenDirDialog object. }
+ // odfStatusText - do not support status callback
+ TOpenDirOptions = set of TOpenDirOption;
+ {* Set of all flags used to control ZOpenDirDialog class. }
+
+ TOnODSelChange = procedure( Sender: POpenDirDialog; NewSelDir: PKOL_Char;
+ var EnableOK: Integer; var StatusText: KOL_String )
+ of object;
+ {* Event type to be called when user select another directory in OpenDirDialog.
+ Set EnableOK to -1 to disable OK button, or to +1 to enable it.
+ It is also possible to set new StatusText string. }
+
+{ ----------------------------------------------------------------------
+ TOpenDirDialog
+----------------------------------------------------------------------- }
+ TOpenDirDialog = object( TObj )
+ {* Dialog for open directories, uses SHBrowseForFolder. }
+ protected
+ FTitle: KOLString;
+ FOptions: TOpenDirOptions;
+ FCallBack: Pointer;
+ FCenterProc: procedure( Wnd: HWnd );
+ FBuf : array[ 0..MAX_PATH ] of KOLChar;
+ FInitialPath: KOLString;
+ FCenterOnScreen: Boolean;
+ FDoSelChanged: procedure( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ); stdcall;
+ FOnSelChanged: TOnODSelChange;
+ FStatusText: KOLString;
+ FWnd, FDialogWnd: HWnd;
+ function GetPath: KOLString;
+ procedure SetInitialPath(const Value: KOLString);
+ procedure SetCenterOnScreen(const Value: Boolean);
+ procedure SetOnSelChanged(const Value: TOnODSelChange);
+ function GetInitialPath: KOLString;
+ public
+ destructor Destroy; virtual;
+ {* destructor }
+ function Execute : Boolean;
+ {* Call it to select directory by user. Returns True, if operation was
+ not cancelled by user. }
+ property Title : KOLString read FTitle write FTitle;
+ {* Title for a dialog. }
+ property Options : TOpenDirOptions read FOptions write FOptions;
+ {* Option flags. }
+ property Path : KOLString read GetPath;
+ {* Resulting (selected by user) path. }
+ property InitialPath: KOLString read GetInitialPath write SetInitialPath;
+ {* Set this property to a path of directory to be selected initially
+ in a dialog. }
+ property CenterOnScreen: Boolean read FCenterOnScreen write SetCenterOnScreen;
+ {* Set it to True to center dialog on screen. }
+ property OnSelChanged: TOnODSelChange read FOnSelChanged write SetOnSelChanged;
+ {* This event is called every time, when user selects another directory.
+ It is possible to enable/disable OK button in dialog and/or change
+ dialog status text in responce to event. }
+ property WndOwner: HWnd read FWnd write FWnd;
+ {* Owner window. If you want to provide your dialog visible over stay-on-top
+ form, fire it as a child of the form, assigning the handle of form window
+ to this property first. }
+ property DialogWnd: HWnd read FDialogWnd;
+ {* Handle to the open directory dialog itself, become available on the
+ first call of callback procedure (i.e. on the first call to OnSelChanged).
+ }
+ end;
+
+function NewOpenDirDialog( const Title: KOLString; Options: TOpenDirOptions ):
+ POpenDirDialog;
+{* Creates object, which can be used (several times) to open directory
+ selecting dialog (using SHBrowseForFolder API call). }
+
+type
+ TColorCustomOption = ( ccoFullOpen, ccoShortOpen, ccoPreventFullOpen );
+
+{$IFDEF KOL_MCK}
+type TKOLOpenDirDialog = POpenDirDialog;
+{$ENDIF}
+
+ PColorDialog = ^TColorDialog;
+{ ----------------------------------------------------------------------
+ TColorDialog
+----------------------------------------------------------------------- }
+ TColorDialog = object( TObj )
+ {* Color choosing dialog. }
+ protected
+ public
+ OwnerWindow: HWnd;
+ {* Owner window (can be 0). }
+ CustomColors: array[ 1..16 ] of TColor;
+ {* Array of stored custom colors. }
+ ColorCustomOption: TColorCustomOption;
+ {* Options (how to open a dialog). }
+ Color: TColor;
+ {* Returned color (if the result of Execute is True). }
+ function Execute: Boolean;
+ {* Call this method to open a dialog and wait its result. }
+ end;
+
+function NewColorDialog( FullOpen: TColorCustomOption ): PColorDialog;
+{* Creates color choosing dialog object. }
+{$ENDIF WIN_GDI}
+{$IFDEF WIN_GDI}
+type
+ TIniFileMode = ( ifmRead, ifmWrite );
+ {* ifmRead is default mode (means "read" data from ini-file.
+ Set mode to ifmWrite to write data to ini-file, correspondent to
+ TIniFile. }
+
+ PIniFile = ^TIniFile;
+
+{ ----------------------------------------------------------------------
+ TIniFile - store/load data to ini-files
+----------------------------------------------------------------------- }
+ TIniFile = object( TObj )
+ {* Ini file incapsulation. The main feature is what the same block of
+ read-write operations could be defined (difference must be only in
+ Mode value).
+ |*Ini file sample.
+ This sample shows how the same Pascal operators can be used both
+ for read and write for the same variables, when working with TIniFile:
+ ! procedure ReadWriteIni( Write: Boolean );
+ ! var Ini: PIniFile;
+ ! begin
+ ! Ini := OpenIniFile( 'MyIniFile.ini' );
+ ! Ini.Section := 'Main';
+ ! if Write then // if Write, the same operators will save
+ ! Ini.Mode := ifmWrite; // data rather then load.
+ ! MyForm.Left := Ini.ValueInteger( 'Left', MyForm.Left );
+ ! MyForm.Top := Ini.ValueInteger( 'Top', MyForm.Top );
+ ! Ini.Free;
+ ! end;
+ !
+ |* }
+ protected
+ fMode: TIniFileMode;
+ fFileName: KOLString;
+ fSection: KOLString;
+ protected
+ public
+ destructor Destroy; virtual;
+ {* destructor }
+ property Mode: TIniFileMode read fMode write fMode;
+ {* ifmWrite, if write data to ini-file rather than read it. }
+ property FileName: KOLString read fFileName;
+ {* Ini file name. }
+ property Section: KOLString read fSection write fSection;
+ {* Current ini section. }
+ function ValueInteger( const Key: KOLString; Value: Integer ): Integer;
+ {* Reads or writes integer data value. }
+ function ValueString( const Key: KOLString; const Value: KOLString ): KOLString;
+ {* Reads or writes string data value. }
+ function ValueDouble( const Key: KOLString; const Value: Double ): Double;
+ {* Reads or writes Double data value. }
+ function ValueBoolean( const Key: KOLString; Value: Boolean ): Boolean;
+ {* Reads or writes Boolean data value. }
+ function ValueData( const Key: KOLString; Value: Pointer; Count: Integer ): Boolean;
+ {* Reads or writes data from/to buffer. Returns True, if success. }
+ procedure ClearAll;
+ {* Clears all sections of ini-file. }
+ procedure ClearSection;
+ {* Clears current Section of ini-file. }
+ procedure ClearKey( const Key: KOLString );
+ {* Clears given key in current section. }
+
+ /////////////// + by Vyacheslav A. Gavrik:
+ procedure GetSectionNames(Names:PKOLStrList);
+ {* Retrieves section names, storing it in string list passed as a parameter.
+ String list does not cleared before processing. Section names are added
+ to the end of the string list. }
+ procedure SectionData(Names:PKOLStrList);
+ {* Read/write current section content to/from string list. (Depending on
+ current Mode value). }
+ ///////////////
+
+ end;
+
+function OpenIniFile( const FileName: KOLString ): PIniFile;
+{* Opens ini file, creating TIniFile object instance to work with it. }
+{$ENDIF WIN_GDI}
+
+type
+ TMenuitemInfo = packed record
+ cbSize: UINT;
+ fMask: UINT;
+ fType: UINT; { used if MIIM_TYPE}
+ fState: UINT; { used if MIIM_STATE}
+ wID: UINT; { used if MIIM_ID}
+ hSubMenu: HMENU; { used if MIIM_SUBMENU}
+ hbmpChecked: HBITMAP; { used if MIIM_CHECKMARKS}
+ hbmpUnchecked: HBITMAP; { used if MIIM_CHECKMARKS}
+ dwItemData: DWORD; { used if MIIM_DATA}
+ dwTypeData: PKOLChar; { used if MIIM_TYPE}
+ cch: UINT; { used if MIIM_TYPE}
+ hbmpItem: HBITMAP; { used if MIIM_BITMAP - not exists under Windows95 }
+ end;
+
+const
+ TPM_HORPOSANIMATION = $0400;
+ TPM_HORNEGANIMATION = $0800;
+ TPM_VERPOSANIMATION = $1000;
+ TPM_VERNEGANIMATION = $2000;
+ TPM_NOANIMATION = $4000;
+
+type
+ PMenu = ^TMenu;
+
+ TOnMenuItem = procedure( Sender : PMenu; Item : Integer ) of object;
+ {* Event type to define OnMenuItem event. }
+
+ TMenuAccelerator = packed Record
+ {* Menu accelerator record. Use MakeAccelerator function to combine desired
+ attributes into a record, describing the accelerator. }
+ fVirt: Byte; // or-combination of FSHIFT, FCONTROL, FALT, FVIRTKEY, FNOINVERT
+ Key: Word; // character or virtual key code (FVIRTKEY flag is present above)
+ NotUsed: Byte; // not used
+ end;
+
+ // by Sergey Shisminzev:
+ TMenuOption = (moDefault, moDisabled, moChecked,
+ moCheckMark, moRadioMark, moSeparator, moBitmap, moSubMenu,
+ moBreak, moBarBreak);
+ {* Options to add menu items dynamically. }
+ TMenuOptions = set of TMenuOption;
+ {* Set of options for menu item to use it in TMenu.AddItem method. }
+
+ TMenuBreak = ( mbrNone, mbrBreak, mbrBarBreak );
+ {* Possible menu item break types. }
+
+{ ----------------------------------------------------------------------
+ TMenu - main, popup menu and menu item
+----------------------------------------------------------------------- }
+ TMenu = object( TObj )
+ protected
+ {$IFDEF GDI}
+ function GetItemHelpContext(Idx: Integer): Integer;
+ procedure SetItemHelpContext(Idx: Integer; const Value: Integer);
+ {* Dynamic menu incapsulation object. Can play role of form main menu or popup
+ menu, depending on kind of parent window (form or control) and order of
+ creation (created first (for a form) become main menu). Does not allow
+ merging menus, but items can be hidden. Additionally checkmark bitmaps,
+ shortcut key accelerators and other features are available. }
+ protected
+ FHandle: HMenu;
+ FId: Integer;
+ FControl: PControl;
+ {$ENDIF GDI}
+ fNextMenu : PMenu;
+ {$IFDEF GDI}
+ FMenuBreak: TMenuBreak;
+ FOnMenuItem : TOnMenuItem;
+ FOnRadioOff : TOnMenuItem;
+ fOnPopup: TOnEvent;
+ fByAccel: Boolean;
+ FIsCheckItem: Boolean;
+ FIsSeparator: Boolean;
+ FVisible: Boolean;
+ FOwnerDraw: Boolean;
+ FClearBitmaps: Boolean;
+ FNotPopup: Boolean;
+ f_DummyFiller: Byte;
+ FPopupFlags: DWORD;
+ FSavedState: DWORD;
+ FData: Pointer;
+ {$ENDIF GDI}
+ FParentMenu: PMenu;
+ FMenuItems: PList;
+ FRadioGroup: Integer;
+ FCaption: KOLString;
+ {$IFDEF _X_}
+ {$IFDEF GTK}
+ fChecked: Boolean;
+ fMnemonics: AnsiString;
+ fGtkMenuItem: PGtkWidget;
+ fGtkMenuShell: PGtkWidget;
+ fGtkMenuBar: PGtkWidget;
+ {$ENDIF GTK}
+ {$ENDIF _X_}
+ {$IFDEF GDI}
+ FBitmap: HBitmap;
+ FBmpChecked: HBitmap;
+ FBmpItem: HBitmap;
+ ClearBitmapsProc: procedure( Sender: PMenu );
+ FAccelerator: TMenuAccelerator;
+ FHelpContext: Integer;
+ FOnMeasureItem: TOnMeasureItem;
+ FOnDrawItem: TOnDrawItem;
+ {$IFDEF USE_MENU_CURCTL}
+ fCurCtl: PControl;
+ {$ENDIF USE_MENU_CURCTL}
+ function GetItems( Id: HMenu ): PMenu;
+ function GetCount: Integer;
+ function GetTopParent: PMenu;
+ function GetState( const Index: Integer ): Boolean;
+ procedure SetState( const Index: Integer; Value: Boolean );
+ procedure SetMenuVisible( Value: Boolean );
+ procedure SetData( Value: Pointer );
+ procedure SetMenuItemCaption( const Value: KOLString );
+ function FillMenuItems(AHandle: HMenu; StartIdx: Integer;
+ const Template: array of PKOLChar): Integer;
+ procedure SetMenuBreak( Value: TMenuBreak );
+ function GetControl: PControl;
+ function GetInfo( var MII: TMenuItemInfo ): Boolean;
+ function SetInfo( var MII: TMenuItemInfo ): Boolean;
+ function SetTypeInfo( var MII: TMenuItemInfo ): Boolean;
+ procedure SetBitmap( Value: HBitmap );
+ procedure SetBmpChecked( Value: HBitmap );
+ procedure SetBmpItem( Value: HBitmap );
+ procedure ClearBitmaps;
+ procedure SetAccelerator( const Value: TMenuAccelerator );
+ {$IFDEF GDI}
+ procedure SetHelpContext( Value: Integer );
+ {$ENDIF GDI}
+ procedure SetSubmenu( Value: HMenu );
+ procedure SetOnMeasureItem( const Value: TOnMeasureItem );
+ procedure SetOnDrawItem( const Value: TOnDrawItem );
+ procedure SetOwnerDraw( Value: Boolean );
+ protected
+ function GetItemChecked( Item : Integer ) : Boolean;
+ procedure SetItemChecked( Item : Integer; Value : Boolean );
+ function GetItemBitmap(Idx: Integer): HBitmap;
+ procedure SetItemBitmap(Idx: Integer; const Value: HBitmap);
+ function GetItemText(Idx: Integer): KOLString;
+ procedure SetItemText(Idx: Integer; const Value: KOLString);
+ function GetItemEnabled(Idx: Integer): Boolean;
+ procedure SetItemEnabled(Idx: Integer; const Value: Boolean);
+ function GetItemVisible(Idx: Integer): Boolean;
+ procedure SetItemVisible(Idx: Integer; const Value: Boolean);
+ function GetItemAccelerator(Idx: Integer): TMenuAccelerator;
+ procedure SetItemAccelerator(Idx: Integer; const Value: TMenuAccelerator);
+ function GetItemSubMenu( Idx: Integer ): HMenu;
+ {$ENDIF GDI}
+ public
+ destructor Destroy; virtual;
+ {* To release menu dynamically, call Free method instead. All (popup)
+ menus created after this (for the same control) are destroyed in
+ that case too.
+ |<br>
+ It is not necessary to release menu object manually: all menus,
+ created with given form (or control), are automatically released,
+ when owner form (or control) is destroyed.
+ }
+ {$IFDEF GDI}
+ property Handle : HMenu read FHandle;
+ {* Handle of Windows menu object. }
+ property MenuId: Integer read FId;
+ {* Id of the menu item object. If menu item has subitems, it has
+ also submenu Handle. Top parent menu object itself has no Id.
+ Id-s areassigned automatically starting from 4096. Do not
+ (re)create menu items instantly, because such values are not
+ reused, and maximum possible Id value must not exceed 65535. }
+ property Parent: PMenu read FParentMenu;
+ {* Parent menu item (or parent menu). }
+ property TopParent: PMenu read GetTopParent;
+ {* Top parent menu, owning all nested subitems. }
+ property Owner: PControl read GetControl;
+ {* Parent control or form. }
+ property Caption: KOLString read FCaption write SetMenuItemCaption;
+ {* Menu item caption text (including '&' indicating mnemonic characters,
+ and keyboard accelerator representation string, usually following
+ tabulation character). }
+ property Items[ Id: HMenu ]: PMenu read GetItems;
+ {* Returns menu item object by its index or by menu id. Since menu id
+ values are starting from 4096, values from 0 to 4095 are interpreted
+ as absolute index of menu item. Be careful accessing menu items or
+ submenus by index, if you dynamically insert or delete items or
+ submenus. In this version, separators are enumerating too, like
+ all other items. Use index -1 to access object itself. The first
+ item of a menu (or the first subitem of submenu item) has index 0.
+ Children are enumerating before all siblings. The maximum available
+ index is (Count - 1), when accessing menu items by index. }
+ property Count: Integer read GetCount;
+ {* Count of items together with all its nested subitems. }
+ function IndexOf( Item: PMenu ): Integer;
+ {* Returns index of an item. This index can be used to access
+ menu item. Value -2 is returned, if the Item is not a child for menu
+ or menu item, and has no parents, which are children for it, etc.
+ Menu object itself always has index -1. }
+ property OnMenuItem : TOnMenuItem read FOnMenuItem write FOnMenuItem;
+ {* Is called when menu item is clicked. Absolute index of menu item
+ clicked is passed as the second parameter. TopParent always is
+ passed as a Sender parameter. }
+ property ByAccel: Boolean read fByAccel;
+ {* True, when OnMenuItem is called not by mouse, but by accelerator key.
+ Check this flag for entire menu (TopParent), not for item itself.
+ (Note, that Sender in OnMenuItem always is TopParent menu object). )
+ }
+ property IsSeparator: Boolean read FIsSeparator;
+ {* TRUE, if a separator menu item. }
+ property MenuBreak: TMenuBreak read FMenuBreak write SetMenuBreak;
+ {* Menu item break type. }
+ property OnUncheckRadioItem : TOnMenuItem read FOnRadioOff write FOnRadioOff;
+ {* Is called when radio item becomes unchecked in menu in result of
+ checking another radio item of the same radio group. }
+ property RadioGroup: Integer read FRadioGroup write FRadioGroup;
+ {* Radio group index. Several neighbour items with the same radio group
+ index form radio group. Only single item from the same group can be
+ checked at a time. }
+ property IsCheckItem: Boolean read FIsCheckItem;
+ {* If menu item is defined as check item, it is checked automatically
+ when clicked. }
+ procedure RadioCheckItem;
+ {* Call this method to check radio item. (Calling this method for
+ an item, which is not belonging to a radio group, just sets its
+ Checked state to TRUE). }
+ property Checked: Boolean index MFS_CHECKED read GetState write SetState;
+ {* Checked state of the item. }
+ property Enabled: Boolean
+ {$IFDEF F_P}
+ index $80000000 or MFS_DISABLED
+ {$ELSE DELPHI}
+ index Integer( $80000000 or MFS_DISABLED )
+ {$ENDIF F_P/DELPHI}
+ read GetState write SetState;
+ {* Enabled state of the item. Whaen assigned, Grayed state also is
+ set to arbitrary value (i.e., when Enabled is set to true, Grayed
+ is set to FALSE. }
+ property DefaultItem: Boolean index MFS_DEFAULT read GetState write SetState;
+ {* Set this property to TRUE to make menu item default. Default item
+ is drawn with bold.
+ |<br>If you change DefaultItem at run-time and whant
+ to provide changing its visual state, recreate the item first resetting
+ Visible property, then setting it again. }
+ property Highlight: Boolean index MFS_HILITE read GetState write SetState;
+ {* Highlight state of the item. }
+ property Visible: Boolean read FVisible write SetMenuVisible;
+ {* Visibility of menu item. }
+ property Data: Pointer read FData write SetData;
+ {* Data pointer, associated with the menu item. }
+ property Bitmap: HBitmap read FBitmap write SetBitmap;
+ {* Bitmap used for unchecked state of the menu item. }
+ property BitmapChecked: HBitmap read FBmpChecked write SetBmpChecked;
+ {* Bitmap used for checked state of the menu item. }
+ property BitmapItem: HBitmap read FBmpItem write SetBmpItem;
+ {* Bitmap used for item itself. In addition, following special values
+ are possible:
+ HBMMENU_CALLBACK, HBMMENU_MBAR_CLOSE, HBMMENU_MBAR_CLOSE_D,
+ HBMMENU_MBAR_MINIMIZE, HBMMENU_MBAR_MINIMIZE_D, HBMMENU_MBAR_RESTORE,
+ HBMMENU_POPUP_CLOSE, HBMMENU_POPUP_MAXIMIZE, HBMMENU_POPUP_MINIMIZE,
+ HBMMENU_POPUP_RESTORE, HBMMENU_SYSTEM. }
+ property Accelerator: TMenuAccelerator read FAccelerator write SetAccelerator;
+ {* Accelerator for menu item. }
+ {$IFDEF GDI}
+ property HelpContext: Integer read FHelpContext write SetHelpContext;
+ {* Help context for entire menu (help context can not be assigned to
+ individual menu items). }
+ {$ENDIF GDI}
+
+ procedure AssignEvents( StartIdx: Integer; const Events: array of TOnMenuItem );
+ {* It is possible to assign its own event handler to every menu item
+ using this call. This procedure also is called automatically in
+ a constructor NewMenuEx. }
+
+ function Popup( X, Y : Integer ): Integer; {!ecm}
+ {* Only for popup menu - to popup it at the given position on screen.
+ Return: If you specify TPM_RETURNCMD in the uFlags parameter, the return
+ value is the menu-item identifier of the item that the user selected.
+ If the user cancels the menu without making a selection, or if an error
+ occurs, then the return value is zero.
+ If you do not specify TPM_RETURNCMD in the uFlags parameter, the return
+ value is nonzero if the function succeeds and zero if it fails. }
+ function PopupEx( X, Y: Integer ): Integer; {!ecm}
+ {* This version of popup command is very useful, when popup menu is activated
+ when its parent window is not visible (e.g., for a kind of applications,
+ which always are invisible, and can be activated only using tray icon).
+ PopupEx method provides correct tracking of menu disappearing when mouse
+ is clicked anywhere else on screen, fixing strange menu behavior in some
+ Windows versions (NT).
+ |<br>
+ Actually, when PopupEx used, parent form is shown but below of visible
+ screen, and when menu is disappearing, previous state of the form (visibility
+ and position) are restored. If such solvation is not satisfying You,
+ You can do something else (e.g., use region clipping, etc.) }
+ property OnPopup: TOnEvent read fOnPopup write fOnPopup;
+ {* This event occurs before the popup menu is shown. }
+ property NotPopup: Boolean read FNotPopup write FNotPopup;
+ {* Set this property to true to prevent popup of popup menu, e.g. in
+ OnPopup event handler. }
+ property Flags: DWORD read FPopupFlags write FPopupFlags;
+ {* Pop-up flags, which are used to call TrackPopupMenuEx, when Popup or
+ PopupEx method is called. Can be a combination of following values:
+ |<br>
+ TPM_CENTERALIGN or TPM_LEFTALIGN or TPM_RIGHTALIGN
+ |<br>
+ TPM_BOTTOMALIGN or TPM_TOPALIGN or TPM_VCENTERALIGN
+ |<br>
+ TPM_NONOTIFY or TPM_RETURNCMD
+ |<br>
+ TPM_LEFTBUTTON or TPM_RIGHTBUTTON
+ |<br>
+ TPM_HORNEGANIMATION or TPM_HORPOSANIMATION or TPM_NOANIMATION or
+ TPM_VERNEGANIMATION or TPM_VERPOSANIMATION
+ |<br>
+ TPM_HORIZONTAL or TPM_VERTICAL.
+ |<br>
+ By default, a combination TPM_LEFTALIGN or TPM_LEFTBUTTON is used. }
+ function Insert(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem;
+ Options: TMenuOptions): PMenu;
+ {* Inserts new menu item before item, given by Id (>=4096) or index
+ value InsertBefore. Pointer to an object created is returned. }
+ property SubMenu: HMenu read FHandle; // write SetSubMenu;
+ {* Submenu associated with the menu item. The same as Handle. It was possible
+ in ealier versions to change this value, replacing (removing, assigning)
+ entire popup menu as a submenu for menu item.
+ But in modern version of TMenu, this is not possible.
+ Instead, entire menu object should be added or removed using
+ InsertSubmenu or RemoveSubmenu methods. }
+ procedure InsertSubMenu( SubMenuToInsert: PMenu; InsertBefore: Integer );
+ {* Inserts existing menu item (together with its subitems if any present)
+ into given position. See also RemoveSubMenu. }
+ function RemoveSubMenu( ItemToRemove: Integer ): PMenu;
+ {* Removes menu item from the menu, returning TMenu object, representing it,
+ if submenu item, having its own children, detached. If an individual menu
+ item is removed, nil is returned.
+ This function can be useful to add or remove dynamically entire submenus
+ (created together with its subitems). }
+ property OnMeasureItem: TOnMeasureItem read FOnMeasureItem write SetOnMeasureItem;
+ {* This event is called for owner-drawn menu items. Event handler should return
+ menu item height in lower word of a result and item width (for menu) in
+ high word of result. If either for height or for width returned value is 0,
+ a default one is used. }
+ property OnDrawItem: TOnDrawItem read FOnDrawItem write SetOnDrawItem;
+ {* This event is called for owner-drawn menu items. }
+ property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw;
+ {* Set this property to true for some items to make it owner-draw. }
+
+ // For compatibility with old code (be sure that item with given index
+ // actually exists):
+ function GetMenuItemHandle( Idx : Integer ): DWORD;
+ {* Returns Id of menu item with given index. }
+ property ItemHandle[ Idx: Integer ]: DWORD read GetMenuItemHandle;
+ {* Returns handle for item given by index. }
+ property ItemChecked[ Idx : Integer ] : Boolean read GetItemChecked write SetItemChecked;
+ {* True, if correspondent menu item is checked. }
+ procedure RadioCheck( Idx : Integer );
+ {* Call this method to check radio item. For radio items, do not
+ use assignment to ItemChecked or Checked properties. }
+ property ItemBitmap[ Idx: Integer ]: HBitmap read GetItemBitmap write SetItemBitmap;
+ {* This property allows to assign bitmap to menu item (for unchecked state
+ only - for checked menu items default checkmark bitmap is used). }
+ procedure AssignBitmaps( StartIdx: Integer; Bitmaps: array of HBitmap );
+ {* Can be used to assign bitmaps to several menu items during one call. }
+ property ItemText[ Idx: Integer ]: KOLString read GetItemText write SetItemText;
+ {* This property allows to get / modify menu item text at run time. }
+ property ItemEnabled[ Idx: Integer ]: Boolean read GetItemEnabled write SetItemEnabled;
+ {* Controls enabling / disabling menu items. Disabled menu items are
+ displayed (grayed) but inaccessible to click. }
+ property ItemVisible[ Idx: Integer ]: Boolean read GetItemVisible write SetItemVisible;
+ {* This property allows to simulate visibility of menu items (implementing
+ it by removing or inserting again if needed. For items of submenu, which
+ is made invisible, True is returned. If such item made Visible, entire
+ submenu with all its parent menu items becomes visible. To release menu
+ properly it is necessary to make before all its items visible again.
+ This does not matter, if menu is released at the end of execution, but
+ can be sensible if owner form is destroyed and re-created at run time
+ dynamically. }
+ property ItemHelpContext[ Idx: Integer ]: Integer read GetItemHelpContext
+ write SetItemHelpContext;
+ function ParentItem( Idx: Integer ): Integer;
+ {* Returns index of parent menu item (for submenu item). If there are no
+ such item (Idx corresponds to root level menu item), -1 is returned. }
+ property ItemAccelerator[ Idx: Integer ]: TMenuAccelerator read GetItemAccelerator write SetItemAccelerator;
+ {* Allows to get / change accelerator key kodes assigned to menu items.
+ Has no effect unless SupportMnemonics called for a form. }
+ property ItemSubmenu[ Idx: Integer ]: HMenu read GetItemSubmenu; // write SetItemSubmenu;
+ {* Retrieves submenu item dynamically. See also SubMenu property. }
+
+ // by Sergey Shisminzev:
+ function AddItem(ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer;
+ {* Adds menu item dynamically. Returns ID of the added item. }
+ function InsertItem(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer;
+ {* Inserts menu item before an item with ID, given by InsertBefore parameter. }
+ function InsertItemEx(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions;
+ ByPosition: Boolean): Integer;
+ {* Inserts menu item by command or by position, dependant on ByPosition parameter }
+ procedure RedrawFormMenuBar;
+ {* }
+
+ {$IFDEF USE_MENU_CURCTL}
+ property CurCtl: PControl read fCurCtl write fCurCtl;
+ {* By Alexander Pravdin. This property is assigned to a control which were
+ initiated a pop-up, for popup menu. }
+ {$ENDIF USE_MENU_CURCTL}
+ {$ENDIF GDI}
+ end;
+
+{$IFDEF WIN_GDI}
+function MenuStructSize: Integer;
+{* Returns 44 under Windows95, and 48 (=sizeof(TMenuItemInfo) under all other
+ Windows versions. }
+
+var FDynamicMenuID: DWORD = $1000;
+{$ENDIF WIN_GDI}
+function NewMenu( AParent : PControl; MaxCmdReserve: DWORD;
+ const Template : array of PKOLChar; aOnMenuItem: TOnMenuItem ): PMenu;
+{* Menu constructor. First created menu becomes main menu of form (if AParent
+ is a form). All other menus becomes popup (can be activated using Popup
+ method). To provide dynamic replacing of main menu, create all popup
+ menus as children of any other control, not form itself.
+ When Menu is created, pass FirstCmd integer value to set it
+ as ID of first menu item (all other ID's obtained by incrementing this value),
+ and Template, which is an array of PChar (usually array of string constants),
+ containing list of menu item identifiers and/or formatting characters.
+|<br>
+ FirstCmd value is assigned to first menu item created as its ID,
+ all follow menu items are assigned to ID's obtained from FirstCmd incrementing
+ it by 1. It is desirable to provide not intersected ranges of ID's for
+ defferent menus in the applet.
+|<br>
+ Following formatting characters can be used in menu template strings:
+|&L=<br><b>%1</b>
+ <L & (in identifier)> - to underline next character and use it as a shortcut character
+ when possible;
+ <L + (in front of identifier)> - to make item checked. If also
+|<b>!</b> is used before <b>
+ &
+|</b> than radioitem is defined;
+ <L - (in front of identifier)> - item not checked;
+ <L - (separate)> - separator (between two items);
+ <L ( (separate)> - start of submenu;
+ <L ) (separate)> - end of submenu;
+|<br>
+ To get access to menu items, use constants 0, 1, etc. It is a good idea
+ to create special enumerated type to index correspondent menu items
+ using Ord( ) operator. Note in that case, that it is necessary only to
+ define constants correspondent to identifiers (positions, correspondent
+ to separators or submenu brackets are not identified by numbers).
+|<br>
+}
+
+function NewMenuEx( AParent : PControl; FirstCmd : Integer;
+ const Template : array of PKOLChar; aOnMenuItems: array of TOnMenuItem ): PMenu;
+{* Creates menu, assigning its own event handler for every (enough) menu item. }
+{$IFDEF WIN_GDI}
+
+function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator;
+{* Creates accelerator item to assign it to TMenu.ItemAccelerator[ ] property
+ easy.}
+
+// {YS} added 7 Aug 2004
+function GetAcceleratorText( const Accelerator: TMenuAccelerator ): KOLString;
+{* Returns text representation of accelerator.
+ |<hr>
+
+ <R System functions and working with windows>
+}
+type
+ TWindowChildKind = ( wcActive, wcFocus, wcCapture, wcMenuOwner,
+ wcMoveSize, wcCaret );
+ {* Type of window child kind. Used in function GetWindowChild. }
+
+function GetWindowChild( Wnd: HWnd; Kind: TWindowChildKind ): HWnd;
+{* Returns child of given top-level window, having given characteristics.
+ For example, it is possible to get know for foreground window,
+ which of its child window has focus. This function does not work in old
+ Windows 95 (returns Wnd in that case). But for Windows 98, Windows NT/2000
+ this function works fine. To obtain focused child of the window,
+ use GetFocusedWindow, which is independant from Windows version. }
+
+function GetFocusedChild( Wnd: HWnd ): HWnd;
+{* Returns focused child of given window (which should be foreground
+ and active, certainly). 0 is returned either if Wnd is not active
+ or Wnd has no focused child window. }
+
+function Stroke2Window( Wnd: HWnd; const S: AnsiString ): Boolean;
+{* Posts characters from string S to those child window of Wnd, which
+ has focus now (top-level window Wnd must be foreground, and have
+ focused edit-aware control to receive the stroke).
+ |<br>
+ This function allows only to post typeable characters (including
+ such special symbols as #13 (Enter), #9 (Tab), #8 (BackSpace), etc.
+ |<br>
+ See also function Stroke2WindowEx, which allows to post any key down
+ and up events, simulating keyboard for given (automated) application. }
+
+function Stroke2WindowEx( Wnd: HWnd; const S: AnsiString; Wait: Boolean ): Boolean;
+{* In addition to function Stroke2Window, this one can send special keys
+ to given window, including functional keys and navigation keys. To
+ post special key to target window, place a combination of names of
+ such key together with keys, which should be passed simultaneously,
+ between square or figure brackets. For example, [Ctrl F1], [Alt Shift Home],
+ [Ctrl E]. For letters and usual characters, it is not necessary to
+ simulate pressing it with determining all Shift combinations and it is
+ sufficient to pass characters as is. (E.g., not '[Shift 1]', but '!'). }
+
+function FindWindowByThreadID( ThreadID : DWORD ) : HWnd;
+{* Searches for window, belonging to a given thread. }
+
+function DesktopPixelFormat: TPixelFormat;
+{* Returns the pixel format correspondent to current desktop color resolution.
+ Use this function to decide which format to use for converting bitmap,
+ planned to draw transparently using TBitmap.DrawTransparent or
+ TBitmap.StretchDrawTransparent methods. }
+
+function GetDesktopRect : TRect;
+{* Returns rectangle of screen, free of taskbar and other
+ similar app-bars, which reduces size of available desktop
+ when created. }
+function GetWorkArea: TRect;
+{* The same as GetDesktopRect, but obtained calling SystemParametersInfo. }
+
+function ExecuteWait( const AppPath, CmdLine, DfltDirectory: KOLString;
+ Show: DWORD; TimeOut: DWORD; ProcID: PDWORD ): Boolean;
+{* Allows to execute an application and wait when it is finished. Pass
+ INFINITE constant as TimeOut, if You sure that application is finished
+ anyway. If another value passed as a TimeOut (in milliseconds), and
+ application was not finished for that time, ExecuteWait is returning
+ FALSE, and if ProcID is not nil, than ProcID^ contains started process
+ handle (it can be used to wait it more, or to terminate it using
+ TerminateProcess API function).
+ |<br>
+ Launching application can be console or GUI - it does not matter.
+ Pass SW_SHOW, SW_HIDE or other SW_XXX constant as Show parameter
+ as appropriate.
+ |<br>
+ True is returned only in case when application specified was launched
+ successfully and finished for TimeOut specified. Otherwise, check
+ ProcID^ variable: if it is 0, process could not be launched (and it
+ is possible to get information about error using GetLastError API
+ function in a such case). You can freely pass nil in place of ProcID
+ parameter, but this is acually correct only when TimeOut is INFINITE. }
+function ExecuteIORedirect( const AppPath, CmdLine, DfltDirectory: KOLString;
+ Show: DWORD; ProcID: PDWORD; InPipe, OutPipeWr, OutPipeRd: PHandle ): Boolean;
+{* Executes an application with its console input and output redirection.
+ Terminating of the application is not waiting, but if ProcID pointer
+ is defined, it receives process Id launched, so it is possible to
+ call WaitForSingleObject for it. InPipe is a pointer to THandle variable
+ which receives a handle to input pipe of the console redirected. The same
+ is for OutPipeWr and OutPipeRd, but for output of the console redirected.
+ Before reading from OutPipeRd^, first close OutPipeWr^. If you run
+ simple console application, for which you want to read results after its
+ termination, you can use ExecuteConsoleAppIORedirect instead.
+ |<br>
+ Notes: if your application is not console and it does not create console
+ using AllocConsole, this function will fail to redirect input-output. }
+function ExecuteConsoleAppIORedirect( const AppPath, CmdLine, DfltDirectory: KOLString;
+ Show: DWORD; const InStr: KOLString; var OutStr: KOLString; WaitTimeout: DWORD )
+ : Boolean;
+{* Executes an application, redirecting its console input and output.
+ After redirecting input and output and launching the application,
+ content of InStr is written to input stream of the application, then
+ the application is waiting for its termination (WaitTimeout milliseconds
+ or INFINITE, as passed) and console output of the application is read to
+ OutStr. TRUE is returned only in case, when all these tasks are
+ completed successfully.
+ |<br>
+ Notes: if your application is not console and it does not create console
+ using AllocConsole, this function will fail to redirect input-output. }
+
+function WindowsShutdown( const Machine : KOLString; Force, Reboot : Boolean ) : Boolean;
+{* Shut down of Windows NT. Pass Machine = '' to shutdown this PC.
+ Pass Reboot = True to reboot immediatelly after shut down. }
+function WindowsLogoff( Force : Boolean ) : Boolean;
+{* Logoff of Windows. }
+
+
+type
+ TWindowsVersion = ( wv31, wv95, wv98, wvME, wvNT, wvY2K, wvXP, wvServer2003,
+ wvVista, wvSeven );
+ {* Windows versions constants. }
+ TWindowsVersions = Set of TWindowsVersion;
+ {* Set of Windows version (e.g. to define a range of versions supported by the
+ application). }
+
+function WinVer : TWindowsVersion;
+{* Returns Windows version. }
+function IsWinVer( Ver : TWindowsVersions ) : Boolean;
+{* Returns True if Windows version is in given range of values. }
+{$IFNDEF PARAMS_DEFAULT}
+function SkipParam(P: PKOLChar): PKOLChar; //forward;
+function ParamStr( Idx: Integer ): KOLString;
+{* Returns command-line parameter by index. This function supersides
+ standard ParamStr function. }
+function ParamCount: Integer;
+{* Returns number of parameters in command line.
+|<hr>
+}
+{$ENDIF}
+{$ENDIF WIN_GDI}
+
+{$IFDEF INPACKAGE}
+ {$IFDEF ASM_VERSION}
+ {$UNDEF ASM_VERSION}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF WIN_GDI}
+//{$DEFINE CHK_BITBLT}
+{$IFDEF CHK_BITBLT}
+procedure Chk_BitBlt;
+{$ENDIF}
+{$IFDEF ASM_VERSION}
+ {$DEFINE ASM_DC}
+{$ENDIF}
+{$IFDEF ASM_DC}
+procedure StartDC;
+procedure FinishDC;
+{$ENDIF ASM_VERSION}
+
+function WndProcCtrl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+function WndProcDoEraseBkgnd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+
+var CreatingWindow: PControl;
+ //ActiveWindow: HWnd;
+{$ENDIF WIN_GDI}
+{$IFDEF _D2}
+// Assert operator was not available in Delphi2. Provide here easy Assert
+// procedure for Delphi2.
+procedure Assert( Cond: Boolean; const Msg: AnsiString );
+
+var AssertErrorProc: procedure( const Message, Filename: AnsiString; LineNumber: Integer );
+{$ENDIF}
+
+{$IFDEF USE_CUSTOMEXTENSIONS}
+ {$I CUSTOM_KOL_EXTENSION.inc} // See comments in TControl
+{$ENDIF}
+
+{$IFDEF DEBUG_ENDSESSION}
+var EndSession_Initiated: Boolean;
+{$ENDIF}
+
+{$IFDEF WIN_GDI}
+var
+ FMMNotify: procedure( var Msg: TMsg );
+
+procedure ClearText( Sender: PControl );
+procedure ClearListbox( Sender: PControl );
+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;
+ EDIT_ACTIONS = 3;
+ LIST_ACTIONS = 4;
+ COMBO_ACTIONS = 5;
+ LISTVIEW_ACTIONS = 6;
+ TREEVIEW_ACTIONS = 7;
+ TABCONTROL_ACTIONS = 8;
+ RICHEDIT_ACTIONS = 9;
+ PROGRESS_ACTIONS = 10;
+ TOOLBAR_ACTIONS = 11;
+ LAST_ACTIONS = 11;
+var AllActions_Objs: array[ 0..LAST_ACTIONS ] of PCommandActionsObj;
+{$ENDIF}
+
+const
+ {$IFDEF PACK_COMMANDACTIONS}
+ ButtonActions_Packed: PAnsiChar = Char(BUTTON_ACTIONS) +
+ #0#0 + //BN_CLICKED
+ #6#0 + //BN_SETFOCUS
+ #7#0 + //BN_KILLFOCUS
+ #225 + //25 нулей
+ #0#1 + //BS_LEFT
+ #0#2 + //BS_RIGHT
+ #0#3 + //BS_CENTER
+ #0#4 + //0, BS_TOP>>8
+ #12#8+ // BS_VCENTER>>8, BS_BOTTOM>>8
+ #204 //4 нуля
+ ;
+ {$ELSE}
+ ButtonActions: TCommandActions = (
+ aClear: ClearText;
+ aAddText: nil;
+ aClick: BN_CLICKED;
+ aEnter: BN_SETFOCUS;
+ aLeave: BN_KILLFOCUS;
+ aChange: 0;
+ aSelChange: 0;
+ aGetCount: 0;
+ aSetCount: 0;
+ aGetItemLength: 0;
+ aGetItemText: 0;
+ aSetItemText: 0;
+ aGetItemData: 0;
+ aSetItemData: 0;
+ aAddItem: 0;
+ aDeleteItem: 0;
+ aInsertItem: 0;
+ aFindItem: 0;
+ aFindPartial: 0;
+ bItem2Pos: 0;
+ bPos2Item: 0;
+ aGetSelCount: 0;
+ aGetSelected: 0;
+ aGetSelRange: 0;
+ aGetCurrent: 0;
+ aSetSelected: 0;
+ aSetCurrent: 0;
+ aSetSelRange: 0;
+ aExSetSelRange: 0;
+ aGetSelection: 0;
+ aReplaceSel: 0;
+ aTextAlignLeft: BS_LEFT;
+ aTextAlignRight: BS_RIGHT;
+ aTextAlignCenter: BS_CENTER;
+ bTextAlignMask: 0;
+ bVertAlignTop: BS_TOP shr 8; //=4
+ bVertAlignCenter: BS_VCENTER shr 8; //=12
+ bVertAlignBottom: BS_BOTTOM shr 8; //=8
+ aDir: 0;
+ aSetLimit: 0;
+ aSetImgList: 0;
+ //-----aAutoSzX: 14;
+ //-----aAutoSzY: 6;
+ aSetBkColor: 0;
+ );
+ {$ENDIF}
+
+const
+ {$IFDEF PACK_COMMANDACTIONS}
+ LabelActions_Packed: PAnsiChar = Char( LABEL_ACTIONS ) +
+ #229 + //29 нулей
+ #2#0 + // SS_RIGHT
+ #1#0 + // SS_CENTER
+ #12#0 + // SS_LEFTNOWORDWRAP, 0
+ #2#0 + // SS_CENTERIMAGE>>8, 0
+ #205;
+ {$ELSE}
+ LabelActions: TCommandActions = (
+ aClear: ClearText;
+ aAddText: nil;
+ aClick: 0;
+ aEnter: 0;
+ aLeave: 0;
+ aChange: 0;
+ aSelChange: 0;
+ aGetCount: 0;
+ aSetCount: 0;
+ aGetItemLength: 0;
+ aGetItemText: 0;
+ aSetItemText: 0;
+ aGetItemData: 0;
+ aSetItemData: 0;
+ aAddItem: 0;
+ aDeleteItem: 0;
+ aInsertItem: 0;
+ aFindItem: 0;
+ aFindPartial: 0;
+ bItem2Pos: 0;
+ bPos2Item: 0;
+ aGetSelCount: 0;
+ aGetSelected: 0;
+ aGetSelRange: 0;
+ aGetCurrent: 0;
+ aSetSelected: 0;
+ aSetCurrent: 0;
+ aSetSelRange: 0;
+ aExSetSelRange: 0;
+ aGetSelection: 0;
+ aReplaceSel: 0;
+ aTextAlignLeft: SS_LEFT;
+ aTextAlignRight: SS_RIGHT;
+ aTextAlignCenter: SS_CENTER;
+ bTextAlignMask: SS_LEFTNOWORDWRAP;
+ bVertAlignTop: 0;
+ bVertAlignCenter: SS_CENTERIMAGE shr 8;
+ bVertAlignBottom: 0;
+ aDir: 0;
+ aSetLimit: 0;
+ aSetImgList: 0;
+ //---- aAutoSzX: 1;
+ //---- aAutoSzY: 1;
+ aSetBkColor: 0;
+ );
+ {$ENDIF}
+
+const
+ EN_LINK = $070b;
+ {$IFDEF PACK_COMMANDACTIONS}
+ EditActions_Packed: PAnsiChar = Char( EDIT_ACTIONS ) +
+ #201 +
+ #0#1 + // EN_SETFOCUS
+ #0#2 + // EN_KILLFOCUS
+ #0#3 + // EN_CHANGE
+ #201 +
+ #$BA#0 + // EM_GETLINECOUNT
+ #201 +
+ #$C1#0 + // EM_LINELENGTH
+ #$C4#0 + // EM_GETLINE
+ #$C2#0 + // EM_REPLACESEL
+ #207 +
+ #$BB#$C9 + // EM_LINEINDEX, EM_LINEFROMCHAR
+ #$B0#0 + // EM_GETSEL
+ #201 +
+ #$B0#0 + // EM_GETSEL
+ #$BB#0 + // EM_LINEINDEX
+ #202 +
+ #$B1#0 + // EM_SETSEL
+ #202 +
+ #$C2#0 + // EM_REPLACESEL
+ #201 + // ES_LEFT
+ #2#0 + // ES_RIGHT
+ #1#0 + // ES_CENTER
+ #203 +
+ #$C5#0 + // EM_SETLIMITTEXT
+ #202 +
+ #200#214#0; // EM_POSFROMCHAR
+ {$ELSE}
+ EditActions: TCommandActions = (
+ aClear: ClearText;
+ aAddText: nil;
+ aClick: 0;
+ aEnter: EN_SETFOCUS;
+ aLeave: EN_KILLFOCUS;
+ aChange: EN_CHANGE;
+ aSelChange: 0;
+ aGetCount: EM_GETLINECOUNT;
+ aSetCount: 0;
+ aGetItemLength: EM_LINELENGTH;
+ aGetItemText: EM_GETLINE;
+ aSetItemText: EM_REPLACESEL;
+ aGetItemData: 0;
+ aSetItemData: 0;
+ aAddItem: 0;
+ aDeleteItem: 0;
+ aInsertItem: 0;
+ aFindItem: 0;
+ aFindPartial: 0;
+ bItem2Pos: EM_LINEINDEX;
+ bPos2Item: EM_LINEFROMCHAR;
+ aGetSelCount: EM_GETSEL;
+ aGetSelected: 0;
+ aGetSelRange: EM_GETSEL;
+ aGetCurrent: EM_LINEINDEX;
+ aSetSelected: 0;
+ aSetCurrent: 0;
+ aSetSelRange: EM_SETSEL;
+ aExSetSelRange: 0;
+ aGetSelection: 0;
+ aReplaceSel: EM_REPLACESEL;
+ aTextAlignLeft: ES_LEFT;
+ aTextAlignRight: ES_RIGHT;
+ aTextAlignCenter: ES_CENTER;
+ bTextAlignMask: 0;
+ bVertAlignTop: 0;
+ bVertAlignCenter: 0;
+ bVertAlignBottom: 0;
+ aDir: 0;
+ aSetLimit: EM_SETLIMITTEXT;
+ aSetImgList: 0;
+ //---- aAutoSzX: 0;
+ //---- aAutoSzY: 6;
+ aSetBkColor: 0;
+ aItem2XY: EM_POSFROMCHAR;
+ );
+ {$ENDIF}
+
+const
+ {$IFDEF PACK_COMMANDACTIONS}
+ ListActions_Packed: PAnsiChar = Char(LIST_ACTIONS) +
+ #2#0 + // LBN_DBLCLK
+ #4#0 + // LBN_SETFOCUS
+ #5#0 + // LBN_KILLFOCUS
+ #201 +
+ #1#0 + // LBN_SELCHANGE
+ #$8B#1 + // LB_GETCOUNT
+ #$A7#1 + // LB_SETCOUNT
+ #$8A#1 + // LB_GETTEXTLEN
+ #$89#1 + // LB_GETTEXT
+ #201 +
+ #$99#1 + // LB_GETITEMDATA
+ #$9A#1 + // LB_SETITEMDATA
+ #$80#1 + // LB_ADDSTRING
+ #$82#1 + // LB_DELETESTRING
+ #$81#1 + // LB_INSERTSTRING
+ #$A2#1 + // LB_FINDSTRINGEXACT
+ #$8F#1 + // LB_FINDSTRING
+ #201 +
+ #$90#1 + // LB_GETSELCOUNT
+ #$87#1 + // LB_GETSEL
+ #201 +
+ #$88#1 + // LB_GETCURSEL
+ #$85#1 + // LB_SETSEL
+ #$86#1 + // LB_SETCURSEL
+ #209 +
+ #$8D#1 + // LB_DIR
+ #203 +
+ #$98#1; // LB_GETITEMRECT
+ {$ELSE}
+ ListActions: TCommandActions = (
+ aClear: ClearListbox;
+ aAddText: nil;
+ aClick: LBN_DBLCLK;
+ aEnter: LBN_SETFOCUS;
+ aLeave: LBN_KILLFOCUS;
+ aChange: 0;
+ aSelChange: LBN_SELCHANGE;
+ aGetCount: LB_GETCOUNT;
+ aSetCount: LB_SETCOUNT;
+ aGetItemLength: LB_GETTEXTLEN;
+ aGetItemText: LB_GETTEXT;
+ aSetItemText: 0;
+ aGetItemData: LB_GETITEMDATA;
+ aSetItemData: LB_SETITEMDATA;
+ aAddItem: LB_ADDSTRING;
+ aDeleteItem: LB_DELETESTRING;
+ aInsertItem: LB_INSERTSTRING;
+ aFindItem: LB_FINDSTRINGEXACT;
+ aFindPartial: LB_FINDSTRING;
+ bItem2Pos: 0;
+ bPos2Item: 0;
+ aGetSelCount: LB_GETSELCOUNT;
+ aGetSelected: LB_GETSEL;
+ aGetSelRange: 0;
+ aGetCurrent: LB_GETCURSEL;
+ aSetSelected: LB_SETSEL;
+ aSetCurrent: LB_SETCURSEL;
+ aSetSelRange: 0;
+ aExSetSelRange: 0;
+ aGetSelection: 0;
+ aReplaceSel: 0;
+ aTextAlignLeft: 0;
+ aTextAlignRight: 0;
+ aTextAlignCenter: 0;
+ bTextAlignMask: 0;
+ bVertAlignTop: 0;
+ bVertAlignCenter: 0;
+ bVertAlignBottom: 0;
+ aDir: LB_DIR;
+ aSetLimit: 0;
+ aSetImgList: 0;
+ //---- aAutoSzX: 0;
+ //---- aAutoSzY: 0;
+ aSetBkColor: 0;
+ aItem2XY: LB_GETITEMRECT;
+ );
+ {$ENDIF}
+
+const
+ {$IFDEF PACK_COMMANDACTIONS}
+ ComboActions_Packed: PAnsiChar = Char(COMBO_ACTIONS) +
+ #2#0 + // CBN_DBLCLK
+ #3#0 + // CBN_SETFOCUS
+ #4#0 + // CBN_KILLFOCUS
+ #5#0 + // CBN_EDITCHANGE
+ #15#0 + // CM_CBN_SELCHANGE
+ #$46#1 + // CB_GETCOUNT
+ #201 +
+ #$49#1 + // CB_GETLBTEXTLEN
+ #$48#1 + // CB_GETLBTEXT
+ #201 +
+ #$50#1 + // CB_GETITEMDATA
+ #$51#1 + // CB_SETITEMDATA
+ #$43#1 + // CB_ADDSTRING
+ #$44#1 + // CB_DELETESTRING
+ #$4A#1 + // CB_INSERTSTRING
+ #$58#1 + // CB_FINDSTRINGEXACT
+ #$4C#1 + // CB_FINDSTRING
+ #202 +
+ #$47#1 + // CB_GETCURSEL
+ #201 +
+ #$47#1 + // CB_GETCURSEL
+ #201 +
+ #$4E#1 + // CB_SETCURSEL
+ #209 +
+ #$45#1 + // CB_DIR
+ #203;
+ {$ELSE}
+ ComboActions: TCommandActions = (
+ aClear: ClearCombobox;
+ aAddText: nil;
+ aClick: CBN_DBLCLK;
+ aEnter: CBN_SETFOCUS;
+ aLeave: CBN_KILLFOCUS;
+ aChange: CBN_EDITCHANGE;
+ aSelChange: CM_CBN_SELCHANGE;
+ aGetCount: CB_GETCOUNT;
+ aSetCount: 0;
+ aGetItemLength: CB_GETLBTEXTLEN;
+ aGetItemText: CB_GETLBTEXT;
+ aSetItemText: 0;
+ aGetItemData: CB_GETITEMDATA;
+ aSetItemData: CB_SETITEMDATA;
+ aAddItem: CB_ADDSTRING;
+ aDeleteItem: CB_DELETESTRING;
+ aInsertItem: CB_INSERTSTRING;
+ aFindItem: CB_FINDSTRINGEXACT;
+ aFindPartial: CB_FINDSTRING;
+ bItem2Pos: 0;
+ bPos2Item: 0;
+ aGetSelCount: 0;
+ aGetSelected: CB_GETCURSEL;
+ aGetSelRange: 0;
+ aGetCurrent: CB_GETCURSEL;
+ aSetSelected: 0;
+ aSetCurrent: CB_SETCURSEL;
+ aSetSelRange: 0;
+ aExSetSelRange: 0;
+ aGetSelection: 0;
+ aReplaceSel: 0;
+ aTextAlignLeft: 0; //ES_LEFT;
+ aTextAlignRight: 0; //ES_RIGHT;
+ aTextAlignCenter: 0; //ES_CENTER;
+ bTextAlignMask: 0;
+ bVertAlignTop: 0;
+ bVertAlignCenter: 0;
+ bVertAlignBottom: 0;
+ aDir: CB_DIR;
+ aSetLimit: 0;
+ aSetImgList: 0;
+ //---- aAutoSzX: 0;
+ //---- aAutoSzY: 6;
+ aSetBkColor: 0;
+ );
+ {$ENDIF}
+
+const
+ {$IFDEF PACK_COMMANDACTIONS}
+ ListViewActions_Packed: PAnsiChar = Char( LISTVIEW_ACTIONS ) +
+ #203 +
+ #$9B#$FF + // LVN_ITEMCHANGED
+ #201 +
+ #4#$10 + // LVM_GETITEMCOUNT
+ #47#$10 + // LVM_SETITEMCOUNT
+ //#211 +
+ #206 + #8#$10 // LVM_DELETEITEM
+ + #204 +
+ #50#$10 + // LVM_GETSELECTEDCOUNT
+ #44#$10 + // LVM_GETITEMSTATE
+ #201 +
+ #12#$10 + // LVM_GENEXTITEM
+ #213 +
+ #3#$10 + // LVM_SETIMAGELIST
+ #1#$10 + // LVM_SETBKCOLOR
+ #14#$10; // LVM_GETITEMRECT
+ {$ELSE}
+ ListViewActions: TCommandActions = (
+ aClear: ClearListView;
+ aAddText: nil;
+ aClick: 0;
+ aEnter: 0;
+ aLeave: 0;
+ aChange: LVN_ITEMCHANGED;
+ aSelChange: 0;
+ aGetCount: LVM_GETITEMCOUNT;
+ aSetCount: LVM_SETITEMCOUNT;
+ aGetItemLength: 0;
+ aGetItemText: 0;
+ aSetItemText: 0;
+ aGetItemData: 0;
+ aSetItemData: 0;
+ aAddItem: 0;
+ aDeleteItem: LVM_DELETEITEM;
+ aInsertItem: 0;
+ aFindItem: 0;
+ aFindPartial: 0;
+ bItem2Pos: 0;
+ bPos2Item: 0;
+ aGetSelCount: { $8000 or} LVM_GETSELECTEDCOUNT;
+ aGetSelected: LVM_GETITEMSTATE;
+ aGetSelRange: 0;
+ aGetCurrent: LVM_GETNEXTITEM;
+ aSetSelected: 0;
+ aSetCurrent: 0;
+ aSetSelRange: 0;
+ aExSetSelRange: 0;
+ aGetSelection: 0;
+ aReplaceSel: 0;
+ aTextAlignLeft: 0;
+ aTextAlignRight: 0;
+ aTextAlignCenter: 0;
+ bTextAlignMask: 0;
+ bVertAlignTop: 0;
+ bVertAlignCenter: 0;
+ bVertAlignBottom: 0;
+ aDir: 0;
+ aSetLimit: 0;
+ aSetImgList: LVM_SETIMAGELIST;
+ //---- aAutoSzX: 0;
+ //---- aAutoSzY: 0;
+ aSetBkColor: LVM_SETBKCOLOR;
+ aItem2XY: LVM_GETITEMRECT;
+ );
+ {$ENDIF}
+
+const
+ {$IFDEF PACK_COMMANDACTIONS}
+ TreeViewActions_Packed: PAnsiChar = Char( TREEVIEW_ACTIONS ) +
+ #203 +
+ {$IFDEF UNICODE_CTRLS} #$34#$FE {$ELSE} #$65#$FE {$ENDIF} + // TVN_ENDLABELEDIT(W)
+ {$IFDEF UNICODE_CTRLS} #$3E#$FE {$ELSE} #$6E#$FE {$ENDIF} + // TVN_SELCHANGED(W)
+ #5#$11 + // TVM_GETCOUNT
+ #207 +
+ #1#$11 + // TVM_DELETEITEM
+ #221 +
+ #9#$11 + // TVM_SETIMAGELIST
+ #29#$11 + // TVM_SETBKCOLOR
+ #4#$11; // TVM_GETITEMRECT
+ {$ELSE}
+ TreeViewActions: TCommandActions = (
+ aClear: ClearTreeView;
+ aAddText: nil;
+ aClick: 0;
+ aEnter: 0;
+ aLeave: 0;
+ aChange: TVN_ENDLABELEDIT;
+ aSelChange: TVN_SELCHANGED;
+ aGetCount: TVM_GETCOUNT;
+ aSetCount: 0;
+ aGetItemLength: 0;
+ aGetItemText: 0;
+ aSetItemText: 0;
+ aGetItemData: 0;
+ aSetItemData: 0;
+ aAddItem: 0;
+ aDeleteItem: TVM_DELETEITEM;
+ aInsertItem: 0;
+ aFindItem: 0;
+ aFindPartial: 0;
+ bItem2Pos: 0;
+ bPos2Item: 0;
+ aGetSelCount: 0;
+ aGetSelected: 0;
+ aGetSelRange: 0;
+ aGetCurrent: 0;
+ aSetSelected: 0;
+ aSetCurrent: 0;
+ aSetSelRange: 0;
+ aExSetSelRange: 0;
+ aGetSelection: 0;
+ aReplaceSel: 0;
+ aTextAlignLeft: 0;
+ aTextAlignRight: 0;
+ aTextAlignCenter: 0;
+ bTextAlignMask: 0;
+ bVertAlignTop: 0;
+ bVertAlignCenter: 0;
+ bVertAlignBottom: 0;
+ aDir: 0; //CB_DIR;
+ aSetLimit: 0;
+ aSetImgList: TVM_SETIMAGELIST;
+ //---- aAutoSzX: 0;
+ //---- aAutoSzY: 0;
+ aSetBkColor: TVM_SETBKCOLOR;
+ aItem2XY: TVM_GETITEMRECT;
+ );
+ {$ENDIF}
+
+const
+ {$IFDEF PACK_COMMANDACTIONS}
+ TabControlActions_Packed: PAnsiChar = Char( TABCONTROL_ACTIONS ) +
+ #203 +
+ #200#$D9#$FD + // TCN_SELCHANGE
+ #200#$D9#$FD + // TCN_SELCHANGE
+ #4#$13 + // TCM_GETITEMCOUNT
+ #215 +
+ #11#$13 + // TCM_GETCURSEL
+ #201 +
+ #12#$13 + // TCM_SETCURSEL
+ #211 +
+ #3#$13 + // TCM_SETIMAGELIST
+ #201 +
+ #10#$13; // TCM_GETITEMRECT
+ {$ELSE}
+ TabControlActions: TCommandActions = (
+ aClear: ClearText;
+ aAddText: nil;
+ aClick: 0;
+ aEnter: 0;
+ aLeave: 0;
+ aChange: TCN_SELCHANGE;
+ aSelChange: TCN_SELCHANGE;
+ aGetCount: TCM_GETITEMCOUNT;
+ aSetCount: 0;
+ aGetItemLength: 0;
+ aGetItemText: 0;
+ aSetItemText: 0;
+ aGetItemData: 0;
+ aSetItemData: 0;
+ aAddItem: 0;
+ aDeleteItem: 0;
+ aInsertItem: 0;
+ aFindItem: 0;
+ aFindPartial: 0;
+ bItem2Pos: 0;
+ bPos2Item: 0;
+ aGetSelCount: 0;
+ aGetSelected: 0;
+ aGetSelRange: 0;
+ aGetCurrent: TCM_GETCURSEL;
+ aSetSelected: 0;
+ aSetCurrent: TCM_SETCURSEL; //TCM_SETCURFOCUS;
+ aSetSelRange: 0;
+ aExSetSelRange: 0;
+ aGetSelection: 0;
+ aReplaceSel: 0;
+ aTextAlignLeft: 0;
+ aTextAlignRight: 0;
+ aTextAlignCenter: 0;
+ bTextAlignMask: 0;
+ bVertAlignTop: 0;
+ bVertAlignCenter: 0;
+ bVertAlignBottom: 0;
+ aDir: 0; // CB_DIR;
+ aSetLimit: 0;
+ aSetImgList: TCM_SETIMAGELIST;
+ //---- aAutoSzX: 0;
+ //---- aAutoSzY: 0;
+ aSetBkColor: 0;
+ aItem2XY: TCM_GETITEMRECT;
+ );
+ {$ENDIF}
+
+{$IFNDEF NOT_USE_RICHEDIT}
+const
+ {$IFDEF PACK_COMMANDACTIONS}
+ RichEditActions_Packed: PAnsiChar = Char( RICHEDIT_ACTIONS ) +
+ #201 +
+ #0#1 + // EN_SETFOCUS
+ #0#2 + // EN_KILLFOCUS
+ #0#3 + // EN_CHANGE
+ #2#7 + // EN_SELCHANGE
+ #$BA#0 + // EM_GETLINECOUNT
+ #201 +
+ #$C1#0 + // EM_LINELENGTH
+ #$C4#0 + // EM_GETLINE
+ #$C2#0 + // EM_REPLACESEL
+ #207 +
+ #$BB#$C9 + // EM_LINEINDEX, EM_LINEFROMCHAR
+ #$B0#0 + // EM_GETSEL
+ #201 +
+ #$B0#0 + // EM_GETSEL
+ #$BB#0 + // EM_LINEINDEX
+ #203 +
+ #55#4 + // EM_EXSETSEL
+ #62#4 + // EM_GETSELTEXT
+ #$C2#0 + // EM_REPLACESEL
+ #201 + // ES_LEFT
+ #2#0 + // ES_RIGHT
+ #1#0 + // ES_CENTER
+ #203 +
+ #53#4 + // EM_EXLIMITTEXT
+ #201 +
+ #67#4 + // EM_SETBKGNDCOLOR
+ #200#214#0; // EM_POSFROMCHAR
+ {$ELSE}
+ RichEditActions: TCommandActions = (
+ aClear: ClearText;
+ aAddText: nil;
+ aClick: 0;
+ aEnter: EN_SETFOCUS;
+ aLeave: EN_KILLFOCUS;
+ aChange: EN_CHANGE;
+ aSelChange: EN_SELCHANGE;
+ aGetCount: EM_GETLINECOUNT;
+ aSetCount: 0;
+ aGetItemLength: EM_LINELENGTH;
+ aGetItemText: EM_GETLINE;
+ aSetItemText: EM_REPLACESEL;
+ aGetItemData: 0;
+ aSetItemData: 0;
+ aAddItem: 0;
+ aDeleteItem: 0;
+ aInsertItem: 0;
+ aFindItem: 0;
+ aFindPartial: 0;
+ bItem2Pos: EM_LINEINDEX;
+ bPos2Item: EM_LINEFROMCHAR;
+ aGetSelCount: EM_GETSEL;
+ aGetSelected: 0;
+ aGetSelRange: EM_GETSEL;
+ aGetCurrent: EM_LINEINDEX;
+ aSetSelected: 0;
+ aSetCurrent: 0;
+ aSetSelRange: 0;
+ aExSetSelRange: EM_EXSETSEL;
+ aGetSelection: EM_GETSELTEXT;
+ aReplaceSel: EM_REPLACESEL;
+ aTextAlignLeft: ES_LEFT;
+ aTextAlignRight: ES_RIGHT;
+ aTextAlignCenter: ES_CENTER;
+ bTextAlignMask: 0;
+ bVertAlignTop: 0;
+ bVertAlignCenter: 0;
+ bVertAlignBottom: 0;
+ aDir: 0;
+ aSetLimit: EM_EXLIMITTEXT;
+ aSetImgList: 0;
+ //---- aAutoSzX: 0;
+ //---- aAutoSzY: 0;
+ aSetBkColor: EM_SETBKGNDCOLOR;
+ aItem2XY: EM_POSFROMCHAR;
+ );
+ {$ENDIF}
+
+{$ENDIF NOT_USE_RICHEDIT}
+
+const
+ BaseFileMethods: TStreamMethods = (
+ fSeek: SeekFileStream;
+ fGetSiz: GetSizeFileStream;
+ fSetSiz: DummySetSize;
+ fRead: DummyReadWrite;
+ fWrite: DummyReadWrite;
+ fClose: CloseFileStream;
+ fCustom: nil;
+ );
+
+ MemoryMethods: TStreamMethods = (
+ fSeek: SeekMemStream;
+ fGetSiz: GetSizeMemStream;
+ fSetSiz: SetSizeMemStream;
+ fRead: ReadMemStream;
+ fWrite: WriteMemStream;
+ fClose: CloseMemStream;
+ fCustom: nil;
+ );
+
+ ConcatStreamMethods: TStreamMethods = (
+ fSeek: SeekConcatStream;
+ fGetSiz: GetSizeConcatStream;
+ fSetSiz: SetSizeConcatStream;
+ fRead: ReadConcatStream;
+ fWrite: WriteConcatStream;
+ fClose: CloseConcatStream;
+ fCustom: nil;
+ );
+
+ SubStreamMethods: TStreamMethods = (
+ fSeek: SeekSubStream;
+ fGetSiz: GetSizeSubStream;
+ fSetSiz: SetSizeSubStream;
+ fRead: ReadSubStream;
+ fWrite: WriteSubStream;
+ fClose: CloseSubStream;
+ fCustom: nil;
+ );
+{$ENDIF WIN_GDI}
+
+{$IFDEF DEBUG_MCK}
+procedure dummy_Log( const s: AnsiString );
+var mck_Log: procedure( const s: AnsiString ) = dummy_Log;
+{$ENDIF}
+
+type
+ TThemedElement = (
+ teButton,
+ teClock,
+ teComboBox,
+ teEdit,
+ teExplorerBar,
+ teHeader,
+ teListView,
+ teMenu,
+ tePage,
+ teProgress,
+ teRebar,
+ teScrollBar,
+ teSpin,
+ teStartPanel,
+ teStatus,
+ teTab,
+ teTaskBand,
+ teTaskBar,
+ teToolBar,
+ teToolTip,
+ teTrackBar,
+ teTrayNotify,
+ teTreeview,
+ teWindow
+ );
+
+var DrawThemeBackground: function(hTheme: DWORD; hdc: HDC; iPartId, iStateId: Integer;
+ const pRect: TRect; pClipRect: PRECT): HRESULT; stdcall;
+ OpenThemeData: function(hwnd: HWND; pszClassList: LPCWSTR): DWORD; stdcall;
+ ThemeLibrary: THandle;
+ IsThemeBackgroundPartiallyTransparent: function(hTheme: DWORD;
+ iPartId, iStateId: Integer): BOOL; stdcall;
+ DrawThemeParentBackground: function(hwnd: HWND; hdc: HDC; prc: PRECT): HRESULT; stdcall;
+ CloseThemeData: function(hTheme: DWORD): HRESULT; stdcall;
+ DrawThemeText: function(hTheme: DWORD; hdc: HDC; iPartId, iStateId: Integer;
+ pszText: LPCWSTR; iCharCount: Integer; dwTextFlags, dwTextFlags2: DWORD;
+ var pRect: TRect): HRESULT; stdcall;
+ IsThemeActive: function: BOOL; stdcall;
+ IsAppThemed: function: BOOL; stdcall;
+ GetThemeColor: function(hTheme: DWORD; iPartId, iStateId, iPropId: Integer;
+ var pColor: COLORREF): HRESULT; stdcall;
+
+const
+ themelib = 'uxtheme.dll';
+
+type
+ PThemedElementDetails = ^TThemedElementDetails;
+ TThemedElementDetails = record
+ Element: TThemedElement;
+ Part,
+ State: Integer;
+ end;
+ TThemedEdit = (
+ teEditDontCare,
+ teEditRoot,
+ teEditTextNormal, teEditTextHot, teEditTextSelected, teEditTextDisabled, teEditTextFocused, teEditTextReadOnly, teEditTextAssist,
+ teEditCaret
+ );
+
+type TOverrideScrollbarsProc = procedure(Sender: PControl);
+procedure DummyOverrideScrollbars(Sender: PControl);
+var OverrideScrollbars: TOverrideScrollbarsProc = DummyOverrideScrollbars;
+
+{$IFNDEF PAS_ONLY}
+function CrackStack_MapInResource( const MapName: KOLString; Max_length: Integer;
+ HandleSuspiciousAddresses: Boolean ): KOLString;
+{* Allows to list all procedures and functions called before current cracking
+ stack frames. This version loads map-file from the resource.
+ Important note: you must provide latest map file created at the last
+ application build in the resource! See also CrackStack_MapInFile below. }
+function CrackStack_MapInFile( const MapFileName: KOLString; Max_length: Integer;
+ HandleSuspiciousAddresses: Boolean ): KOLString;
+{* Allows to list all procedures and functions called before current cracking
+ stack frames. This version loads map-file from the file.
+ Important note: you must have the latest map file created at the last
+ application build on a path specified! For example, use path GetStartDir +
+ appname_wo_extention + '.map' and do not forget to set flag Map file -
+ Detailed in Project Options | Linker. Use flag HandleSuspiciousAddresses
+ to show all suspicious addresses found in stack (this may help to find
+ errors not shown even by Delphi debugger since stack frames in some cases give
+ no enough data). }
+{$ENDIF}
+//......... these declarations are here to stop hints from Delphi5 while compiling MCK:
+function CallTControlCreateWindow( Ctl: PControl ): Boolean;
+function DumpWindowed( c: PControl ): PControl;
+{$IFNDEF PAS_ONLY}
+function WndProcAppAsm( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+{$ENDIF}
+//22{$IFDEF ASM_VERSION}
+const ButtonClass: array[ 0..6 ] of KOLChar = ( 'B','U','T','T','O','N',#0 );
+//22{$ENDIF ASM_VERSION}
+{$IFDEF _D3orHigher}
+function WndProcUnicodeChars( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+{$ENDIF}
+procedure SetMouseEvent( Self_: PControl );
+function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
+function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
+procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD );
+function _GetDIBPixelsTrueColorAlpha( Bmp: PBitmap; X, Y: Integer ): TColor;
+procedure _SetDIBPixelsTrueColorAlpha( Bmp: PBitmap; X, Y: Integer; Value: TColor );
+//^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+{$IFDEF DEBUG_MONITOR_MESSAGES}
+var OnMonitorMessage: procedure( var M: TMsg; Enter_WndFunc: Boolean ) of object = nil;
+{$ENDIF}
+
+
+{$IFDEF _D2006orHigher}
+ {$I MCKfakeClasses200x.inc} // Dufa
+{$ENDIF}
+implementation
+
+ {$UNDEF CALL_INHERITED}
+{$IFDEF _D2orD3}
+ {$DEFINE CALL_INHERITED}
+{$ENDIF}
+{$IFnDEF NIL_EVENTS}
+ {$DEFINE CALL_INHERITED}
+{$ENDIF}
+
+{ -- don't remove this comment!!!
+ uses
+ //ShellAPI,
+ //commdlg // removing reference to commdlg decreases executable about 0.5 K
+ ; //, commctrl;
+ // in Delphi3, including of commctrl.pas increases executable
+ // onto about 30K. So, all needed definitions are copied here
+ // (see commctrl.inc).}
+
+{$IFDEF _X_}
+ {$undef uses_2}
+ {$IFNDEF NOT_USE_KOLMATH}
+ {$define uses_2}
+ {$ENDIF NOT_USE_KOLMATH}
+ {$IFDEF uses_2}
+ uses {$IFNDEF NOT_USE_KOLMATH} KOLmath
+ {$IFNDEF NOT_USE_EXCEPTION} , err
+ {$IFDEF REDECLARATION_INSERTED_AUTOMATICALLY}
+ , gdk2, pango, gtk2
+ {$ENDIF REDECLARATION_INSERTED_AUTOMATICALLY}
+ {$ENDIF NOT_USE_EXCEPTION}
+ {$ENDIF NOT_USE_KOLMATH};
+ {$ENDIF uses_2}
+{$ELSE}
+ {$IFDEF USE_GRUSH}
+ uses ToGRush;
+ {$ELSE}
+ {$IFDEF INPACKAGE}
+ uses mirror, SysUtils;
+ {$ENDIF INPACKAGE}
+ {$ENDIF USE_GRUSH}
+{$ENDIF _X_}
+
+{$IFDEF WIN}
+ {$IFNDEF FPC}
+ {$IFDEF UNICODE_CTRLS}
+ {$DEFINE implementation_part} {$I KOL_unicode.inc} {$UNDEF implementation_part}
+ {$ELSE} // ANSI_CTRLS
+ {$DEFINE implementation_part} {$I KOL_ansi.inc} {$UNDEF implementation_part}
+ {$ENDIF UNICODE_CTRLS}
+ {$ENDIF}
+{$ENDIF WIN}
+
+{$IFDEF DEBUG_MCK}
+procedure dummy_Log( const s: AnsiString );
+begin
+ //
+end;
+{$ENDIF}
+{$IFDEF WIN}
+type
+ PSHFileInfoA = ^TSHFileInfoA;
+ PSHFileInfoW = ^TSHFileInfoW;
+ PSHFileInfo = PSHFileInfoA;
+ _SHFILEINFOA = record
+ hIcon: HICON; { out: icon }
+ iIcon: Integer; { out: icon index }
+ dwAttributes: DWORD; { out: SFGAO_ flags }
+ szDisplayName: array [0..MAX_PATH-1] of AnsiChar; { out: display name (or path) }
+ szTypeName: array [0..79] of AnsiChar; { out: type name }
+ end;
+ _SHFILEINFOW = record
+ hIcon: HICON; { out: icon }
+ iIcon: Integer; { out: icon index }
+ dwAttributes: DWORD; { out: SFGAO_ flags }
+ szDisplayName: array [0..MAX_PATH-1] of WideChar; { out: display name (or path) }
+ szTypeName: array [0..79] of WideChar; { out: type name }
+ end;
+ _SHFILEINFO = {$IFDEF UNICODE_CTRLS} _SHFILEINFOW {$ELSE} _SHFILEINFOA {$ENDIF};
+ TSHFileInfoA = _SHFILEINFOA;
+ TSHFileInfoW = _SHFILEINFOW;
+ TSHFileInfo = {$IFDEF UNICODE_CTRLS} TSHFileInfoW {$ELSE} TSHFileInfoA {$ENDIF};
+ SHFILEINFOA = _SHFILEINFOA;
+ SHFILEINFOW = _SHFILEINFOW;
+ SHFILEINFO = {$IFDEF UNICODE_CTRLS} SHFILEINFOW {$ELSE} SHFILEINFOA {$ENDIF};
+
+const
+ SHGFI_ICON = $000000100; { get icon }
+ SHGFI_DISPLAYNAME = $000000200; { get display name }
+ SHGFI_TYPENAME = $000000400; { get type name }
+ SHGFI_ATTRIBUTES = $000000800; { get attributes }
+ SHGFI_ICONLOCATION = $000001000; { get icon location }
+ SHGFI_EXETYPE = $000002000; { return exe type }
+ SHGFI_SYSICONINDEX = $000004000; { get system icon index }
+ SHGFI_LINKOVERLAY = $000008000; { put a link overlay on icon }
+ SHGFI_SELECTED = $000010000; { show icon in selected state }
+ SHGFI_LARGEICON = $000000000; { get large icon }
+ SHGFI_SMALLICON = $000000001; { get small icon }
+ SHGFI_OPENICON = $000000002; { get open icon }
+ SHGFI_SHELLICONSIZE = $000000004; { get shell size icon }
+ SHGFI_PIDL = $000000008; { pszPath is a pidl }
+ SHGFI_USEFILEATTRIBUTES = $000000010; { use passed dwFileAttribute }
+
+function SHGetFileInfoA(pszPath: PAnsiChar; dwFileAttributes: DWORD;
+ var psfi: TSHFileInfo; cbFileInfo, uFlags: UINT): DWORD; stdcall;
+ external 'shell32.dll' name 'SHGetFileInfoA';
+{$IFDEF UNICODE_CTRLS}
+function SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD;
+ var psfi: TSHFileInfo; cbFileInfo, uFlags: UINT): DWORD; stdcall;
+ external 'shell32.dll' name 'SHGetFileInfoW';
+{$ENDIF UNICODE_CTRLS}
+
+type
+ FILEOP_FLAGS = Word;
+ PRINTEROP_FLAGS = Word;
+
+ PSHFileOpStructA = ^TSHFileOpStructA;
+ PSHFileOpStructW = ^TSHFileOpStructW;
+ PSHFileOpStruct = PSHFileOpStructA;
+ _SHFILEOPSTRUCTA = packed record
+ Wnd: HWND;
+ wFunc: UINT;
+ pFrom: PAnsiChar;
+ pTo: PAnsiChar;
+ fFlags: FILEOP_FLAGS;
+ fAnyOperationsAborted: BOOL;
+ hNameMappings: Pointer;
+ lpszProgressTitle: PAnsiChar; { only used if FOF_SIMPLEPROGRESS }
+ end;
+ _SHFILEOPSTRUCTW = packed record
+ Wnd: HWND;
+ wFunc: UINT;
+ pFrom: PWideChar;
+ pTo: PWideChar;
+ fFlags: FILEOP_FLAGS;
+ fAnyOperationsAborted: BOOL;
+ hNameMappings: Pointer;
+ lpszProgressTitle: PWideChar; { only used if FOF_SIMPLEPROGRESS }
+ end;
+ _SHFILEOPSTRUCT = _SHFILEOPSTRUCTA;
+ TSHFileOpStructA = _SHFILEOPSTRUCTA;
+ TSHFileOpStructW = _SHFILEOPSTRUCTW;
+ TSHFileOpStruct = TSHFileOpStructA;
+ SHFILEOPSTRUCTA = _SHFILEOPSTRUCTA;
+ SHFILEOPSTRUCTW = _SHFILEOPSTRUCTW;
+ SHFILEOPSTRUCT = SHFILEOPSTRUCTA;
+
+const
+ FO_MOVE = $0001;
+ FO_COPY = $0002;
+ FO_DELETE = $0003;
+ FO_RENAME = $0004;
+
+ FOF_MULTIDESTFILES = $0001;
+ FOF_CONFIRMMOUSE = $0002;
+ FOF_SILENT = $0004; { don't create progress/report }
+ FOF_RENAMEONCOLLISION = $0008;
+ FOF_NOCONFIRMATION = $0010; { Don't prompt the user. }
+ FOF_WANTMAPPINGHANDLE = $0020; { Fill in SHFILEOPSTRUCT.hNameMappings
+ Must be freed using SHFreeNameMappings }
+ FOF_ALLOWUNDO = $0040;
+ FOF_FILESONLY = $0080; { on *.*, do only files }
+ FOF_SIMPLEPROGRESS = $0100; { means don't show names of files }
+ FOF_NOCONFIRMMKDIR = $0200; { don't confirm making any needed dirs }
+ FOF_NOERRORUI = $0400; { don't put up error UI }
+
+
+{$IFDEF UNICODE_CTRLS}
+function SHFileOperationW(const lpFileOp: TSHFileOpStructW): Integer; stdcall;
+ external 'shell32.dll' name 'SHFileOperationW';
+{$ENDIF}
+
+function SHFileOperationA(const lpFileOp: TSHFileOpStructA): Integer; stdcall;
+ external 'shell32.dll' name 'SHFileOperationA';
+
+type
+ PNotifyIconDataA = ^TNotifyIconDataA;
+ PNotifyIconDataW = ^TNotifyIconDataW;
+ PNotifyIconData = PNotifyIconDataA;
+ _NOTIFYICONDATAA = record
+ cbSize: DWORD;
+ Wnd: HWND;
+ uID: UINT;
+ uFlags: UINT;
+ uCallbackMessage: UINT;
+ hIcon: HICON;
+ szTip: array [0..63] of AnsiChar;
+ end;
+ _NOTIFYICONDATAW = record
+ cbSize: DWORD;
+ Wnd: HWND;
+ uID: UINT;
+ uFlags: UINT;
+ uCallbackMessage: UINT;
+ hIcon: HICON;
+ szTip: array [0..63] of WideChar;
+ end;
+ _NOTIFYICONDATA = _NOTIFYICONDATAA;
+ TNotifyIconDataA = _NOTIFYICONDATAA;
+ TNotifyIconDataW = _NOTIFYICONDATAW;
+ TNotifyIconData = TNotifyIconDataA;
+ NOTIFYICONDATAA = _NOTIFYICONDATAA;
+ NOTIFYICONDATAW = _NOTIFYICONDATAW;
+ NOTIFYICONDATA = NOTIFYICONDATAA;
+
+const
+ NIM_ADD = $00000000;
+ NIM_MODIFY = $00000001;
+ NIM_DELETE = $00000002;
+
+ NIF_MESSAGE = $00000001;
+ NIF_ICON = $00000002;
+ NIF_TIP = $00000004;
+
+{$IFDEF UNICODE_CTRLS}
+function Shell_NotifyIcon(dwMessage: DWORD; lpData: PNotifyIconDataW): BOOL; stdcall;
+ external 'shell32.dll' name 'Shell_NotifyIconW';
+{$ELSE}
+function Shell_NotifyIcon(dwMessage: DWORD; lpData: PNotifyIconData): BOOL; stdcall;
+ external 'shell32.dll' name 'Shell_NotifyIconA';
+{$ENDIF UNICODE_CTRLS}
+
+{$IFDEF UNICODE_CTRLS}
+function ExtractIcon(hInst: HINST; lpszExeFileName: PKOLChar;
+ nIconIndex: UINT): HICON; stdcall;
+ external 'shell32.dll' name 'ExtractIconW';
+{$ELSE}
+function ExtractIcon(hInst: HINST; lpszExeFileName: PKOLChar;
+ nIconIndex: UINT): HICON; stdcall;
+ external 'shell32.dll' name 'ExtractIconA';
+{$ENDIF UNICODE_CTRLS}
+{$ENDIF WIN}
+{$IFDEF WIN_GDI}
+
+type
+ HDROP = Longint;
+
+function DragQueryPoint(Drop: HDROP; var Point: TPoint): BOOL; stdcall;
+ external 'shell32.dll' name 'DragQueryPoint';
+{$IFDEF UNICODE_CTRLS}
+function DragQueryFile(Drop: HDROP; FileIndex: UINT; FileName: PWideChar; cb: UINT): UINT; stdcall;
+ external 'shell32.dll' name 'DragQueryFileW';
+{$ELSE}
+function DragQueryFile(Drop: HDROP; FileIndex: UINT; FileName: PAnsiChar; cb: UINT): UINT; stdcall;
+ external 'shell32.dll' name 'DragQueryFileA';
+{$ENDIF UNICODE_CTRLS}
+procedure DragFinish(Drop: HDROP); stdcall;
+ external 'shell32.dll' name 'DragFinish';
+procedure DragAcceptFiles(Wnd: HWND; Accept: BOOL); stdcall;
+ external 'shell32.dll' name 'DragAcceptFiles';
+
+const
+ OFN_READONLY = $00000001;
+ OFN_OVERWRITEPROMPT = $00000002;
+ OFN_HIDEREADONLY = $00000004;
+ OFN_NOCHANGEDIR = $00000008;
+ OFN_SHOWHELP = $00000010;
+ OFN_ENABLEHOOK = $00000020;
+ OFN_ENABLETEMPLATE = $00000040;
+ OFN_ENABLETEMPLATEHANDLE = $00000080;
+ OFN_NOVALIDATE = $00000100;
+ OFN_ALLOWMULTISELECT = $00000200;
+ OFN_EXTENSIONDIFFERENT = $00000400;
+ OFN_PATHMUSTEXIST = $00000800;
+ OFN_FILEMUSTEXIST = $00001000;
+ OFN_CREATEPROMPT = $00002000;
+ OFN_SHAREAWARE = $00004000;
+ OFN_NOREADONLYRETURN = $00008000;
+ OFN_NOTESTFILECREATE = $00010000;
+ OFN_NONETWORKBUTTON = $00020000;
+ OFN_NOLONGNAMES = $00040000;
+ OFN_EXPLORER = $00080000;
+ OFN_NODEREFERENCELINKS = $00100000;
+ OFN_LONGNAMES = $00200000;
+ OFN_ENABLEINCLUDENOTIFY = $00400000;
+ OFN_ENABLESIZING = $00800000;
+ OFN_DONTADDTORECENT = $02000000;
+ OFN_FORCESHOWHIDDEN = $10000000; // Show All files including System and hidden files
+ OFN_EX_NOPLACESBAR = $00000001;
+ OFN_SHAREFALLTHROUGH = 2;
+ OFN_SHARENOWARN = 1;
+ OFN_SHAREWARN = 0;
+type
+ POpenFilename = ^TOpenFilename;
+ tagOFN = packed record
+ lStructSize: DWORD;
+ hWndOwner: HWND;
+ hInstance: HINST;
+ lpstrFilter: PKOLChar;
+ lpstrCustomFilter: PKOLChar;
+ nMaxCustFilter: DWORD;
+ nFilterIndex: DWORD;
+ lpstrFile: PKOLChar;
+ nMaxFile: DWORD;
+ lpstrFileTitle: PKOLChar;
+ nMaxFileTitle: DWORD;
+ lpstrInitialDir: PKOLChar;
+ lpstrTitle: PKOLChar;
+ Flags: DWORD;
+ nFileOffset: Word;
+ nFileExtension: Word;
+ lpstrDefExt: PKOLChar;
+ lCustData: LPARAM;
+ lpfnHook: function(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
+ lpTemplateName: PKOLChar;
+ {$IFDEF OpenSaveDialog_Extended}
+ //---------- added from Windows2000:
+ pvReserved: Pointer;
+ dwReserved: DWORD;
+ FlagsEx: DWORD;
+ {$ENDIF}
+ end;
+ TOpenFilename = tagOFN;
+ OPENFILENAME = tagOFN;
+{$IFDEF UNICODE_CTRLS}
+function GetOpenFileName(var OpenFile: TOpenFilename): Bool; stdcall;
+ external 'comdlg32.dll' name 'GetOpenFileNameW';
+function GetSaveFileName(var OpenFile: TOpenFilename): Bool; stdcall;
+ external 'comdlg32.dll' name 'GetSaveFileNameW';
+{$ELSE}
+function GetOpenFileName(var OpenFile: TOpenFilename): Bool; stdcall;
+ external 'comdlg32.dll' name 'GetOpenFileNameA';
+function GetSaveFileName(var OpenFile: TOpenFilename): Bool; stdcall;
+ external 'comdlg32.dll' name 'GetSaveFileNameA';
+{$ENDIF UNICODE_CTRLS}
+
+type
+ PChooseColorA = ^TChooseColorA;
+ PChooseColorW = ^TChooseColorW;
+ PChooseColor = PChooseColorA;
+ tagCHOOSECOLORA = packed record
+ lStructSize: DWORD;
+ hWndOwner: HWND;
+ hInstance: HWND;
+ rgbResult: COLORREF;
+ lpCustColors: ^COLORREF;
+ Flags: DWORD;
+ lCustData: LPARAM;
+ lpfnHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
+ lpTemplateName: PAnsiChar;
+ end;
+ tagCHOOSECOLORW = packed record
+ lStructSize: DWORD;
+ hWndOwner: HWND;
+ hInstance: HWND;
+ rgbResult: COLORREF;
+ lpCustColors: ^COLORREF;
+ Flags: DWORD;
+ lCustData: LPARAM;
+ lpfnHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
+ lpTemplateName: PWideChar;
+ end;
+ tagCHOOSECOLOR = tagCHOOSECOLORA;
+ TChooseColorA = tagCHOOSECOLORA;
+ TChooseColorW = tagCHOOSECOLORW;
+ TChooseColor = TChooseColorA;
+
+const
+ CC_RGBINIT = $00000001;
+ CC_FULLOPEN = $00000002;
+ CC_PREVENTFULLOPEN = $00000004;
+ CC_SHOWHELP = $00000008;
+ CC_ENABLEHOOK = $00000010;
+ CC_ENABLETEMPLATE = $00000020;
+ CC_ENABLETEMPLATEHANDLE = $00000040;
+ CC_SOLIDCOLOR = $00000080;
+ CC_ANYCOLOR = $00000100;
+
+function ChooseColor(var CC: TChooseColor): Bool; stdcall;
+ external 'comdlg32.dll' name 'ChooseColorA';
+
+{$IFDEF GDI}
+{$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}
+{$ENDIF GDI}
+
+{$ifdef _D2}
+procedure Assert( Cond: Boolean; const Msg: AnsiString );
+begin
+ if not Cond then
+ begin
+ AssertErrorProc( Msg, '', 0 );
+ asm
+ int 3;
+ end;
+ end;
+end;
+
+function CreateDIBSection(DC: HDC; const p2: TBitmapInfo; p3: UINT;
+ var p4: Pointer; p5: THandle; p6: DWORD): HBITMAP; stdcall;
+external gdi32 name 'CreateDIBSection';
+
+procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
+asm
+ { -> EAX pointer to dest }
+ { EDX source }
+ { ECX length }
+
+ PUSH EBX
+ PUSH ESI
+ PUSH EDI
+
+ MOV EBX,EAX
+ MOV ESI,EDX
+ MOV EDI,ECX
+
+ { allocate new string }
+
+ MOV EAX,EDI
+
+ CALL System.@NewAnsiString
+ MOV ECX,EDI
+ MOV EDI,EAX
+
+ TEST ESI,ESI
+ JE @@noMove
+
+ MOV EDX,EAX
+ MOV EAX,ESI
+ CALL Move
+
+ { assign the result to dest }
+
+@@noMove:
+ MOV EAX,EBX
+ CALL System.@LStrClr
+ MOV [EBX],EDI
+
+ POP EDI
+ POP ESI
+ POP EBX
+end;
+{$endif}
+
+{$IFDEF _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}
+
+procedure InitCommonControls; external cctrl name 'InitCommonControls';
+
+type
+ TInitCommonControlsEx = packed record
+ dwSize: DWORD;
+ dwICC: DWORD;
+ end;
+ PInitCommonControlsEx = ^TInitCommonControlsEx;
+
+var ComCtl32_Module: HModule;
+{$IFDEF ASM_UNICODE}
+{$ELSE PASCAL}
+procedure DoInitCommonControls( dwICC: DWORD );
+var Proc: procedure( ICC: PInitCommonControlsEx ); stdcall;
+ ICC: TInitCommonControlsEx;
+begin
+ InitCommonControls;
+ 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
+ ICC.dwSize := Sizeof( ICC );
+ ICC.dwICC := dwICC;
+ Proc( @ ICC );
+ end;
+end;
+{$ENDIF}
+
+const size_TRect = 16; // used often in assembler versions of code
+
+{$IFDEF ASM_VERSION}
+const
+ EmptyString: AnsiString = '';
+
+procedure EAX2PChar;
+asm
+ TEST EAX, EAX
+ JNZ @@exit
+ MOV EAX, offset[EmptyString]
+ //LEA EAX, [EmptyString]
+ //MOV EAX, [EmptyString]
+@@exit:
+end;
+
+procedure EDX2PChar;
+asm
+ TEST EDX, EDX
+ JNZ @@exit
+ MOV EDX, offset[EmptyString]
+@@exit:
+end;
+
+procedure ECX2PChar;
+asm
+ JECXZ @@convert
+ RET
+@@convert:
+ MOV ECX, offset[EmptyString]
+@@exit:
+end;
+
+procedure RemoveStr;
+asm { <- [ESP+4] = string to remove
+ -> ESP := ESP + 4
+ EAX = 0 }
+ POP EAX
+ XCHG EAX, [ESP]
+ PUSH EAX
+ MOV EAX, ESP
+ CALL System.@LStrClr
+ POP EAX
+end;
+
+{$IFDEF _D3orHigher}
+procedure RemoveWStr;
+asm { <- [ESP+4] = string to remove
+ -> ESP := ESP + 4
+ EAX = 0 }
+ POP EAX
+ XCHG EAX, [ESP]
+ PUSH EAX
+ MOV EAX, ESP
+ CALL System.@WStrClr
+ POP EAX
+end;
+{$ENDIF _D3orHigher}
+{$ENDIF ASM_VERSION}
+
+const PossibleColorBits : array[1..7] of Byte = ( 1, 4, 8, 16, 24, 32, 0 );
+
+function FindFilter( const Filter: KOLString): KOLString; forward;
+function WriteExMemoryStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; forward;
+procedure CreateComboboxWnd( Combo: PControl ); forward;
+procedure ComboboxDropDown( Sender: PObj ); forward;
+function WndProcParentResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; forward;
+function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; forward;
+function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward;
+function 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;
+ stdcall; forward;
+function OpenDirSelChangeCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ):
+ Integer; stdcall; forward;
+function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+function TimerProc( Wnd : HWnd; Msg : Integer; T : PTimer; CurrentTime : DWord ): Integer;
+ stdcall; forward;
+function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo; forward;
+procedure PreparePF16bit( DIBHeader: PBitmapInfo ); forward;
+procedure _RotateBitmapMono( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
+procedure _RotateBitmap4bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
+procedure _RotateBitmap8bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
+procedure _RotateBitmap16bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
+procedure _RotateBitmap2432bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
+procedure _RotateBitmapRight( SrcBmp: PBitmap ); forward;
+procedure _SetDIBPixels1bit( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward;
+procedure _SetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward;
+procedure _SetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward;
+procedure _SetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward;
+procedure FillBmpWithBkColor( Bmp: PBitmap; DC2: HDC; oldWidth, oldHeight: Integer ); forward;
+procedure DetachBitmapFromCanvas( Sender: PBitmap ); forward;
+function ColorBits( ColorsCount : Integer ) : Integer; forward;
+procedure AlignChildrenProc(Sender: PObj); forward;
+function WndProcUpdate( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+function CollectTabControls( Form: PControl ): PList; forward;
+{$IFNDEF NOT_USE_RICHEDIT}
+function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+{$ENDIF NOT_USE_RICHEDIT}
+function WndProc_DrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
+ : Boolean; forward;
+function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+ forward;
+function WndProcSplitter( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+ forward;
+function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
+ forward;
+procedure Tabulate2Next( Form: PControl; Dir: Integer ); forward;
+function Tabulate2Control( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
+ forward;
+function GetPrevCtrlBoundsRect( P: PControl; var R: TRect ): Boolean; forward;
+
+////////////---------------------------------------------------/////////////////
+function WndProcDateTimePickerNotify( Self_: PControl; var Msg: TMsg;
+ var Rslt: Integer ): Boolean; forward;
+
+////////////////////////////////////////////////////////////////////////////////
+{$IFNDEF PAS_ONLY}
+var MapFile: PKOLStrList;
+ LineNumbersFrom: Integer;
+ MaxCrackStackLen: Integer;
+ HandleSuspicious: Boolean;
+ BelowBasePtr: PDWORD;
+ CrackedStack: KOLString;
+
+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 := 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 (DWORD( BelowBasePtr ) < BasePtr) then
+ begin
+ BelowBasePtr := Pointer( DWORD( BelowBasePtr ) + 4 );
+ while DWORD( BelowBasePtr ) < BasePtr do
+ begin
+ A := BelowBasePtr^;
+ if (A > $400000) and (A < $700000) then
+ DoCrackSingleFrame( A, 0 );
+ BelowBasePtr := Pointer( DWORD( BelowBasePtr ) + 4 );
+ 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;
+asm
+ mov edx, ebp
+@@loop:
+ mov ecx, [edx]
+ mov eax, [edx+4]
+ mov edx, ecx
+ push edx
+ call DoCrackSingleFrame
+ pop edx
+ test al, al
+ jnz @@loop
+end;
+
+function CrackStack( Max_length: Integer; HandleSuspiciousAddresses: Boolean ): KOLString;
+begin
+ 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;
+ end;
+ end;
+end;
+
+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 );
+end;
+
+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 );
+end;
+{$ENDIF _no_PAS_ONLY}
+
+{$IFDEF GRAPHCTL_XPSTYLES}
+ {$I visual_xp_styles.inc}
+{$ENDIF}
+
+{$IFDEF SNAPMOUSE2DFLTBTN}
+var FoundMsgBoxWnd: HWnd;
+
+function EnumProcSnapMouse2DfltBtn( W: HWnd; lParam: Integer ): BOOL; stdcall;
+var ClassBuf: array[ 0..31 ] of KOLChar;
+begin
+ GetClassName( W, ClassBuf, Sizeof( ClassBuf ) div Sizeof( KOLChar ) );
+ Result := TRUE;
+ if ClassBuf = '#32770' then
+ begin
+ FoundMsgBoxWnd := W;
+ Result := FALSE;
+ end;
+end;
+
+function WndProcSnapMouse2DfltBtn( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean;
+var W: HWnd;
+ R: TRect;
+ P: TPoint;
+ SnapMouse: Integer;
+begin
+ SnapMouse := 0;
+ if SystemParametersInfo( {SPI_GETSNAPTODEFBUTTON}95, 0, @ SnapMouse, 0 ) then
+ if SnapMouse <> 0 then
+ begin
+ FoundMsgBoxWnd := 0;
+ EnumThreadWindows( GetCurrentThreadID, @ EnumProcSnapMouse2DfltBtn, 0 );
+ if FoundMsgBoxWnd <> 0 then
+ begin
+ W := GetWindow( FoundMsgBoxWnd, GW_CHILD );
+ while W <> 0 do
+ begin
+ if GetWindowLong( W, GWL_STYLE ) and BS_DEFPUSHBUTTON <> 0 then
+ begin
+ GetWindowRect( W, R );
+ P.X := (R.Left + R.Right) div 2;
+ P.Y := (R.Top + R.Bottom) div 2;
+ SetCursorPos( P.X, P.Y );
+ end;
+ W := GetWindow( W, GW_HWNDNEXT );
+ end;
+ Applet.DetachProc( @WndProcSnapMouse2DfltBtn );
+ end;
+ end;
+ Result := FALSE;
+end;
+{$ENDIF SNAPMOUSE2DFLTBTN}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+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
+ 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;
+{$ENDIF PAS_VERSION}
+
+procedure MsgOK( const S: KOLString );
+begin
+ MsgBox( S, MB_OK );
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PASCAL}
+function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD;
+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}
+ Wnd := Applet.Handle;
+ //{$ENDIF}
+ end;
+ Result := MessageBox( Wnd, PKOLChar( S ), Title, Flags );
+ {$IFDEF SNAPMOUSE2DFLTBTN}
+ {$IFDEF SAFE_CODE}
+ if Assigned( Applet ) then
+ {$ENDIF}
+ Applet.DetachProc( WndProcSnapMouse2DfltBtn );
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+procedure ShowMessage( const S: KOLString );
+begin
+ ShowMsg( S, MB_OK or MB_SETFOREGROUND or MB_DEFBUTTON1 );
+end;
+{$ENDIF GDI}
+
+{$IFDEF WIN_GDI}
+{$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 {$IFDEF F_P} [ 'EAX' ] {$ENDIF} ;
+ Sleep(Duration);
+ asm
+ in al,61H
+ and al,0fcH
+ out 61H,al
+ end {$IFDEF F_P} [ 'EAX' ] {$ENDIF} ;
+ end;
+end;
+{$ENDIF}
+{$ENDIF WIN_GDI}
+
+function SysErrorMessage(ErrorCode: Integer): KOLString;
+var
+ Len: Integer;
+ Buffer: array[0..255] of KOLChar;
+begin
+ Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
+ FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,
+ SizeOf(Buffer), nil);
+ while (Len > 0) and ({(Buffer[Len - 1] >= #0) and} (Buffer[Len - 1] <= ' ')) do Dec(Len);
+ SetString(Result, Buffer, Len);
+ //Result := Trim( Result );
+end;
+{$ENDIF WIN_GDI}
+
+function GetShiftState: DWORD;
+{$IFDEF WIN}
+const Buttons: array[0..6] of Byte = ( VK_SHIFT, VK_CONTROL, VK_MENU, VK_LBUTTON,
+ VK_RBUTTON, VK_MBUTTON, VK_CAPITAL );
+ Flags: array[0..6] of Byte = ( MK_SHIFT, MK_CONTROL, MK_ALT, MK_LBUTTON,
+ MK_RBUTTON, MK_MBUTTON, MK_LOCK );
+var i, mask: Integer;
+{$ENDIF WIN} //todo: for Linux / GTK ?
+begin
+ Result := 0;
+ {$IFDEF WIN}
+ mask := 1;
+ for i := High( Buttons ) downto 0 do
+ begin
+ if GetKeyState( Buttons[ i ] ) and mask <> 0 then
+ Result := Result or Flags[ i ];
+ mask := $8000;
+ end;
+ {$ENDIF WIN}
+end;
+
+function MakeMethod( Data, Code: Pointer ): TMethod;
+begin
+ Result.Data := Data;
+ Result.Code := Code;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function MakeRect( Left, Top, Right, Bottom: Integer ): TRect; stdcall;
+begin
+ Result.Left := Left;
+ Result.Top := Top;
+ Result.Right:= Right;
+ Result.Bottom := Bottom;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function RectsEqual( const R1, R2: TRect ): Boolean;
+begin
+ Result := CompareMem( @R1, @R2, Sizeof( TRect ) );
+end;
+{$ENDIF PAS_VERSION}
+
+function RectsIntersected( const R1, R2: TRect ): Boolean;
+begin
+ Result := ((R1.Left <= R2.Left) and (R1.Right > R2.Left ) or
+ (R1.Left <= R2.Right) and (R1.Right >= R2.Right) or
+ (R1.Left >= R2.Left) and (R1.Right <= R2.Right))
+ and
+ ((R1.Top <= R2.Top) and (R1.Bottom > R2.Top) or
+ (R1.Top <= R2.Bottom) and (R1.Bottom >= R2.Bottom) or
+ (R1.Top >= R2.Top) and (R1.Bottom <= R2.Bottom)) ;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function PointInRect( const P: TPoint; const R: TRect ): Boolean;
+begin
+ Result := (P.x >= R.Left) and (P.x < R.Right)
+ and (P.y >= R.Top) and (P.y < R.Bottom);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // Pascal
+function OffsetPoint( const T: TPoint; dX, dY: Integer ): TPoint;
+begin
+ Result := MakePoint( T.X + dX, T.Y + dY );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // Pascal
+function OffsetSmallPoint( const T: TSmallPoint; dX, dY: SmallInt ): TSmallPoint;
+begin
+ Result.x := T.x + dX;
+ Result.y := T.y + dY;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // Pascal
+function Point2SmallPoint( const T: TPoint ): TSmallPoint;
+begin
+ Result.x := T.X;
+ Result.y := T.Y;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function SmallPoint2Point( const T: TSmallPoint ): TPoint;
+begin
+ Result := MakePoint( T.x, T.y );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function MakePoint( X, Y: Integer ): TPoint;
+begin
+ Result.x := X;
+ Result.y := Y;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // Pascal
+function MakeSmallPoint( X, Y: Integer ): TSmallPoint;
+begin
+ Result.x := X;
+ Result.y := Y;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer;
+var I : Integer;
+ Mask : DWORD;
+begin
+ Result := 0;
+ Mask := FlgSet^;
+ for I := 0 to High( FlgArray ) do
+ begin
+ if (FlgArray[ I ] < 0) and not LongBool( Mask and 1 ) then
+ Result := Result or not FlgArray[ I ]
+ else
+ if (FlgArray[ I ] >= 0) and LongBool( Mask and 1 ) then
+ Result := Result or FlgArray[ I ];
+ Mask := Mask shr 1;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function MakeDateTimeRange( D1, D2: TDateTime ): TDateTimeRange;
+begin
+ Result.FromDate := D1;
+ Result.ToDate := D2;
+end;
+
+procedure Swap( var X, Y: Integer );
+{$IFDEF F_P}
+var Tmp: Integer;
+begin
+ Tmp := X;
+ X := Y;
+ Y := Tmp;
+end;
+{$ELSE DELPHI}
+asm
+ MOV ECX, [EDX]
+ XCHG ECX, [EAX]
+ MOV [EDX], ECX
+end;
+{$ENDIF F_P/DELPHI}
+
+function Min( X, Y: Integer ): Integer;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [X]
+ MOV EDX, [Y]
+ {$ENDIF F_P}
+ {$IFDEF USE_CMOV}
+ CMP EAX, EDX
+ CMOVG EAX, EDX
+ {$ELSE}
+ CMP EAX, EDX
+ JLE @@exit
+ MOV EAX, EDX
+@@exit:
+ {$ENDIF}
+end {$IFDEF F_P} [ 'EAX', 'EDX' ] {$ENDIF};
+
+function Max( X, Y: Integer ): Integer;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [X]
+ MOV EDX, [Y]
+ {$ENDIF F_P}
+ {$IFDEF USE_CMOV}
+ CMP EAX, EDX
+ CMOVL EAX, EDX
+ {$ELSE}
+ CMP EAX, EDX
+ JGE @@exit
+ MOV EAX, EDX
+@@exit:
+ {$ENDIF}
+end {$IFDEF F_P} [ 'EAX', 'EDX' ] {$ENDIF};
+
+{$IFDEF REDEFINE_ABS}
+function Abs( X: Integer ): Integer;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [X]
+ {$ENDIF F_P}
+ cdq
+ xor eax, edx
+ sub eax, edx
+end {$IFDEF F_P} [ 'EAX' ] {$ENDIF};
+{$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;
+
+function iSQRT( X: Integer ): Integer;
+{$IFDEF _D4orHigher}
+// new version is more efficient but code is not compatible with older compilers
+var I, N: Int64;
+begin
+ Result := 0;
+ while Result < X do
+ begin
+ I := 1;
+ while I > 0 do
+ begin
+ N := (Result + I) * (Result + I);
+ if N > X then
+ begin
+ I := I shr 1;
+ break;
+ end else
+ if N = X then
+ begin
+ Result := Result + I;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ I := I * 2;
+ end;
+ if I <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := Result + I;
+ end;
+end;
+{$ELSE _D3 or below or FPC1}
+var m, y, b: DWORD;
+begin
+ m := $40000000;
+ y := 0;
+ while m <> 0 do // 16 times
+ begin
+ b := y or m;
+ y := y shr 1;
+ if x >= b then
+ begin
+ x := x - b;
+ y := y or m;
+ end;
+ m := m shr 2;
+ end;
+ Result := y;
+end;
+{$ENDIF}
+
+function iCbrt( X: DWORD ): Integer;
+var s: Integer;
+ y, b: DWORD;
+begin
+ s := 30;
+ y := 0;
+ while s >= 0 do // 11 times
+ begin
+ y := 2 * y;
+ b := (3 * y * (y+1) + 1) shl s;
+ s := s - 3;
+ if x >= b then
+ begin
+ x := x - b;
+ y := y + 1;
+ end;
+ end;
+ Result := y;
+end;
+{$IFDEF WIN_GDI}
+
+{$IFDEF ASM_DC}
+procedure StartDC;
+asm
+ { <- EBX : PBitmap
+ -> EAX = dc
+ [ESP+8] = var dc
+ [ESP+4] = var SaveBmp
+ }
+ PUSH 0
+ CALL CreateCompatibleDC
+ POP EDX
+ PUSH EAX
+ PUSH EDX
+ MOV EAX, EBX
+ CALL [EBX].TBitmap.fDetachCanvas
+ MOV EAX, EBX
+ CALL TBitmap.GetHandle
+ PUSH EAX
+ PUSH dword ptr [ESP+8]
+ CALL SelectObject
+ POP EDX
+ PUSH EAX
+ PUSH EDX
+ MOV EAX, [ESP+8]
+end;
+
+procedure FinishDC;
+asm
+ POP ECX
+ POP EAX
+ POP EDX
+ PUSH ECX
+ PUSH EDX
+ PUSH EAX
+ PUSH EDX
+ CALL SelectObject
+ CALL DeleteDC
+end;
+{$ENDIF ASM_DC}
+
+function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+ forward;
+
+{$ENDIF WIN_GDI}
+
+procedure DummyObjProc( Sender: PObj );
+begin // 1-2-3 parameters, no result
+end;
+
+function DummyProc123_TRUE( Dummy: Pointer; Sender: PControl; param3: Integer ): Boolean;
+begin Result := TRUE; // 1-2-3 params, Result = TRUE
+end;
+
+function DummyProc123_0( Dummy: Pointer; Sender: PObj; param3: Integer ): Integer;
+begin Result := 0; // 1-2-3 params, Result = 0
+end;
+
+function DummyProc4_TRUE( Dummy: Pointer; Sender: PControl; p3, p4: Integer ): Boolean;
+begin Result := TRUE; // 4 params, result = TRUE
+end;
+
+function DummyProc5_TRUE( Dummy: Pointer; Sender: PControl; p3, p4, p5: Integer): Boolean;
+begin Result := TRUE; // 5 params, result = TRUE
+end;
+
+procedure DummyOnLVDataProc( Dummy: Pointer; Sender: PControl; Idx, SubItem: Integer;
+ var Txt: KOL_String; var ImgIdx: Integer; var State: DWORD;
+ var Store: Boolean );
+begin // 8 params
+end;
+
+function DummyProc4_0( Dummy: Pointer; Sender: PControl; p3, p4: Integer ): Integer;
+begin Result := 0; // 4 params, Result = 0
+end;
+
+function DummyOnDrawItemProc( Dummy:Pointer; Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer;
+ DrawAction: TDrawAction; ItemState: TDrawState ): Boolean;
+begin Result := FALSE; // 7 params, Result = FALSE
+end;
+
+function DummyOnLVCustomDrawProc( Dummy: Pointer; Sender: PControl; DC: HDC; Stage: DWORD;
+ ItemIdx, SubItemIdx: Integer; const Rect: TRect;
+ ItemState: TDrawState; var TextColor, BackColor: TColor ): DWORD;
+begin Result := 0; // 10 params, Result = 0
+end;
+
+function DummyOnSBBeforeScrollProc(Dummy: Pointer; Sender: PControl;
+ OldPos, NewPos: Integer; Cmd: Word; var AllowChange: Boolean): Boolean;
+begin Result := FALSE; // 6 params
+end;
+
+var DummyProcTable: array[ 0..11 ] of Pointer = ( @DummyObjProc, @DummyProc123_TRUE,
+ @DummyProc123_0, @DummyProc4_TRUE, @DummyProc5_TRUE, @DummyOnLVDataProc,
+ @DummyProc4_0, @DummyOnDrawItemProc, @DummyOnLVCustomDrawProc,
+ @DummyOnSBBeforeScrollProc, @WndFunc,
+ {$IFDEF USE_GRAPHCTLS} @InvalidateWindowed {$ELSE} @DummyObjProc {$ENDIF} );
+const idummy123 = 0; //+
+ idummy123_TRUE = 1; //+
+ idummy123_0 = 2; //+
+ idummy4_TRUE = 3; //+
+ idummy5_TRUE = 4; //+
+ idummy8 = 5; //+
+ idummy4_0 = 6; //+
+ idummy7 = 7; //+
+ idummy10 = 8; //+
+ idummy6 = 9; //+
+ iWndFunc = 10; //+
+ iInvalidateWindowed = 11; //+
+const InitEventsTable: array[ 0..idx_LastEvent ] of Byte = (
+ idummy123_0 + iWndFunc shl 4, //idx_fOnMessage + idx_fWndFunc = 0; idx_fWndFunc = 69;
+ idummy123_0 + iInvalidateWindowed shl 4, //idx_fOldOnMessage + idx_fDoInvalidate = 1; idx_fDoInvalidate = 70;
+ idummy123 + idummy123_0 shl 4, //idx_fOnClick = 2; idx_fOnDynHandlers = 71;
+ idummy123 + idummy123_0 shl 4, //idx_fOnMouseDown = 3; idx_fPass2DefProc = 72;
+ idummy123 + idummy123_0 shl 4, //idx_fOnMouseUp = 4; idx_fWndProcKeybd = 73;
+ idummy123 + idummy123_0 shl 4, //idx_fOnMouseMove = 5; idx_fControlClick = 74;
+ idummy123 + idummy123_0 shl 4, //idx_fOnMouseDblClk = 6; idx_fAutoSize = 75;
+ idummy123 + idummy123_0 shl 4, //idx_fOnMouseWheel = 7; idx_fGotoControl = 77;
+ idummy123 + idummy123_0 shl 4, //idx_fOnMouseEnter = 8; idx_fNotifyChild = 78;
+ idummy123 + idummy123_0 shl 4, //idx_fOnMouseLeave = 9; idx_fScrollChildren = 79;
+ idummy123_TRUE + idummy123_0 shl 4, //idx_fOnTestMouseOver = 10; idx_fCreateWndExt = 80;
+ idummy123 + idummy123_0 shl 4, //idx_fGraphCtlMouseEvent = 11; idx_fExMsgProc = 81;
+ idummy123, //idx_fMouseLeaveProc = 12;
+ idummy5_TRUE, //idx_fOnScroll = 13;
+ idummy4_TRUE, //idx_fOnChar = 14;
+ idummy4_TRUE, //idx_fOnDeadChar = 15;
+ idummy4_TRUE, //idx_fOnKeyUp = 16;
+ idummy4_TRUE, //idx_fOnKeyDown = 17;
+ idummy123, //idx_fOnChangeCtl = 18;
+ idummy123, //idx_fOnEnter = 19;
+ idummy123, //idx_fOnLeave = 20;
+ idummy123, //idx_fLeave = 21;
+ idummy123, //idx_fOnPaint = 22;
+ idummy123, //idx_fOnPaint2 = 23;
+ idummy123, //idx_fOnPrepaint = 24;
+ idummy123, //idx_fOnPostPaint = 25;
+ idummy123, //idx_fPaintProc = 26;
+ idummy123, //idx_fOnEraseBkgnd = 27;
+ idummy7, //idx_fOnDrawItem = 28;
+ idummy123_0, //idx_fOnMeasureItem = 29;
+ idummy6, //idx_fDragCallback = 30;
+ idummy123, //idx_fOnSelChange = 31;
+ idummy123, //idx_fOnResize = 32;
+ idummy123, //idx_fOnHide = 33;
+ idummy123, //idx_fOnShow = 34;
+ idummy123, //idx_fOnClose = 35;
+ idummy123, //idx_fOnMove = 36;
+ idummy123, //idx_fOnMoving = 37;
+ idummy4_0, //idx_fOnHelp = 38;
+ idummy123, //idx_fOnQueryEndSession = 39;
+ idummy123, //idx_fOnMinimize = 40;
+ idummy123, //idx_fOnMaximize = 41;
+ idummy123, //idx_fOnRestore = 42;
+ idummy10, //idx_fOnLVCustomDraw = 43;
+ idummy5_TRUE, //idx_fOnEndEditLVITem = 44;
+ idummy8, //idx_fOnLVData = 45;
+ idummy4_0, //idx_fOnCompareLVItems = 46;
+ idummy6, //idx_FOnLVStateChange = 47;
+ idummy123, //idx_fOnDeleteLVItem = 48;
+ idummy123, //idx_fOnColumnClick = 49;
+ idummy6, //idx_FOnSBBeforeScroll = 54;
+ idummy123, //idx_FOnSBScroll = 55;
+ idummy123, //idx_FOnDropDown = 56;
+ idummy123, //idx_FOnCloseUp = 57;
+ idummy4_TRUE, //idx_FOnSplit = 58;
+ idummy123, //idx_FOnProgress = 59;
+ idummy123_0, //idx_FOnBitBtnDraw = 60;
+ idummy123, //idx_FOnTVBeginDrag = 61;
+ idummy123_TRUE, //idx_FOnTVBeginEdit = 62;
+
+ idummy4_TRUE, //idx_FOnTVEndEdit = 50;
+ idummy4_0, //idx_FOnTVExpanding = 52;
+ idummy4_TRUE, //idx_FOnTVExpanded = 51;
+ idummy4_TRUE, //idx_FOnTVSelChanging = 53;
+
+ idummy123, //idx_FOnTVDelete = 63;
+ idummy5_TRUE, //idx_FOnDTPUserString = 64;
+ idummy123, //idx_FOnREInsModeChg = 65;
+ idummy123, //idx_FOnREOverURL = 66;
+ idummy123, //idx_FOnREURLClick = 67;
+ idummy4_0 //idx_fOnDropFiles = 68;
+ );
+
+{ _TObj }
+
+procedure Free_And_Nil( var Obj );
+var Obj1: PObj;
+begin
+ Obj1 := PObj( Obj );
+ Pointer( Obj ) := nil;
+ Obj1.Free;
+end;
+
+procedure _TObj.Init;
+begin
+{$IFDEF _D2orD3}
+ //FillChar( Pointer( Integer(@Self) + 4 )^, Sizeof( Self ) - 4, 0 );
+ ZeroMemory( Pointer( Integer(@Self) + 4 ), Sizeof( Self ) - 4 );
+{$ENDIF}
+end;
+
+function _TObj.VmtAddr: Pointer;
+asm
+ MOV EAX, [EAX]
+end;
+
+{ TObj }
+
+class function TObj.AncestorOfObject(Obj: Pointer): Boolean;
+asm
+ MOV ECX, [EAX]
+ MOV EAX, EDX
+ JMP @@loop1
+@@loop:
+ MOV EAX,[EAX]
+@@loop1:
+ TEST EAX,EAX
+ JE @@exit
+ CMP EAX,ECX
+ JNE @@loop
+@@success:
+ MOV AL,1
+@@exit:
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+constructor TObj.Create;
+begin
+ Init;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF OLD_REFCOUNT}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TObj.DoDestroy;
+begin
+ {$IFDEF OLD_REFCOUNT}
+ if fRefCount > 0 then
+ begin
+ if not LongBool( fRefCount and 1) then
+ Dec( fRefCount, 2 );
+ RefDec;
+ end else
+ Self.Destroy;
+ if fRefCount <> 0 then
+ begin
+ if not LongBool( fRefCount and 1) then
+ Dec( fRefCount );
+ end else
+ Self.Destroy;
+ {$ELSE}
+ if fRefCount > 0 then
+ RefDec
+ else Self.Destroy;
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF OLD_REFCOUNT}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TObj.RefDec: Integer;
+begin
+ Result := 0; // stop Delphi alerting the Warning
+ if @ Self = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Dec( fRefCount, 2 );
+ {$IFDEF OLD_REFCOUNT}
+ if (fRefCount < 0) and LongBool(fRefCount and 1) then
+ Destroy;
+ {$ELSE}
+ if fRefCount < 0 then
+ Destroy;
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TObj.RefInc;
+begin
+ Inc( fRefCount, 2 );
+end;
+
+function TObj.VmtAddr: Pointer;
+asm
+ //MOV EAX, [EAX - 4]
+ MOV EAX, [EAX]
+end;
+
+function TObj.InstanceSize: Integer;
+asm
+ //MOV EAX, [EAX]
+ MOV EAX, [EAX-4]
+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}
+{$IFDEF ASM_DEBUG} {$DEFINE ASM_LOCAL} {$ENDIF}
+
+{$IFDEF ASM_LOCAL}
+{$ELSE PAS_VERSION} //Pascal
+destructor TObj.Destroy;
+begin
+ Final;
+
+ {$IFDEF DEBUG_ENDSESSION}
+ if EndSession_Initiated then
+ LogFileOutput( GetStartDir + 'es_debug.txt',
+ 'FINALLED: ' + Int2Hex( DWORD( @ Self ), 8 )
+ {$IFDEF USE_NAMES}
+ + ' (name:' + FName + ')'
+ {$ENDIF}
+ );
+ {$ENDIF}
+ {$IFDEF USE_NAMES}
+ fName := '';
+ if fNamedObjList <> nil then
+ Free_And_Nil(fNamedObjList);
+ {$ENDIF}
+ {$IFDEF CRASH_DEBUG}
+ FillChar( Pointer( Integer(@Self) + 4 )^, Sizeof( Self ) - 4, #$DD );
+ {$ENDIF}
+ FreeMem( @ Self );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}
+ {$DEFINE ASM_TLIST}
+{$IFDEF TLIST_FAST}
+ {$UNDEF ASM_TLIST}
+{$ENDIF}
+{$ENDIF}
+
+{$IFDEF ASM_TLIST}
+procedure TObj.Final;
+asm //cmd //opd
+ PUSH EBX
+ XCHG EBX, EAX
+ XOR ECX, ECX
+ XCHG ECX, [EBX].fOnDestroy.TMethod.Code
+ JECXZ @@freeloop
+ MOV EDX, EBX
+ MOV EAX, [EDX].fOnDestroy.TMethod.Data
+ CALL ECX
+@@freeloop:
+ MOV ECX, [EBX].fAutoFree
+ JECXZ @@eloop
+ MOV EDX, [ECX].TList.fItems
+ MOV ECX, [ECX].TList.fCount
+ JECXZ @@eloop
+ MOV EAX, [EDX+ECX*4-4]
+ MOV EDX, [EDX+ECX*4-8]
+ PUSH EAX
+ PUSH EDX
+ MOV EAX, [EBX].fAutoFree
+ LEA EDX, [ECX-2]
+ XOR ECX, ECX
+ MOV CL, 2
+ CALL TList.DeleteRange
+ POP EDX
+ POP EAX
+ CALL EDX
+ JMP @@freeloop
+@@eloop:
+ XOR EAX, EAX
+ XCHG [EBX].fAutoFree, EAX
+ CALL TObj.RefDec
+@@exit:
+ POP EBX
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure TObj.Final;
+var N: Integer;
+ ProcMethod: TMethod;
+ {$IFDEF _D2orD3}
+ Proc: TObjectMethod;
+ {$ELSE}
+ Proc: TObjectMethod Absolute ProcMethod;
+ {$ENDIF}
+var Destroy_evnt: TOnEvent;
+begin
+ if Assigned( fOnDestroy ) then
+ begin
+ Destroy_evnt := fOnDestroy;
+ fOnDestroy := nil;
+ Destroy_evnt( @Self );
+ end;
+ while (fAutoFree <> nil) and (fAutoFree.fCount > 0) do
+ begin
+ N := fAutoFree.fCount - 2;
+ ProcMethod.Code := fAutoFree.Items[ N ];
+ ProcMethod.Data := fAutoFree.Items[ N + 1 ];
+ fAutoFree.DeleteRange( N, 2 );
+ {$IFDEF _D2orD3}
+ Proc := TObjectMethod( ProcMethod );
+ {$ENDIF}
+ Proc;
+ end;
+ fAutoFree.Free;
+ fAutoFree := nil;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TObj.Add2AutoFree(Obj: PObj);
+begin
+ if fAutoFree = nil then
+ fAutoFree := NewList;
+ fAutoFree.Insert( 0, Obj );
+ fAutoFree.Insert( 0, Pointer( @TObj.RefDec ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TObj.Add2AutoFreeEx( Proc: TObjectMethod );
+{$IFDEF F_P}
+var Ptr1, Ptr2: Pointer;
+{$ENDIF F_P}
+begin
+ if fAutoFree = nil then
+ fAutoFree := NewList;
+ {$IFDEF F_P}
+ asm
+ MOV EAX, [Proc]
+ MOV [Ptr1], EAX
+ MOV EAX, [Proc+4]
+ MOV [Ptr2], EAX
+ end [ 'EAX' ];
+ fAutoFree.Insert( 0, Ptr2 );
+ fAutoFree.Insert( 0, Ptr1 );
+ {$ELSE DELPHI}
+ fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Data ) );
+ fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Code ) );
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+procedure TObj.RemoveFromAutoFree(Obj: PObj);
+var i: Integer;
+begin
+ if fAutoFree <> nil then
+ begin
+ i := fAutoFree.IndexOf( Obj );
+ if i >= 0 then
+ begin
+ fAutoFree.DeleteRange( i and not 1, 2 );
+ if fAutoFree.Count = 0 then
+ Free_And_Nil( fAutoFree );
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TObj.RemoveFromAutoFreeEx(Proc: TObjectMethod);
+var i: Integer;
+begin
+ if fAutoFree <> nil then
+ begin
+ for i := 0 to fAutoFree.Count-2 do
+ if (fAutoFree.Items[ i ] = TMethod( Proc ).Data) and
+ (fAutoFree.Items[ i+1 ] = TMethod( Proc ).Code) then
+ begin
+ fAutoFree.Delete( i );
+ fAutoFree.Delete( i );
+ break;
+ end;
+ end;
+end;
+
+{$IFDEF USE_NAMES}
+procedure TObj.SetName( NewOwnerObj: PObj; NewName: AnsiString );
+{$IFDEF UNIQUE_NAMES}
+var i: Integer;
+{$ENDIF}
+begin
+ if (FOwnerObj <> nil) then
+ if FOwnerObj <> NewOwnerObj then
+ begin
+ FOwnerObj.fNamedObjList.Remove( @ Self );
+ end;
+ FOwnerObj := NewOwnerObj;
+ if NewOwnerObj = nil then
+ begin
+ if NewName = '' then
+ begin
+ fName := '';
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ // здесь тот случай, когда в приложении без Applet'а устанавливается
+ // имя для главной формы (наверное)
+ FOwnerObj := @ Self; // владельцем списка именованных объектов становится
+ // сам объект. Для вышеозначенного случая - главная форма держит себя и
+ // другие формы.
+ end;
+ if FOwnerObj.fNamedObjList = nil then
+ FOwnerObj.fNamedObjList := NewList;
+ {$IFDEF UNIQUE_NAMES}
+ for i := 0 to FOwnerObj.fNamedObjList.Count-1 do
+ begin
+ if PObj( FOwnerObj.fNamedObjList.Items[ i ] ).FName = NewName then
+ begin
+ NewName := '';
+ break;
+ end;
+ end;
+ {$ENDIF}
+ FName := NewName;
+ if FName = '' then
+ FOwnerObj.fNamedObjList.Remove( @ Self )
+ else if FOwnerObj.fNamedObjList.IndexOf( @ Self ) < 0 then
+ FOwnerObj.fNamedObjList.Add( @ Self );
+end;
+
+function TObj.FindObj(const ObjName: Ansistring): PObj;
+var i: Integer;
+ Obj: PObj;
+begin
+ if fNamedObjList <> nil then
+ for i := 0 to fNamedObjList.Count-1 do
+ begin
+ Obj := fNamedObjList.Items[ i ];
+ if ObjName = Obj.FName then
+ begin
+ Result := Obj; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ Result := nil;
+end;
+{$ENDIF}
+
+{ TList }
+
+{$IFDEF USE_CONSTRUCTORS}
+procedure TList.Init;
+begin
+ {$IFDEF CALL_INHERITED}
+ inherited;
+ {$ENDIF}
+ fAddBy := 4;
+ {$IFDEF TLIST_FAST}
+ {$IFNDEF DFLT_TLIST_NOUSE_BLOCKS} // for debug only
+ fUseBlocks := TRUE;
+ {$ENDIF}
+ {$ENDIF}
+end;
+
+function NewList: PList;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ fObjKind := 'TList';
+ {$ENDIF}
+end;
+
+{$ELSE not_USE_CONSTRUCTORS}
+function NewList: PList;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TList';
+ {$ENDIF}
+ Result.fAddBy := 4;
+ {$IFDEF TLIST_FAST}
+ {$IFNDEF DFLT_TLIST_NOUSE_BLOCKS} // for debug only
+ Result.fUseBlocks := TRUE;
+ {$ENDIF}
+ {$ENDIF}
+end;
+{$ENDIF USE_CONSTRUCTORS}
+
+{$IFDEF _D4orHigher}
+function NewListInit( const AItems: array of Pointer ): PList;
+var i: Integer;
+begin
+ Result := NewList;
+ Result.Capacity := Length( AItems );
+ for i := 0 to High( AItems ) do
+ Result.Add( AItems[ i ] );
+end;
+{$ENDIF}
+
+{$IFNDEF PAS_ONLY}
+procedure HelpFastIncNum2Els( DataArray: Pointer; Value, Count: Integer );
+asm
+ PUSH ESI
+ PUSH EDI
+ {$IFDEF F_P}
+ MOV ESI, [DataArray]
+ MOV EDX, [Value]
+ MOV ECX, [Count]
+ {$ELSE DELPHI}
+ MOV ESI, EAX
+ {$ENDIF F_P/DELPHI}
+ MOV EDI, ESI
+ CLD
+
+@@1:
+ LODSD
+ ADD EAX, EDX
+ STOSD
+ LOOP @@1
+
+ POP EDI
+ POP ESI
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+
+{$IFNDEF TLIST_FAST}
+procedure FastIncNum2Elements( List: TList; FromIdx, Count, Value: Integer );
+begin
+ HelpFastIncNum2Els( @List.fItems[ FromIdx ], Value, Count );
+end;
+{$ENDIF}
+{$ENDIF PAS_ONLY}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TList.Destroy;
+begin
+ Clear;
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+procedure TList.Release;
+asm
+ TEST EAX, EAX
+ JZ @@e
+ MOV ECX, [EAX].fCount
+ JECXZ @@e
+ MOV EDX, [EAX].fItems
+ PUSH EAX
+@@1:
+ MOV EAX, [EDX+ECX*4-4]
+ TEST EAX, EAX
+ JZ @@2
+ PUSH EDX
+ PUSH ECX
+ CALL System.@FreeMem
+ POP ECX
+ POP EDX
+@@2: LOOP @@1
+ POP EAX
+@@e: CALL TObj.RefDec
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure TList.Release;
+var I: Integer;
+begin
+ if @ Self = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ for I := 0 to fCount - 1 do
+ if {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ] <> nil then
+ FreeMem( {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ] );
+ Free;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TList.ReleaseObjects;
+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;
+
+{$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 // Capacitity в обычном смысле работает только для первого
+ 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;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TList.Clear;
+{$IFDEF TLIST_FAST}
+var i: Integer;
+{$ENDIF}
+begin
+ if fItems <> nil then
+ FreeMem( fItems );
+ fItems := nil;
+ fCount := 0;
+ fCapacity := 0;
+ {$IFDEF TLIST_FAST}
+ if fBlockList <> nil then
+ 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;
+{$ENDIF PAS_VERSION}
+
+procedure TList.SetAddBy(Value: Integer);
+begin
+ if Value < 1 then Value := 1;
+ fAddBy := Value;
+end;
+
+{$IFDEF ASM_NO_VERSION} /// ASM-version disabled due some problems - 20-May-2010
+{$ELSE PAS_VERSION} //Pascal
+procedure TList.Add( Value: Pointer );
+{$IFDEF TLIST_FAST}
+var LastBlockCount: Integer;
+ LastBlockStart: Pointer;
+{$ENDIF}
+begin
+ {$IFDEF TLIST_FAST}
+ if fUseBlocks and ((fCount >= 256) or ( fBlockList <> nil )) then
+ begin
+ if fBlockList = nil then
+ begin
+ fBlockList := NewList;
+ fBlockList.fUseBlocks := FALSE;
+ fBlockList.Add( fItems );
+ fBlockList.Add( Pointer( fCount ) );
+ fItems := nil;
+ end;
+ if fBlockList.fCount = 0 then
+ begin
+ fBlockList.Add( nil );
+ fBlockList.Add( nil );
+ LastBlockCount := 0;
+ end else
+ begin
+ LastBlockCount := Integer( fBlockList.Items[ fBlockList.fCount-1 ] );
+ if LastBlockCount >= 256 then
+ begin
+ fBlockList.Add( nil );
+ fBlockList.Add( nil );
+ LastBlockCount := 0;
+ end;
+ end;
+ LastBlockStart := fBlockList.Items[ fBlockList.fCount-2 ];
+ if LastBlockStart = nil then
+ begin
+ GetMem( LastBlockStart, 256 * Sizeof( Pointer ) );
+ fBlockList.Items[ fBlockList.fCount-2 ] := LastBlockStart;
+ end;
+ fBlockList.Items[ fBlockList.fCount-1 ] := Pointer( LastBlockCount+1 );
+ PDWORD( Integer(LastBlockStart) + Sizeof(Pointer)*LastBlockCount )^ :=
+ DWORD( Value );
+ end else
+ {$ENDIF}
+ begin
+ if fCapacity <= fCount then
+ begin
+ if fAddBy <= 0 then
+ Capacity := fCount + Min( 1000, fCount div 4 + 1 )
+ else Capacity := fCount + fAddBy;
+ end;
+ fItems[ fCount ] := Value;
+ end;
+ Inc( fCount );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF _D4orHigher}
+procedure TList.AddItems(const AItems: array of Pointer);
+var i: Integer;
+begin
+ Capacity := Count + Length( AItems );
+ for i := 0 to High( AItems ) do
+ Add( AItems[ i ] );
+end;
+{$ENDIF}
+
+procedure TList.Delete( Idx: Integer );
+begin
+ DeleteRange( Idx, 1 );
+end;
+
+{$IFDEF ASM_TLIST}
+procedure TList.DeleteRange(Idx, Len: Integer);
+asm //cmd //opd
+ TEST ECX, ECX
+ JLE @@exit
+ CMP EDX, [EAX].fCount
+ JGE @@exit
+ PUSH EBX
+ XCHG EBX, EAX
+ LEA EAX, [EDX+ECX]
+ CMP EAX, [EBX].fCount
+ JBE @@1
+ MOV ECX, [EBX].fCount
+ SUB ECX, EDX
+@@1:
+ MOV EAX, [EBX].fItems
+ PUSH [EBX].fCount
+ SUB [EBX].fCount, ECX
+ MOV EBX, EDX
+ LEA EDX, [EAX+EDX*4]
+ LEA EAX, [EDX+ECX*4]
+ ADD EBX, ECX
+ POP ECX
+ SUB ECX, EBX
+ SHL ECX, 2
+ CALL System.Move
+ POP EBX
+@@exit:
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure TList.DeleteRange(Idx, Len: Integer);
+{$IFDEF TLIST_FAST}
+var i, DelFromBlock: Integer;
+ CountBefore, CountCurrent: Integer;
+ BlockStart: Pointer;
+{$ENDIF}
+begin
+ if Len <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Idx >= Count then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( (Idx >= 0), 'TList.DeleteRange: index out of bounds' );
+ {$ENDIF KOL_ASSERTIONS}
+ if DWORD( Idx + Len ) > DWORD( Count ) then
+ Len := Count - Idx;
+ {$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 (Idx >= CountBefore) and (Idx < CountBefore + CountCurrent) then
+ begin
+ DelFromBlock := CountBefore + CountCurrent - Idx;
+ if DelFromBlock > Len then
+ DelFromBlock := Len;
+ if DelFromBlock < CountCurrent then
+ begin
+ fNotOptimized := TRUE;
+ move( Pointer( Integer( BlockStart ) + (Idx - CountBefore + DelFromBlock) * Sizeof( Pointer ) )^,
+ Pointer( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^,
+ (CountCurrent - (Idx - CountBefore) - DelFromBlock) * Sizeof( Pointer ) );
+ dec( CountCurrent, DelFromBlock );
+ fBlockList.fItems[ i * 2 + 1 ] := Pointer( CountCurrent );
+ dec( fCount, DelFromBlock );
+ dec( Len, DelFromBlock );
+ if Len <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end else
+ begin // delete entire block
+ //++ fix added: 21.06.08 ++ VK
+ fLastKnownBlockIdx := 0;
+ fLastKnownCountBefore := 0;
+ //++++++++++++++++++++++++++++
+ FreeMem( BlockStart );
+ fBlockList.DeleteRange( i * 2, 2 );
+ dec( fCount, CountCurrent );
+ dec( Len, CountCurrent );
+ if Len <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ CountCurrent := 0;
+ dec( i );
+ end;
+ end;
+ inc( i );
+ inc( CountBefore, CountCurrent );
+ end;
+ end else
+ {$ENDIF}
+ begin
+ Move( fItems[ Idx + Len ], fItems[ Idx ], Sizeof( Pointer ) * (Count - Idx - Len) );
+ Dec( fCount, Len );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TList.Remove(Value: Pointer);
+var I: Integer;
+begin
+ I := IndexOf( Value );
+ if I >= 0 then
+ Delete( I );
+end;
+
+function TList.ItemAddress(Idx: Integer): Pointer;
+{$IFDEF TLIST_FAST}
+var i: Integer;
+ BlockStart: Pointer;
+ CountBefore, CountCurrent: Integer;
+{$ENDIF}
+begin
+ {$IFDEF TLIST_FAST}
+ if fUseBlocks and ( fBlockList <> nil ) then
+ begin
+ CountBefore := 0;
+ i := 0;
+ if (fLastKnownBlockIdx > 0) and
+ (Idx >= fLastKnownCountBefore) then
+ begin
+ CountBefore := fLastKnownCountBefore;
+ i := fLastKnownBlockIdx;
+ end;
+ CountCurrent := CountBefore + Integer( fBlockList.fItems[ i*2+1 ] );
+ if Idx - CountCurrent > fCount - CountCurrent then
+ begin // поиск в обратном направлении может оказаться быстрее
+ CountBefore := fCount;
+ i := fBlockList.fCount div 2 - 1;
+ while TRUE do
+ begin
+ BlockStart := fBlockList.fItems[ i * 2 ];
+ CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
+ if (CountBefore - CountCurrent <= Idx) and (Idx < CountBefore) then
+ begin
+ Result := Pointer( Integer( BlockStart ) +
+ (Idx - (CountBefore - CountCurrent))*Sizeof( Pointer ) );
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ dec( CountBefore, CountCurrent );
+ dec( i );
+ end;
+ end;
+ while TRUE { i < fBlockList.Count div 2 } do
+ begin
+ BlockStart := fBlockList.fItems[ i * 2 ];
+ CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
+ if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then
+ begin
+ Result := Pointer( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) );
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ inc( CountBefore, CountCurrent );
+ inc( i );
+ end;
+ end else
+ {$ENDIF}
+ Result := Pointer( Integer( 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 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if 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;
+ PDWORD( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^ :=
+ DWORD( Value );
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ inc( CountBefore, CountCurrent );
+ inc( i );
+ end;
+ end else
+ {$ENDIF}
+ fItems[ Idx ] := Value;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+function TList.Get( Idx: Integer ): Pointer;
+{$IFDEF TLIST_FAST}
+var i: Integer;
+ BlockStart: Pointer;
+ CountBefore, CountCurrent: Integer;
+{$ENDIF}
+begin
+ Result := nil;
+ if Idx < 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Idx >= fCount then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF TLIST_FAST}
+ if fUseBlocks and ( fBlockList <> nil ) 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( PDWORD( Integer( 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( PDWORD( Integer( 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
+ PUSH EDI
+
+ MOV EDI, [EAX].fItems
+ MOV ECX, [EAX].fCount
+ PUSH EDI
+ DEC EAX // make "NZ" - EAX always <> 1
+ 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
+ SAR EAX, 2
+
+ POP EDI
+end;
+{$ELSE PAS_VERSION} //Pascal
+function TList.IndexOf( Value: Pointer ): Integer;
+var I: Integer;
+ {$IFDEF TLIST_FAST}
+ BlockStart: PDWORD;
+ j: Integer;
+ CountBefore, CountCurrent: Integer;
+ {$ENDIF}
+begin
+ Result := -1;
+ {$IFDEF DEBUG_ANY}
+ TRY
+ {$ENDIF}
+ {$IFDEF TLIST_FAST}
+ if fUseBlocks and ( fBlockList <> nil ) then
+ begin
+ CountBefore := 0;
+ for I := 0 to fBlockList.fCount div 2 - 1 do
+ begin
+ BlockStart := fBlockList.fItems[ I * 2 ];
+ CountCurrent := Integer( fBlockList.fItems[ I * 2 + 1 ] );
+ for j := 0 to CountCurrent-1 do
+ begin
+ if BlockStart^ = DWORD( Value ) then
+ begin
+ Result := CountBefore + j; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ inc( BlockStart );
+ end;
+ inc( CountBefore, CountCurrent );
+ end;
+ end else
+ {$ENDIF}
+ begin
+ for I := 0 to fCount - 1 do
+ begin
+ if fItems[ I ] = Value then
+ begin
+ Result := I;
+ break;
+ end;
+ end;
+ end;
+ {$IFDEF DEBUG_ANY}
+ EXCEPT
+ END;
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+procedure TList.Insert(Idx: Integer; Value: Pointer);
+asm
+ PUSH ECX
+ PUSH EAX
+ PUSH [EAX].fCount
+ PUSH EDX
+ CALL TList.Add // don't matter what to add
+ POP EDX // EDX = Idx, Eax = Count-1
+ POP EAX
+ SUB EAX, EDX
+
+ SAL EAX, 2
+ MOV ECX, EAX // ECX = (Count - Idx - 1) * 4
+ POP EAX
+ MOV EAX, [EAX].fItems
+ LEA EAX, [EAX + EDX*4]
+ JL @@1
+ PUSH EAX
+ LEA EDX, [EAX + 4]
+ CALL System.Move
+
+ POP EAX // EAX = @fItems[ Idx ]
+@@1:
+ POP ECX // ECX = Value
+ MOV [EAX], ECX
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure TList.Insert(Idx: Integer; Value: Pointer);
+{$IFDEF TLIST_FAST}
+var i: Integer;
+ CountBefore, CountCurrent: Integer;
+ BlockStart, NewBlock: Pointer;
+{$ENDIF}
+begin
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( (Idx >= 0) and (Idx <= FCount+1), 'List index out of bounds' );
+ {$ENDIF KOL_ASSERTIONS}
+ {$IFDEF TLIST_FAST}
+ if fUseBlocks and (( fBlockList <> nil ) or (fCount >= 256)) then
+ begin
+ if ( fBlockList = nil ) then
+ begin
+ fBlockList := NewList;
+ fBlockList.fUseBlocks := FALSE;
+ fBlockList.Add( fItems );
+ fBlockList.Add( Pointer( fCount ) );
+ fItems := nil;
+ end;
+ if fBlockList.fCount = 0 then
+ begin
+ fNotOptimized := FALSE;
+ GetMem( NewBlock, 256 * Sizeof( Pointer ) );
+ fBlockList.Add( NewBlock );
+ fBlockList.Add( nil );
+ end;
+ CountBefore := 0;
+ i := 0;
+ if (fLastKnownBlockIdx > 0) and
+ (Idx >= fLastKnownCountBefore) then
+ begin
+ i := fLastKnownBlockIdx;
+ CountBefore := fLastKnownCountBefore;
+ end;
+ while TRUE {i < fBlockList.fCount div 2} do
+ begin
+ CountCurrent := Integer( fBlockList.Items[ i * 2 + 1 ] );
+ if (Idx >= CountBefore) and
+ ((Idx < CountBefore + CountCurrent) or
+ (Idx = CountBefore + CountCurrent) and
+ (CountCurrent < 256)) then // insert in block i
+ begin
+ BlockStart := fBlockList.fItems[ i * 2 ];
+ if BlockStart = nil then
+ begin
+ GetMem( BlockStart, 256 * Sizeof( Pointer ) );
+ fBlockList.fItems[ i * 2 ] := BlockStart;
+ end;
+ Idx := Idx - CountBefore;
+ if CountCurrent < 256 then
+ begin
+ if Idx < CountCurrent then
+ Move( Pointer( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^,
+ Pointer( Integer( BlockStart ) + (Idx+1) * Sizeof( Pointer ) )^,
+ (CountCurrent - Idx) * Sizeof( Pointer ) );
+ PDWORD( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^ :=
+ DWORD( Value );
+ fBlockList.fItems[ i * 2 + 1 ] := Pointer( CountCurrent + 1 );
+ end else // new block is created since current block is full 256 items
+ begin
+ fNotOptimized := TRUE;
+ GetMem( NewBlock, 256 * Sizeof( Pointer ) );
+ fBlockList.Insert( (i+1)*2, Pointer( 256-Idx ) );
+ fBlockList.Insert( (i+1)*2, NewBlock );
+ move( Pointer( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^,
+ NewBlock^, (256 - Idx) * Sizeof( Pointer ) );
+ PDWORD( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^ :=
+ DWORD( Value );
+ fBlockList.fItems[ i * 2 + 1 ] := Pointer( Idx + 1 );
+ end;
+ fLastKnownBlockIdx := i;
+ fLastKnownCountBefore := CountBefore;
+ inc( fCount );
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ inc( CountBefore, CountCurrent );
+ inc( i );
+ if i >= fBlockList.fCount div 2 then
+ begin
+ fBlockList.Add( nil );
+ fBlockList.Add( nil );
+ end;
+ end;
+ end else
+ {$ENDIF}
+ begin
+ Add( nil );
+ if fCount > Idx then
+ Move( FItems[ Idx ], FItems[ Idx + 1 ], (fCount - Idx - 1) * Sizeof( Pointer ) );
+ FItems[ Idx ] := Value;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION} {$DEFINE MoveItem_ASM} {$ENDIF}
+{$IFDEF TLIST_FAST} {$UNDEF MoveItem_ASM} {$ENDIF}
+
+{$IFDEF MoveItem_ASM}
+{$ELSE PAS_VERSION} //Pascal
+procedure TList.MoveItem(OldIdx, NewIdx: Integer);
+var Item: Pointer;
+begin
+ if OldIdx = NewIdx then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if NewIdx >= Count then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Item := Items[ OldIdx ];
+ Delete( OldIdx );
+ Insert( NewIdx, Item );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+function TList.Last: Pointer;
+asm //cmd //opd
+ MOV ECX, [EAX].fCount
+ JECXZ @@0
+ MOV EAX, [EAX].fItems
+ DEC ECX
+ MOV ECX, [EAX + ECX*4]
+@@0: XCHG EAX, ECX
+end;
+{$ELSE PAS_VERSION} //Pascal
+function TList.Last: Pointer;
+begin
+ if Count = 0 then
+ Result := nil
+ else Result := Items[ Count-1 ];
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+procedure TList.Swap(Idx1, Idx2: Integer);
+asm
+ MOV EAX, [EAX].fItems
+ PUSH dword ptr [EAX + EDX*4]
+ PUSH ECX
+ MOV ECX, [EAX + ECX*4]
+ MOV [EAX + EDX*4], ECX
+ POP ECX
+ POP EDX
+ MOV [EAX + ECX*4], EDX
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure TList.Swap(Idx1, Idx2: Integer);
+var Tmp: DWORD;
+ AItem1, AItem2: PDWORD;
+begin
+ {$IFDEF TLIST_FAST}
+ AItem1 := ItemAddress( Idx1 );
+ AItem2 := ItemAddress( Idx2 );
+ {$ELSE}
+ AItem1 := Pointer( Integer( fItems ) + Idx1 * Sizeof( Pointer ) );
+ AItem2 := Pointer( Integer( fItems ) + Idx2 * Sizeof( Pointer ) );
+ {$ENDIF}
+ Tmp := AItem1^;
+ AItem1^ := AItem2^;
+ AItem2^ := Tmp;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TList.SetCount(const Value: Integer);
+begin
+ if Value >= Count then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fCount := Value;
+end;
+
+procedure TList.Assign(SrcList: PList);
+{$IFDEF TLIST_FAST}
+var i, CountCurrent: Integer;
+ SrcBlock, DstBlock: Pointer;
+{$ENDIF}
+begin
+ Clear;
+ if SrcList.fCount > 0 then
+ begin
+ {$IFDEF TLIST_FAST}
+ if SrcList.fUseBlocks and ( SrcList.fBlockList <> nil ) then
+ begin
+ fBlockList := NewList;
+ fBlockList.Assign( SrcList.fBlockList );
+ for i := 0 to fBlockList.Count div 2 - 1 do
+ begin
+ SrcBlock := SrcList.fBlockList.fItems[ i*2 ];
+ CountCurrent := Integer( fBlockList.fItems[ i*2+1 ] );
+ GetMem( DstBlock, 256 * Sizeof( Pointer ) );
+ fBlockList.fItems[ i*2 ] := DstBlock;
+ move( SrcBlock^, DstBlock^, CountCurrent );
+ end;
+ end else
+ {$ENDIF}
+ begin
+ Capacity := SrcList.fCount;
+ Move( SrcList.FItems[ 0 ], FItems[ 0 ], Sizeof( Pointer ) * SrcList.fCount );
+ end;
+ end;
+ fCount := SrcList.fCount;
+end;
+
+{$IFDEF WIN_GDI}
+
+{$UNDEF ASM_LOCAL}
+{$IFDEF ASM_noVERSION}
+ {$IFNDEF _D2orD3}
+ {$DEFINE ASM_LOCAL}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF ASM_LOCAL} //!!//!!
+function CallCtlWndProc( Ctl: PControl; var Msg: TMsg ): Integer;
+begin
+ Result := Ctl.WndProc( Msg );
+end;
+
+{ -- Window procedure -- }
+function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
+ : Integer; 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 SetWindowLong
+ {$ENDIF}
+
+ XOR EAX, EAX
+ MOV [CreatingWindow], EAX
+ POP EAX // EAX = self_
+ JMP @@self_got
+
+@@get_self_prop:
+ {$IFDEF USE_PROP}
+ PUSH Offset[ID_SELF]
+ PUSH EAX
+ CALL GetProp
+ {$ELSE}
+ PUSH GWL_USERDATA
+ PUSH EAX
+ CALL GetWindowLong
+ {$ENDIF}
+ TEST EAX, EAX
+ JNZ @@self_got
+
+@@self_is_nil:
+ OR EAX, [ Applet ]
+ JNZ @@self_got
+
+ POP EDI
+ POP ESI
+ MOV ESP, EBP
+ POP EBP
+ JMP DefWindowProc
+
+@@self_got:
+ MOV ESI, EAX
+ INC 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, lParam: Integer )
+ : Integer; stdcall;
+var M: TMsg;
+ self_: PControl;
+begin
+ {$IFDEF INPACKAGE}
+ Log( '->WndFunc ' + Int2Hex( Msg, 4 ) + ' (' + Int2Str( Msg ) + ')' );
+ TRY
+ {$ENDIF INPACKAGE}
+
+ M.hwnd := W;
+ M.message := Msg;
+ M.wParam := wParam;
+ M.lParam := lParam;
+
+ {$IFDEF DEBUG_MONITOR_MESSAGES}
+ if Assigned( OnMonitorMessage ) then
+ OnMonitorMessage( M, TRUE );
+ {$ENDIF}
+
+ {$IFDEF DEBUG_ENDSESSION}
+ if EndSession_Initiated then
+ begin
+ LogFileOutput( GetStartDir + 'es_debug.txt',
+ 'HWND:' + Int2Str( W ) + ' MSG:$' + Int2Hex( Msg, 4 ) +
+ ' WParam: ' + Int2Str( wParam ) + '($' + Int2Hex( wParam, 8 ) + ')' +
+ ' LParam: ' + Int2Str( lParam ) + '($' + Int2Hex( lParam, 8 ) + ')' );
+ end;
+ {$ENDIF}
+
+ self_ := nil;
+ if W <> 0 then
+ begin
+ if CreatingWindow <> nil then
+ begin
+ {$IFDEF INPACKAGE}
+ Log( '//// CreatingWindow <> nil' );
+ {$ENDIF INPACKAGE}
+ {$IFDEF DEBUG_CREATEWINDOW}
+ LogFileOutput( GetStartDir + 'Session.log',
+ 'WndFunc: Creating window = ' + Int2Hex( Integer( CreatingWindow ), 4 ) +
+ ' hwnd=' + Int2Str( M.hwnd ) +
+ ' message=' + Int2Hex( M.message, 4 ) +
+ ' wParam=' + Int2Str( M.wParam ) + '=$' + Int2Hex( M.wParam, 4 ) +
+ ' lParam=' + Int2Str( M.lParam ) + '=$' + Int2Hex( M.lParam, 4 )
+ );
+ {$ENDIF DEBUG_CREATEWINDOW}
+ self_ := CreatingWindow;
+ CreatingWindow.fHandle := W;
+ {$IFDEF USE_PROP}
+ {$IFDEF INPACKAGE}
+ Log( '//// SetProp' );
+ {$ENDIF INPACKAGE}
+ SetProp( W, ID_SELF, THandle( CreatingWindow ) );
+ {$ELSE}
+ SetWindowLong( W, GWL_USERDATA, Integer( CreatingWindow ) );
+ {$ENDIF}
+ CreatingWindow := nil;
+ end else
+ {$IFDEF USE_PROP}
+ self_ := Pointer( GetProp( W, ID_SELF ) );
+ {$ELSE}
+ self_ := Pointer( GetWindowLong( W, GWL_USERDATA ) );
+ {$ENDIF}
+ end;
+
+ if self_ <> nil then
+ begin
+ {$IFDEF INPACKAGE}
+ Log( '//// self_ <> nil, calling self_.WndProc' );
+ {$ENDIF INPACKAGE}
+ //self_.RefInc;
+ //TRY
+ Result := self_.WndProc( M );
+ //FINALLY
+ // self_.RefDec;
+ //END;
+ end else
+ if Applet <> nil then
+ Result := Applet.WndProc( M )
+ else Result := DefWindowProc( W, Msg, wParam, lParam );
+ {$IFDEF DEBUG_ENDSESSION}
+ if EndSession_Initiated then
+ begin
+ LogFileOutput( GetStartDir + 'es_debug.txt',
+ 'HWND:' + Int2Str( W ) + ' MSG:$' + Int2Hex( Msg, 4 ) +
+ ' Result: ' + Int2Str( Result ) + '($' + Int2Hex( Result, 8 ) + ')' );
+ end;
+ {$ENDIF}
+ {$IFDEF INPACKAGE}
+ LogOK;
+ FINALLY
+ Log( '<-WndFunc' );
+ END;
+ {$ENDIF INPACKAGE}
+ {$IFDEF DEBUG_MONITOR_MESSAGES}
+ if Assigned( OnMonitorMessage ) then
+ OnMonitorMessage( M, FALSE );
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TList.OptimizeForRead;
+{$IFDEF TLIST_FAST}
+var i, j, N: Integer;
+ NewBlocksList: PList;
+ BlockStart: PPointer;
+{$ENDIF}
+begin
+ {$IFDEF TLIST_FAST}
+ if fNotOptimized and fUseBlocks then
+ begin
+ NewBlocksList := NewList;
+ NewBlocksList.UseBlocks := FALSE;
+ i := 0;
+ while i < Count do
+ begin
+ N := 256;
+ if N > Count-i then
+ N := Count-i;
+ GetMem( BlockStart, 256 * Sizeof(Pointer) );
+ NewBlocksList.Add( BlockStart );
+ NewBlocksList.Add( Pointer(N) );
+ for j := i to i+N-1 do
+ begin
+ BlockStart^ := Items[j];
+ inc( BlockStart );
+ end;
+ inc( i, 256 );
+ end;
+ N := Count;
+ Clear;
+ Free_And_Nil( fBlockList );
+ fBlockList := NewBlocksList;
+ fCount := N;
+ fNotOptimized := FALSE;
+ end;
+ {$ENDIF}
+end;
+
+var
+ IdleHandlers: PList;
+ ProcessIdle: procedure ( Sender: PObj ) = DummyObjProc;
+
+procedure ProcessIdleProc( Sender: PObj );
+var
+ i: integer;
+ m: TMethod;
+begin
+ if AppletTerminated then exit; // YS + >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+ i := 0;
+ with IdleHandlers^ do
+ while i < Count do begin
+ m.Code:=Items[i];
+ Inc(i);
+ m.Data:=Items[i];
+ Inc(i);
+ TOnEvent(m)(Sender);
+ end;
+end;
+
+function FindIdleHandler( const OnIdle: TOnEvent ): integer;
+var
+ i: integer;
+begin
+ i := 0;
+ if not AppletTerminated then //+ {Maxim Pushkar}
+ with TMethod(OnIdle), IdleHandlers^ do
+ while i < Count do begin
+ if (Items[i] = Code) and (Items[i + 1] = Data) then
+ begin
+ Result := i;
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Inc(i, 2);
+ end;
+ Result := -1;
+end;
+
+procedure RegisterIdleHandler( const OnIdle: TOnEvent );
+begin
+ if IdleHandlers = nil then begin
+ IdleHandlers := NewList;
+ if Applet <> nil then
+ Applet.Add2AutoFree(IdleHandlers);
+ end;
+ with TMethod(OnIdle) do
+ begin
+ IdleHandlers.Add(Code);
+ IdleHandlers.Add(Data);
+ end;
+ ProcessIdle := @ProcessIdleProc;
+end;
+
+procedure UnRegisterIdleHandler( const OnIdle: TOnEvent );
+var
+ i: integer;
+begin
+ i := FindIdleHandler(OnIdle);
+ if i <> -1 then
+ with IdleHandlers^ do
+ begin
+ Delete(i);
+ Delete(i);
+ end;
+end;
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+procedure TerminateExecution( var AppletCtl: PControl );
+var App: PControl;
+ Appalreadyterminated: Boolean;
+begin
+ Appalreadyterminated := AppletTerminated;
+ AppletTerminated := TRUE;
+ AppletRunning := FALSE;
+ App := Applet;
+ Applet := nil;
+ if (App <> nil) {and (App.RefCount >= 0)} then
+ begin
+ App.RefInc;
+ if not Appalreadyterminated then
+ begin
+ App.ProcessMessages;
+ App.Perform( WM_CLOSE, 0, 0 );
+ end;
+ AppletCtl := nil;
+ App.Free;
+ App.RefDec;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+//22{$IFDEF ASM_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;
+//22{$ENDIF}
+{$ENDIF GDI}
+{$ENDIF WIN_GDI}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure Run( var AppletCtl: PControl );
+ {$IFDEF PSEUDO_THREADS}
+var n: Integer;
+ i: Integer;
+ T: PThread;
+ u: DWORD;
+ M: TMsg;
+ {$ENDIF}
+begin
+ if AppletCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ AppletRunning := True;
+ Applet := AppletCtl;
+ AppletCtl.CreateWindow; //virtual!!!
+ //Applet_Wnd := AppletCtl.Handle;
+ while not AppletTerminated do
+ begin
+ {$IFDEF PSEUDO_THREADS}
+ if MainThread <> nil then
+ begin
+ while not PeekMessage( M, 0, 0, 0, pm_noremove ) do
+ begin
+ u := GetTickCount;
+ n := 0;
+ for i := 1 to MainThread.AllThreads.Count-1 do
+ begin
+ T := MainThread.AllThreads.Items[ i ];
+ if not T.Suspended and not T.Terminated and (T.DoNotWakeUntil < u) then
+ begin
+ inc( n );
+ break;
+ end;
+ end;
+ if n = 0 then WaitMessage
+ else MainThread.NextThread;
+ end;
+ end else
+ WaitMessage;
+ {$ELSE}
+ WaitMessage;
+ {$ENDIF}
+ AppletCtl.ProcessMessages;
+ {$IFDEF USE_OnIdle}
+ ProcessIdle( AppletCtl );
+ {$ENDIF}
+ end;
+ if Assigned( AppletCtl ) then
+ TerminateExecution( AppletCtl );
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+ PROCEDURE Run( var AppletWnd: PControl );
+ BEGIN
+ AppletRunning := True;
+ Applet := AppletWnd;
+ AppletWnd.VisualizyWindow; // for GTK, show all windows having Visible = TRUE, recursively
+ gtk_main( );
+ IF AppletWnd <> nil THEN
+ //TerminateExecution( AppletWnd );
+ Free_And_Nil( AppletWnd );
+ END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+{$IFDEF GDI}
+procedure AppletMinimize;
+begin
+ if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Applet.Perform( WM_SYSCOMMAND, SC_MINIMIZE, 0 );
+end;
+
+procedure AppletHide;
+begin
+ if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ AppletMinimize;
+ Applet.Hide;
+end;
+
+procedure AppletRestore;
+begin
+ if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Applet.Show;
+ Applet.Perform( WM_SYSCOMMAND, SC_RESTORE, 0 );
+end;
+
+function ScreenWidth: Integer;
+begin
+ Result := GetSystemMetrics( SM_CXSCREEN );
+end;
+
+function ScreenHeight: Integer;
+begin
+ Result := GetSystemMetrics( SM_CYSCREEN );
+end;
+{$ENDIF GDI}
+
+//22{$IFDEF ASM_VERSION}
+//function WndProcAppAsm( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+//22{$ENDIF}
+function WndProcAppPas( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+function WndProcForm( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+function WndProcGradientEx( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+function WndProcLabelEffect( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
+var fGlobalProcKeybd: function( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean =
+ WndProcDummy;
+
+{ -- Graphics support -- }
+
+{$ENDIF WIN_GDI}
+function _NewGraphicTool: PGraphicTool;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TGraphicTool';
+ {$ENDIF}
+end;
+{$IFDEF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION PAS_VERSION}
+function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush;
+{$IFDEF STORE_fTmpBrushColorRGB}{$ELSE}
+var tmpRGBColor: TColor;
+{$ENDIF}
+begin
+ if (Sender.fParent <> nil) and (Sender.fColor = Sender.fParent.fColor) then
+ Result := SimpleGetCtlBrushHandle( Sender.fParent )
+ else
+ begin
+ {$IFDEF GDI}
+ {$IFDEF STORE_fTmpBrushColorRGB}
+ if (Sender.fTmpBrush <> 0) and
+ (Color2RGB( Sender.fColor ) <> Sender.fTmpBrushColorRGB) then
+ begin
+ DeleteObject( Sender.fTmpBrush );
+ Sender.fTmpBrush := 0;
+ end;
+ {$ENDIF}
+ if Sender.fTmpBrush = 0 then
+ begin
+ {$IFDEF STORE_fTmpBrushColorRGB}
+ Sender.fTmpBrushColorRGB := Color2RGB( Sender.fColor );
+ Sender.fTmpBrush := CreateSolidBrush( Sender.fTmpBrushColorRGB );
+ {$ELSE}
+ tmpRGBColor := Color2RGB( Sender.fColor );
+ Sender.fTmpBrush := CreateSolidBrush( tmpRGBColor );
+ {$ENDIF}
+ end;
+ Result := Sender.fTmpBrush;
+ {$ELSE} Result := 0;
+ {$ENDIF GDI}
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE notASM_VERSION}
+function NormalGetCtlBrushHandle( Sender: PControl ): HBrush;
+var B: PGraphicTool;
+ //P: PControl;
+begin
+ {$IFDEF GDI}
+ B := Sender.Brush;
+ //P := Sender.fParent;
+ //if P <> nil then
+ if Sender.fParent <> nil then
+ B.fParentGDITool := Sender.fParent.Brush; //P.Brush;
+ Result := B.Handle;
+ {$ELSE} Result := 0;
+ {$ENDIF GDI}
+end;
+{$ENDIF PAS_VERSION}
+
+function MakeFontHandle( Self_: PGraphicTool ): THandle; forward;
+function MakeBrushHandle( Self_: PGraphicTool ): THandle; forward;
+function MakePenHandle( Self_: PGraphicTool ): THandle; forward;
+function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle; forward;
+
+{$ENDIF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewBrush: PGraphicTool;
+begin
+ {$IFDEF GDI}
+ Global_GetCtlBrushHandle := NormalGetCtlBrushHandle;
+ {$ENDIF GDI}
+ Result := _NewGraphicTool;
+ with Result^ do
+ begin
+ fNewProc := @ NewBrush;
+ fType := gttBrush;
+ {$IFDEF GDI}
+ fMakeHandleProc := @ MakeBrushHandle;
+ {$ENDIF GDI}
+ Result.fData.Color := clBtnFace;
+ Result.fData.Brush.Style := bsSolid;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewPen: PGraphicTool;
+begin
+ Result := _NewGraphicTool;
+ with Result^ do
+ begin
+ fNewProc := @ NewPen;
+ fType := gttPen;
+ {$IFDEF GDI}
+ fMakeHandleProc := @ MakePenHandle;
+ {$ENDIF GDI}
+ fData.Pen.Mode := pmCopy;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+var ApplyFont2Wnd_Proc: procedure( _Self: PObj ) = DummyObjProc;
+procedure DoApplyFont2Wnd( _Self: PControl ); forward;
+
+const size_FontData = sizeof( Integer {fFontHeight} ) + sizeof( Integer {fFontWidth} ) +
+ sizeof( TFontPitch ) + sizeof( TFontStyle ) +
+ sizeof( Integer {fFontOrientation} ) +
+ sizeof( Integer {fFontWeight} ) + sizeof( TFontCharset ) +
+ sizeof( TFontQuality );
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewFont: PGraphicTool;
+begin
+ ApplyFont2Wnd_Proc := @ DoApplyFont2Wnd;
+ Result := _NewGraphicTool;
+ with Result^ do
+ begin
+ fNewProc := @ NewFont;
+ fType := gttFont;
+ {$IFDEF GDI}
+ fMakeHandleProc := @ MakeFontHandle;
+ fData.Color := DefFontColor;
+ Move( DefFont, fData.Font, Sizeof( TGDIFont ) );
+ {$ENDIF GDI}
+ {$IFDEF GTK}
+ fData.Font.Weight := 400;
+ {$ENDIF GTK}
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+function Color2RGB( Color: TColor ): TColor;
+begin
+ if Color < 0 then
+ Result := GetSysColor(Color and $7F)
+ else Result := Color;
+end;
+{$ENDIF PAS_VERSION}
+
+function RGB2BGR( Color: TColor ): TColor;
+begin
+ Result := ((Color shr 16) or (Color shl 16) or Color and $00FF00)
+ and $FFFFFF;
+end;
+
+function ColorsMix( Color1, Color2: TColor ): TColor;
+{$IFDEF F_P}
+begin
+ Result := ((Color2RGB( Color1 ) and $FEFEFE) shr 1) +
+ ((Color2RGB( Color2 ) and $FEFEFE) shr 1);
+end;
+{$ELSE DELPHI}
+asm
+ //PUSH EDX
+ CALL Color2Rgb
+ //POP EDX
+ XCHG EAX, EDX
+ //PUSH EDX
+ CALL Color2Rgb
+ //POP EDX
+ MOV ECX, $0FEFEFE
+ AND EAX, ECX
+ AND EDX, ECX
+ ADD EAX, EDX
+ ROR EAX, 1
+end;
+{$ENDIF F_P/DELPHI}
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function Color2RGBQuad( Color: TColor ): TRGBQuad;
+var C: Integer;
+begin
+ C := Color2RGB( Color );
+ C := ((C shr 16) and $FF)
+ or ((C shl 16) and $FF0000)
+ or (C and $FF00);
+ Result := TRGBQuad( C );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+function Color2Color16( Color: TColor ): WORD;
+begin
+ Color := Color2RGB( Color );
+ Result := (Color shr 19) and $1F or
+ (Color shr 5) and $7E0 or
+ (Color shl 8) and $F800;
+end;
+{$ENDIF PAS_VERSION}
+
+function Color2Color15( Color: TColor ): WORD;
+begin
+ Color := Color2RGB( Color );
+ Result := (Color shr 19) and $1F or
+ (Color shr 6) and $3E0 or
+ (Color shl 7) and $7C00;
+end;
+
+{$ENDIF WIN_GDI}
+{ TGraphicTool }
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+function TGraphicTool.Assign(Value: PGraphicTool): PGraphicTool;
+var _Self: PGraphicTool;
+begin
+ Result := nil;
+ if Value = nil then
+ begin
+ {$IFDEF OLD_REFCOUNT}
+ if @Self <> nil then
+ DoDestroy;
+ {$ELSE}
+ Free;
+ {$ENDIF}
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ _Self := @Self;
+ if _Self = nil then
+ _Self := Value.fNewProc();
+ Result := _Self;
+ if _Self = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ // to avoid infinite loop when assigning to itself
+ {$IFDEF GDI}
+ if _Self.fHandle <> 0 then
+ if Value.fHandle = _Self.fHandle then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$ENDIF GDI}
+ _Self.Changed; // to destroy handle if allocated and release it from the canvas (if any uses it)
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( Value.fType = _Self.fType, 'Attempt to assign to different GDI tool type' );
+ {$ENDIF KOL_ASSERTIONS}
+ Move( Value.fData, _Self.fData, Sizeof( fData ) );
+ _Self.Changed; // to inform owner control, that its tool (font, brush) changed
+end;
+{$ENDIF PAS_VERSION}
+{$IFDEF WIN_GDI}
+
+procedure TGraphicTool.AssignHandle(NewHandle: THANDLE);
+begin
+ if fHandle <> 0 then //
+ DeleteObject( fHandle ); //
+ fHandle := NewHandle;
+ GetObject( fHandle, Sizeof( TGDIFont ), @ fData.Font );
+ Changed;
+end;
+
+{$ENDIF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TGraphicTool.Changed;
+{$IFDEF GDI} var H: THandle; {$ENDIF GDI}
+begin
+ {$IFDEF GDI}
+ H := 0;
+ if fHandle <> 0 then
+ begin
+ H := fHandle;
+ fHandle := 0;
+ end;
+ ////////////////////////////////
+ if Assigned( TMethod( fOnGTChange ).Data ) then
+ fOnGTChange( @Self );
+ ////////////////////////////////
+ if H <> 0 then
+ begin
+ DeleteObject( H );
+ {$IFDEF DEBUG_GDIOBJECTS}
+ case fType of
+ gttBrush: Dec( BrushCount );
+ gttFont: Dec( FontCount );
+ gttPen: Dec( PenCount );
+ end;
+ {$ENDIF}
+ end;
+ {$ENDIF GDI}
+ {$IFDEF GTK}
+ IF Assigned( fPangoFontDesc ) THEN
+ BEGIN
+ pango_font_description_free( fPangoFontDesc );
+ fPangoFontDesc := nil;
+ END;
+ /////////////////////////////////
+ IF Assigned( fOnGTChange ) THEN
+ /////////////////////////////////
+ fOnGTChange( @Self );
+ {$ENDIF GTK}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TGraphicTool.Destroy;
+begin
+ {$IFDEF GDI}
+ case fType of
+ gttBrush: if fData.Brush.Bitmap <> 0 then
+ DeleteObject( fData.Brush.Bitmap );
+ gttPen: if fData.Pen.BrushBitmap <> 0 then
+ DeleteObject( fData.Pen.BrushBitmap )
+ end;
+ if fHandle <> 0 then
+ begin
+ DeleteObject( fHandle );
+ {$IFDEF DEBUG_GDIOBJECTS}
+ case fType of
+ gttPen: Dec( PenCount );
+ gttBrush: Dec( BrushCount );
+ gttFont: Dec( FontCount );
+ end;
+ {$ENDIF}
+ //fHandle := 0; Why to do this? It is now destroying!
+ end;
+ {$ENDIF GDI}
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF WIN_GDI}
+function TGraphicTool.HandleAllocated: Boolean;
+begin
+ Result := fHandle <> 0;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION PAS_VERSION}
+function TGraphicTool.ReleaseHandle: THANDLE;
+begin
+ Changed;
+ Result := fHandle;
+ fHandle := 0;
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TGraphicTool.SetInt( const Index: Integer; Value: Integer );
+var Where: PInteger;
+begin
+ Where := Pointer( Integer( @ fData ) + Index );
+ if Where^ = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Where^ := Value;
+ Changed;
+end;
+{$ENDIF PAS_VERSION}
+
+function TGraphicTool.GetInt(const Index: Integer): Integer;
+var Where: PInteger;
+begin
+ Where := Pointer( Integer( @ fData ) + Index );
+ Result := Where^;
+end;
+{$IFDEF WIN_GDI}
+
+{$ENDIF WIN_GDI}
+procedure TGraphicTool.SetColor( Value: TColor );
+begin
+ SetInt( go_Color, Value );
+ fColorRGB := Color2RGB( Value );
+end;
+{$IFDEF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TGraphicTool.IsFontTrueType: Boolean;
+var OldFont: HFont;
+ DC: HDC;
+begin
+ Result := False;
+ if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ DC := GetDC( 0 );
+ OldFont := SelectObject( DC, fHandle );
+ if GetFontData( DC, 0, 0, nil, 0 ) <> GDI_ERROR then
+ Result := True;
+ SelectObject( DC, OldFont );
+ ReleaseDC( 0, DC );
+end;
+{$ENDIF PAS_VERSION}
+
+function TGraphicTool.GetBrushBitmap: HBitmap;
+begin
+ Result := fData.Brush.Bitmap; // for BCB only
+end;
+
+procedure TGraphicTool.SetBrushBitmap(const Value: HBitmap);
+begin
+ if fData.Brush.Bitmap = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if fData.Brush.Bitmap <> 0 then
+ begin
+ Changed; // !!!
+ DeleteObject( fData.Brush.Bitmap );
+ end;
+ fData.Brush.Bitmap := Value;
+ Changed;
+end;
+
+function TGraphicTool.GetBrushStyle: TBrushStyle;
+begin
+ Result := fData.Brush.Style; // for BCB only
+end;
+
+{$ENDIF WIN_GDI}
+procedure TGraphicTool.SetBrushStyle(const Value: TBrushStyle);
+begin
+ if fData.Brush.Style = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fData.Brush.Style := Value;
+ Changed;
+end;
+{$IFDEF WIN_GDI}
+
+function TGraphicTool.GetFontCharset: TFontCharset;
+begin
+ Result := fData.Font.CharSet; // for BCB only
+end;
+
+procedure TGraphicTool.SetFontCharset(const Value: TFontCharset);
+begin
+ if fData.Font.Charset = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fData.Font.Charset := Value;
+ Changed;
+end;
+
+function TGraphicTool.GetFontQuality: TFontQuality;
+begin
+ Result := fData.Font.Quality; // for BCB only
+end;
+
+procedure TGraphicTool.SetFontQuality(const Value: TFontQuality);
+begin
+ if fData.Font.Quality = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fData.Font.Quality := Value;
+ Changed;
+end;
+{$ENDIF WIN_GDI}
+
+function TGraphicTool.GetFontName: KOLString;
+begin
+ Result := fData.Font.Name;
+ {$IFDEF GTK}
+ IF Result = '' THEN
+ Result := 'Sans Serif';
+ {$ENDIF GTK}
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION}
+procedure TGraphicTool.SetFontName(const Value: KOLString);
+begin
+ if KOLString(fData.Font.Name) = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ //FillChar( fData.Font.Name[ 0 ], LF_FACESIZE, #0 );
+ //ZeroMemory( @fData.Font.Name[ 0 ], LF_FACESIZE );
+ {$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF}
+ ( PKOLChar(@fData.Font.Name[0]), PKOLChar( Value ), Length(Value) * SizeOf(KOLChar) {LF_FACESIZE} );
+ Changed;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TextAreaEx( Sender: PCanvas; var Sz : TSize; var Pt : TPoint );
+var Orient : Integer;
+ Pts : array[ 1..4 ] of TPoint;
+ MinX, MinY, I : Integer;
+ A : Double;
+begin
+ if not Sender.Font.IsFontTrueType then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Orient := Sender.Font.FontOrientation;
+ Pt.x := 0; Pt.y := 0;
+ if Orient = 0 then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ A := Orient / 1800.0 * PI;
+ Pts[ 1 ] := Pt;
+ Pts[ 2 ].x := Round( Sz.cx * cos( A ) );
+ Pts[ 2 ].y := - Round( Sz.cx * sin( A ) );
+ Pts[ 4 ].x := - Round( Sz.cy * cos( A + PI / 2 ) );
+ Pts[ 4 ].y := Round( Sz.cy * sin( A + PI / 2 ) );
+ Pts[ 3 ].x := Pts[ 2 ].x + Pts[ 4 ].x;
+ Pts[ 3 ].y := Pts[ 2 ].y + Pts[ 4 ].y;
+ MinX := 0; MinY := 0;
+ for I := 2 to 4 do
+ begin
+ if Pts[ I ].x < MinX then
+ MinX := Pts[ I ].x;
+ if Pts[ I ].y < MinY then
+ MinY := Pts[ I ].y;
+ end;
+ Sz.cx := 0;
+ Sz.cy := 0;
+ for I := 1 to 4 do
+ begin
+ Pts[ I ].x := Pts[ I ].x - MinX;
+ Pts[ I ].y := Pts[ I ].y - MinY;
+ if Pts[ I ].x > Sz.cx then
+ Sz.cx := Pts[ I ].x;
+ if Pts[ I ].y > Sz.cy then
+ Sz.cy := Pts[ I ].y;
+ end;
+ Pt := Pts[ 1 ];
+end;
+{$ENDIF PAS_VERSION}
+
+function TGraphicTool.GetFontOrientation: Integer;
+begin
+ Result := fData.Font.Orientation; // for BCB only
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TGraphicTool.SetFontOrientation(Value: Integer);
+begin
+ GlobalGraphics_UseFontOrient := True;
+ TOnTextArea( GlobalCanvas_OnTextArea ) := TextAreaEx;
+ Value := Value mod 3600; // -3599..+3599
+ SetInt( go_FontOrientation, Value );
+ SetInt( go_FontEscapement, Value );
+end;
+{$ENDIF PAS_VERSION}
+
+function TGraphicTool.GetFontPitch: TFontPitch;
+begin
+ Result := fData.Font.Pitch; // for BCB only
+end;
+
+procedure TGraphicTool.SetFontPitch(const Value: TFontPitch);
+begin
+ if fData.Font.Pitch = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fData.Font.Pitch := Value;
+ Changed;
+end;
+{$ENDIF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TGraphicTool.GetFontStyle: TFontStyle;
+type PFontStyle = ^TFontStyle;
+begin
+ Result := [ ];
+ if fData.Font.Weight >= 700 then Result := [ fsBold ];
+ if fData.Font.Italic then include( Result, fsItalic );
+ if fData.Font.Underline then include( Result, fsUnderline );
+ if fData.Font.StrikeOut then include( Result, fsStrikeOut );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TGraphicTool.SetFontStyle(const Value: TFontStyle);
+begin
+ if FontStyle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if fsBold in Value then
+ begin
+ if fData.Font.Weight < 700 then
+ fData.Font.Weight := 700;
+ end else
+ begin
+ if fData.Font.Weight >= 700 then
+ fData.Font.Weight := 0;
+ end;
+ fData.Font.Italic := fsItalic in Value;
+ fData.Font.Underline := fsUnderline in Value;
+ fData.Font.StrikeOut := fsStrikeOut in Value;
+ Changed;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF WIN_GDI}
+function TGraphicTool.GetPenMode: TPenMode;
+begin
+ Result := fData.Pen.Mode; // for BCB only
+end;
+
+procedure TGraphicTool.SetPenMode(const Value: TPenMode);
+begin
+ if fData.Pen.Mode = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fData.Pen.Mode := Value;
+ Changed;
+end;
+
+function TGraphicTool.GetPenStyle: TPenStyle;
+begin
+ Result := fData.Pen.Style; // for BCB only
+end;
+
+procedure TGraphicTool.SetPenStyle(const Value: TPenStyle);
+begin
+ if fData.Pen.Style = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fData.Pen.Style := Value;
+ Changed;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TGraphicTool.GetHandle: THandle;
+begin
+ Result := fHandle;
+ if Result <> 0 then
+ begin
+ if Color2RGB( fData.Color ) <> fColorRGB then
+ begin
+ DeleteObject( ReleaseHandle );
+ Result := 0;
+ end;
+ end;
+ if Result = 0 then
+ begin
+ if ( fParentGDITool <> nil ) then
+ begin
+ if CompareMem( @ fData, @ fParentGDITool.fData, Sizeof( fData ) ) then
+ begin
+ Result := fParentGDITool.Handle;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ fColorRGB := Color2RGB( fData.Color );
+ fMakeHandleProc( @Self );
+ Result := fHandle;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function MakeBrushHandle( Self_: PGraphicTool ): THandle;
+var
+ LogBrush: TLogBrush;
+begin
+ if Self_.fHandle = 0 then
+ begin
+ LogBrush.lbColor := Color2RGB( Self_.fData.Color );
+ if Self_.fData.Brush.Bitmap <> 0 then
+ begin
+ LogBrush.lbStyle := BS_PATTERN;
+ LogBrush.lbHatch := Self_.fData.Brush.Bitmap;
+ end else
+ begin
+ LogBrush.lbHatch := 0;
+ case Self_.fData.Brush.Style of
+ bsSolid: LogBrush.lbStyle := BS_SOLID;
+ bsClear: LogBrush.lbStyle := BS_NULL;
+ else LogBrush.lbStyle := BS_HATCHED;
+ LogBrush.lbHatch := Ord(Self_.fData.Brush.Style)-Ord(bsHorizontal);
+ LogBrush.lbColor := Color2RGB( Self_.fData.Brush.LineColor );
+ end;
+ end;
+ Self_.fHandle := CreateBrushIndirect(LogBrush);
+ {$IFDEF DEBUG_GDIOBJECTS}
+ if Self_.fHandle <> 0 then
+ Inc( BrushCount )
+ else ShowMessage( 'Could not create brush, error ' + Int2Str( GetLastError ) +
+ ': ' + SysErrorMessage( GetLastError ) );
+ {$ENDIF}
+ end;
+ Result := Self_.fHandle;
+end;
+{$ENDIF PAS_VERSION}
+
+{$UNDEF ASM_LOCAL}
+{$IFNDEF UNICODE_CTRLS}
+ {$IFDEF ASM_VERSION}
+ {$IFNDEF AUTO_REPLACE_CLEARTYPE}
+ {$DEFINE ASM_LOCAL}
+ {$ENDIF AUTO_REPLACE_CLEARTYPE}
+ {$ENDIF PAS_VERSION}
+{$ENDIF}
+
+{$IFDEF ASM_LOCAL}
+function MakeFontHandle( Self_: PGraphicTool ): THandle;
+asm
+ XCHG EDX, EAX
+ MOV EAX, [EDX].TGraphicTool.fHandle
+ TEST EAX, EAX
+ JNZ @@exit
+ PUSH EDX
+ LEA ECX, [EDX].TGraphicTool.fData.Font
+ PUSH ECX
+ CALL CreateFontIndirect
+ POP EDX
+ MOV [EDX].TGraphicTool.fHandle, EAX
+@@exit:
+end;
+{$ELSE PAS_VERSION} //Pascal
+function MakeFontHandle( Self_: PGraphicTool ): THandle;
+{$IFDEF AUTO_REPLACE_CLEARTYPE}
+var LF: TLogFont;
+{$ENDIF}
+begin
+ with Self_^ do
+ begin
+ if fHandle = 0 then
+ begin
+ {$IFDEF AUTO_REPLACE_CLEARTYPE}
+ Move( fData.Font, LF, Sizeof( LF ) );
+ if WinVer < wvXP then
+ begin
+ if LF.lfQuality > ANTIALIASED_QUALITY then
+ LF.lfQuality := ANTIALIASED_QUALITY;
+ end;
+ fHandle := CreateFontIndirect( LF );
+ {$ELSE}
+ fHandle := CreateFontIndirect( PLogFont( @ fData.Font )^ );
+ {$ENDIF}
+ {$IFDEF DEBUG_GDIOBJECTS}
+ Inc( FontCount );
+ {$ENDIF}
+ end;
+ Result := fHandle;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function MakePenHandle( Self_: PGraphicTool ): THandle;
+var
+ LogPen: TLogPen;
+begin
+ with Self_^ do
+ begin
+ //GlobalGraphics_OnObjectCreating( @Self );
+ if fHandle = 0 then
+ with LogPen do
+ begin
+ lopnStyle := Byte( fData.Pen.Style );
+ lopnWidth.X := fData.Pen.Width;
+ lopnColor := Color2RGB( fData.Color );
+ fHandle := CreatePenIndirect( LogPen );
+ {$IFDEF DEBUG_GDIOBJECTS}
+ Inc( PenCount );
+ {$ENDIF}
+ end;
+ //GlobalGraphics_OnObjectCreated( @Self );
+ Result := fHandle;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function TGraphicTool.GetGeometricPen: Boolean;
+begin
+ Result := fData.Pen.Geometric; // for BCB only
+end;
+
+procedure TGraphicTool.SetGeometricPen(const Value: Boolean);
+begin
+ if fData.Pen.Geometric = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fData.Pen.Geometric := Value;
+ fMakeHandleProc := MakeGeometricPenHandle;
+ Changed;
+end;
+
+function TGraphicTool.GetPenEndCap: TPenEndCap;
+begin
+ Result := fData.Pen.EndCap; // for BCB only
+end;
+
+procedure TGraphicTool.SetPenEndCap(const Value: TPenEndCap);
+begin
+ if fData.Pen.EndCap = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fData.Pen.EndCap := Value;
+ Changed;
+end;
+
+function TGraphicTool.GetPenJoin: TPenJoin;
+begin
+ Result := fData.Pen.Join; // for BCB only
+end;
+
+procedure TGraphicTool.SetPenJoin(const Value: TPenJoin);
+begin
+ if fData.Pen.Join = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fData.Pen.Join := Value;
+ Changed;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle;
+const
+ PenStyles: array[ TPenStyle ] of Word =
+ (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL,
+ PS_INSIDEFRAME);
+ PenEndCapStyles: array[ TPenEndCap ] of Word =
+ (PS_ENDCAP_ROUND, PS_ENDCAP_SQUARE, PS_ENDCAP_FLAT);
+ PenJoinStyles: array[ TPenJoin ] of Word =
+ (PS_JOIN_ROUND, PS_JOIN_BEVEL, PS_JOIN_MITER );
+var
+ LogBrush: TLogBrush;
+begin
+ if Self_.fHandle = 0 then
+ with Self_^, LogBrush do
+ begin
+ lbColor := Color2RGB( fData.Color );
+ lbHatch := 0;
+ if fData.Pen.BrushBitmap <> 0 then
+ begin
+ lbStyle := BS_PATTERN;
+ lbHatch := fData.Pen.BrushBitmap;
+ end else
+ case fData.Pen.BrushStyle of
+ bsSolid: lbStyle := BS_SOLID;
+ bsClear: lbStyle := BS_NULL;
+ else lbStyle := BS_HATCHED;
+ case fData.Pen.BrushStyle of
+ bsHorizontal: lbHatch := HS_HORIZONTAL;
+ bsVertical: lbHatch := HS_VERTICAL;
+ bsFDiagonal: lbHatch := HS_FDIAGONAL;
+ bsBDiagonal: lbHatch := HS_BDIAGONAL;
+ bsCross: lbHatch := HS_CROSS;
+ bsDiagCross: lbHatch := HS_DIAGCROSS;
+ end;
+ end;
+ end;
+ Self_.fHandle := ExtCreatePen( PS_GEOMETRIC or Byte( Self_.fData.Pen.Style ) or
+ PenEndCapStyles[ Self_.fData.Pen.EndCap ] or
+ PenJoinStyles[ Self_.fData.Pen.Join ],
+ Self_.fData.Pen.Width, LogBrush, 0, nil );
+ {Assert( Self_.fHandle <> 0, 'Error ' + Int2Str( GetLastError ) +
+ ': ' + SysErrorMessage( GetLastError ) );}
+ {$IFDEF DEBUG_GDIOBJECTS}
+ Inc( PenCount );
+ {$ENDIF}
+ Result := Self_.fHandle;
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF WIN_GDI}
+function TGraphicTool.GetFontWeight: Integer;
+begin
+ Result := fData.Font.Weight; // for BCB only
+end;
+
+procedure TGraphicTool.SetFontWeight(const Value: Integer);
+begin
+ if fData.Font.Weight = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fData.Font.Weight := Value;
+ Changed;
+end;
+{$IFDEF WIN_GDI}
+
+procedure TGraphicTool.SetLogFontStruct(const Value: TLogFont);
+begin
+ if CompareMem(@fData.Font, @Value, SizeOf(TLogFont)) then Exit; {>>>>>>>>>>>}
+ Move(Value, fData.Font, SizeOF(TLogFont));
+ Changed;
+end;
+
+function TGraphicTool.GetLogFontStruct: TLogFont;
+begin
+ Move(fData.Font, Result, SizeOf(TLogFont));
+end;
+{$ENDIF WIN_GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION TGraphicTool.GetPangoFontDesc: PPangoFontDescription;
+VAR s: AnsiString;
+ i: Integer;
+ FUNCTION IfThen( cond: Boolean; CONST s: AnsiString ): AnsiString;
+ BEGIN
+ Result := '';
+ IF cond THEN Result := s;
+ END;
+{const Weights: array[0..9] of String = ( 'Ultralight',
+ 'Ultralight', 'Ultralight',
+ 'Light', 'Normal', 'Normal', 'Normal',
+ 'Bold', 'Ultrabold', 'Heavy' );}
+BEGIN
+ IF NOT Assigned( fPangoFontDesc ) THEN
+ BEGIN
+ s := FontName; { + ' ' +
+ IfThen( FontWeight <> 400, Weights[ FontWeight div 100 ] + ' ' ) +
+ IfThen( fsItalic in FontStyle, 'Italic ' ) {+
+ Int2Str( FontHeight )};
+ fPangoFontDesc := pango_font_description_from_string( PAnsiChar( s ) );
+ i := FontHeight;
+ IF i > 0 THEN
+ pango_font_description_set_absolute_size( fPangoFontDesc, i * PANGO_SCALE );
+ //i := pango_font_description_get_size( fPangoFontDesc );
+ i := PANGO_STYLE_NORMAL;
+ IF fsItalic IN FontStyle THEN i := PANGO_STYLE_ITALIC;
+ pango_font_description_set_style( fPangoFontDesc, i );
+ pango_font_description_set_weight( fPangoFontDesc, FontWeight );
+ END;
+ Result := fPangoFontDesc;
+END;
+
+FUNCTION Color2GDKColor( Color: TColor ): TGdkColor;
+BEGIN
+ Color := Color2RGB( Color );
+ Result.pixel := 0;
+ Result.red := (Color and $FF) shl 8;
+ Result.green := Color and $FF00;
+ Result.blue := (Color shr 8) and $FF00;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+{$IFDEF WIN_GDI}
+
+{ TCanvas }
+
+type
+ TStock = Packed Record
+ StockPen: HPEN;
+ StockBrush: HBRUSH;
+ StockFont: HFONT;
+ end;
+
+var
+ Stock: TStock;
+
+destructor TCanvas.Destroy;
+begin
+ Handle := 0;
+ fPen.Free;
+ fBrush.Free;
+ fFont.Free;
+ inherited;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TCanvas.Assign(SrcCanvas: PCanvas): Boolean;
+begin
+ fFont := fFont.Assign( SrcCanvas.fFont );
+ fBrush := fBrush.Assign( SrcCanvas.fBrush );
+ fPen := fPen.Assign( SrcCanvas.fPen );
+ AssignChangeEvents;
+ Result := (fFont <> nil) or (fBrush <> nil) or (fPen <> nil);
+ if (SrcCanvas.PenPos.x <> PenPos.x) or (SrcCanvas.PenPos.y <> PenPos.y) then
+ begin
+ Result := True;
+ PenPos := SrcCanvas.PenPos;
+ end;
+ if SrcCanvas.ModeCopy <> ModeCopy then
+ begin
+ Result := True;
+ ModeCopy := SrcCanvas.ModeCopy;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.CreateBrush;
+begin
+ if assigned( fBrush ) then
+ begin
+ SelectObject( GetHandle, fBrush.Handle );
+ AssignChangeEvents;
+ if fBrush.fData.Brush.Style = bsSolid then
+ begin
+ SetBkColor( fHandle, Color2RGB( fBrush.fData.Color ) );
+ SetBkMode( fHandle, OPAQUE );
+ end else
+ begin
+ { Win95 doesn't draw brush hatches if bkcolor = brush color }
+ { Since bkmode is transparent, nothing should use bkcolor anyway }
+ SetBkColor( fHandle, not Color2RGB( fBrush.fData.Color ) );
+ SetBkMode( fHandle, TRANSPARENT );
+ end;
+ end else
+ if Assigned( fOwnerControl ) then
+ begin
+ SetBkColor( GetHandle, Color2RGB( PControl( fOwnerControl ).fColor ) );
+ SetBkMode( fHandle, OPAQUE );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.CreateFont;
+begin
+ if ( fFont <> nil ) then
+ begin
+ SelectObject( GetHandle, fFont.Handle );
+ SetTextColor( fHandle, Color2RGB( fFont.fData.Color ) );
+ AssignChangeEvents;
+ end else
+ if ( fOwnerControl <> nil ) then
+ begin
+ SetTextColor( fHandle,
+ Color2RGB( PControl( fOwnerControl ).fTextColor ) );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.CreatePen;
+begin
+ if ( fPen <> nil ) then
+ begin
+ SelectObject( GetHandle, fPen.Handle );
+ SetROP2( fHandle, Ord( fPen.fData.Pen.Mode ) + 1 );
+ AssignChangeEvents;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function TCanvas.GetPixels(X, Y: Integer): TColor;
+begin
+ RequiredState( HandleValid );
+ Result := Windows.GetPixel(FHandle, X, Y);
+end;
+
+procedure TCanvas.SetPixels(X, Y: Integer; const Value: TColor);
+begin
+ Changing;
+ RequiredState( HandleValid );
+ Windows.SetPixel(FHandle, X, Y, Color2RGB( Value ));
+end;
+
+procedure TCanvas.OffsetAndRotate(Xoff, Yoff: Integer; Angle: Double);
+var F: TXForm;
+begin
+ SetGraphicsMode( fHandle, GM_ADVANCED );
+ F.eM11 := cos( Angle );
+ F.eM12 := sin( Angle );
+ F.eM21 := -F.eM12;
+ F.eM22 := F.eM11;
+ F.eDx := Xoff;
+ F.eDy := Yoff;
+ SetWorldTransform( fHandle, F );
+ if (Angle = 0) and (Xoff = 0) and (Yoff = 0) then
+ SetGraphicsMode( fHandle, GM_COMPATIBLE );
+end;
+
+{$ENDIF WIN_GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TCanvas.SaveState;
+BEGIN
+ gdk_gc_get_values( fHandle, @ fSavedState );
+END;
+
+PROCEDURE TCanvas.RestoreState;
+VAR mask: DWORD;
+BEGIN
+ mask := $1FFFF;
+ if fSavedState.font = nil then mask := mask and not GDK_GC_FONT;
+ if fSavedState.stipple = nil then mask := mask and not GDK_GC_STIPPLE;
+ gdk_gc_set_values( fHandle, @ fSavedState, mask );
+ DeselectHandles;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.DeselectHandles;
+begin
+ if (fHandle <> 0) and
+ LongBool(fState and (PenValid or BrushValid or FontValid)) then
+ with Stock do
+ begin
+ if StockPen = 0 then
+ begin
+ StockPen := GetStockObject(BLACK_PEN);
+ StockBrush := GetStockObject(HOLLOW_BRUSH);
+ StockFont := GetStockObject(SYSTEM_FONT);
+ end;
+ SelectObject( fHandle, StockPen );
+ SelectObject( fHandle, StockBrush );
+ SelectObject( fHandle, StockFont );
+ fState := fState and not( PenValid or BrushValid or FontValid );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TCanvas.DeselectHandles;
+BEGIN
+ IF ( fFont <> nil ) AND ( fFont.fPangoFontDesc <> nil ) THEN
+ BEGIN
+ pango_font_description_free( fFont.fPangoFontDesc );
+ fFont.fPangoFontDesc := nil;
+ END;
+ fState := fState and not( PenValid or BrushValid or FontValid );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TCanvas.RequiredState(ReqState: DWORD): HDC; stdcall;
+var
+ NeededState: Byte;
+begin
+ if Boolean(ReqState and ChangingCanvas) then
+ Changing;
+ ReqState := ReqState and 15;
+ NeededState := Byte( ReqState ) and not fState;
+ Result := 0;
+ if Boolean(ReqState and HandleValid) then
+ begin
+ if GetHandle = 0 then Exit; // Important! {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if NeededState <> 0 then
+ begin
+ if Boolean( NeededState and FontValid ) then
+ CreateFont;
+ if Boolean( NeededState and PenValid ) then
+ begin
+ CreatePen;
+ if ( fPen <> nil ) then
+ if fPen.fData.Pen.Style in [psDash, psDot, psDashDot, psDashDotDot] then
+ NeededState := NeededState or BrushValid;
+ end;
+ if Boolean( NeededState and BrushValid ) then
+ CreateBrush;
+ fState := fState or NeededState;
+ end;
+ Result := fHandle;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN_GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TCanvas.ForeBack(fg_color, bk_color: TColor); // install colors just before drawing
+BEGIN
+ fg_color := RGB2BGR( Color2RGB( fg_color ) );
+ bk_color := RGB2BGR( Color2RGB( bk_color ) );
+ gdk_rgb_gc_set_foreground( fHandle, fg_color );
+ gdk_rgb_gc_set_background( fHandle, bk_color );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.SetHandle(Value: HDC);
+{$IFDEF F_P}
+var Ptr1: Pointer;
+{$ENDIF F_P}
+begin
+ if fHandle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if fHandle <> 0 then
+ begin
+ DeselectHandles;
+ {$IFDEF GDI}
+ if (fOwnerControl = nil) or
+ (PControl(fOwnerControl).fPaintDC <> fHandle) then
+ begin
+ {$IFDEF F_P}
+ Ptr1 := Self;
+ asm
+ MOV EAX, [Ptr1]
+ MOV EAX, [EAX].TCanvas.fOnGetHandle
+ MOV [Ptr1], EAX
+ end [ 'EAX' ];
+ if Ptr1 = @ TControl.DC2Canvas then
+ {$ELSE DELPHI}
+ //////////////////// SLAG
+ if TMethod(fOnGetHandle).Code =
+ @TControl.Dc2Canvas then
+ {$ENDIF F_P/DELPHI}
+ ReleaseDC( PControl(fOwnerControl).Handle, fHandle )
+ else
+ if not (fIsAlienDC or fIsPaintDC) then
+ DeleteDC( fHandle );
+ ////////////////////
+ end;
+ {$ENDIF GDI}
+ fHandle := 0;
+ fIsPaintDC := False;
+ fState := fState and not HandleValid;
+ end;
+ if Value <> 0 then
+ begin
+ fState := fState or HandleValid;
+ fHandle := Value;
+ SetPenPos( fPenPos );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.SetPenPos(const Value: TPoint);
+begin
+ fPenPos := Value;
+ {$IFDEF GDI}
+ MoveTo( Value.x, Value.y );
+ {$ENDIF GDI}
+end;
+{$ENDIF PAS_VERSION}
+{$IFDEF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.Changing;
+begin
+ if Assigned( fOnChangeCanvas ) then
+ fOnChangeCanvas( @Self );
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF WIN_GDI}
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;
+begin
+ RequiredState( HandleValid or PenValid or ChangingCanvas );
+ Windows.Arc(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); STDCALL;
+VAR C: TPoint;
+ angle1, angle2: Integer;
+ A1, A2: Double;
+BEGIN
+ ////RequiredState( {HandleValid or} PenValid or ChangingCanvas );
+ C := MakePoint( (X1 + X2) div 2, (Y1 + Y2) div 2 );
+ {$IFDEF NOT_USE_EXCEPTION}
+ A1 := ArcTan2( Y3-C.Y, X3-C.X );
+ A2 := ArcTan2( Y4-C.Y, X4-C.X );
+ {$ELSE USE_EXCEPTION}
+ TRY
+ A1 := ArcTan2( Y3-C.Y, X3-C.X );
+ EXCEPT
+ A1 := 0;
+ END;
+ TRY
+ A2 := ArcTan2( Y4-C.Y, X4-C.X );
+ EXCEPT
+ A2 := 0;
+ END;
+ {$ENDIF NOT_USE_EXCEPTION}
+ angle1 := -Round(A1 * 180 * 64 / PI);
+ angle2 := -Round(A2 * 180 * 64 / PI);
+ IF Brush.BrushStyle <> bsClear THEN
+ BEGIN
+ ForeBack( Brush.Color, Brush.Color );
+ gdk_draw_arc( fDrawable, fHandle, 1, X1, Y1, X2-X1, Y2-Y1, angle1, angle2 );
+ END;
+ ForeBack( Pen.Color, Brush.Color );
+ gdk_draw_arc( fDrawable, fHandle, 0, X1, Y1, X2-X1, Y2-Y1, angle1, angle2 );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+{$IFDEF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;
+begin
+ RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
+ Windows.Chord(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.CopyRect(const DstRect: TRect; SrcCanvas: PCanvas;
+ const SrcRect: TRect);
+begin
+ RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ SrcCanvas.RequiredState( HandleValid or BrushValid );
+ StretchBlt( fHandle, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
+ DstRect.Bottom - DstRect.Top, SrcCanvas.Handle, SrcRect.Left, SrcRect.Top,
+ SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, ModeCopy);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
+begin
+ RequiredState( HandleValid or BrushValid or FontValid or ChangingCanvas );
+ Windows.DrawFocusRect(FHandle, Rect);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer);
+begin
+ RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
+ Windows.Ellipse(FHandle, X1, Y1, X2, Y2);
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF WIN_GDI}
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
+var Br: HBrush;
+begin
+ RequiredState( HandleValid or BrushValid or ChangingCanvas );
+ if fBrush <> nil then
+ begin
+ Windows.FillRect(fHandle, Rect, fBrush.Handle);
+ end else
+ if ( fOwnerControl <> nil ) then
+ begin
+ {$IFDEF GDI}
+ if ( PControl( fOwnerControl ).fBrush <> nil ) then
+ Windows.FillRect( fHandle, Rect, PControl( fOwnerControl ).fBrush.Handle )
+ else
+ begin
+ Br := CreateSolidBrush( Color2RGB(PControl(fOwnerControl).fColor) );
+ Windows.FillRect(fHandle, Rect, Br );
+ DeleteObject( Br );
+ end;
+ {$ENDIF GDI}
+ end else
+ Windows.FillRect(fHandle, Rect, HBrush(COLOR_WINDOW + 1) );
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
+BEGIN
+ if (fBrush <> nil) and (fBrush.BrushStyle = bsClear) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ ForeBack( Brush.Color, Brush.Color );
+ gdk_draw_rectangle( fDrawable, fHandle, 1, Rect.Left, Rect.Top,
+ Rect.Right-Rect.Left, Rect.Bottom-Rect.Top );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+{$IFDEF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.FillRgn(const Rgn: HRgn);
+var Br : HBrush;
+begin
+ RequiredState( HandleValid or BrushValid or ChangingCanvas );
+ if ( fBrush <> nil ) then
+ Windows.FillRgn(FHandle, Rgn, fBrush.Handle )
+ else if ( fOwnerControl <> nil ) then
+ begin
+ {$IFDEF GDI}
+ if ( PControl( fOwnerControl ).fBrush <> nil ) then
+ Windows.FillRgn( FHandle, Rgn, PControl( fOwnerControl ).fBrush.Handle )
+ else
+ begin
+ Br := CreateSolidBrush( Color2RGB(PControl(fOwnerControl).fColor) );
+ Windows.FillRgn( fHandle, Rgn, Br );
+ DeleteObject( Br );
+ end;
+ {$ENDIF GDI}
+ end else
+ begin
+ Br := CreateSolidBrush( DWORD(clWindow) );
+ Windows.FillRgn( fHandle, Rgn, Br );
+ DeleteObject( Br );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;
+ FillStyle: TFillStyle);
+const
+ FillStyles: array[TFillStyle] of Word =
+ (FLOODFILLSURFACE, FLOODFILLBORDER);
+begin
+ RequiredState( HandleValid or BrushValid or ChangingCanvas );
+ Windows.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.FrameRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
+var SolidBr : HBrush;
+begin
+ RequiredState( HandleValid or ChangingCanvas );
+ if fBrush <> nil then
+ SolidBr := CreateSolidBrush( Color2RGB( fBrush.fData.Color ) )
+ else
+ if fOwnerControl <> nil then
+ SolidBr := CreateSolidBrush( PControl(fOwnerControl).fColor )
+ else SolidBr := CreateSolidBrush( clWhite );
+ Windows.FrameRect(FHandle, Rect, SolidBr);
+ DeleteObject( SolidBr );
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF WIN_GDI}
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.LineTo(X, Y: Integer);
+begin
+ RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
+ Windows.LineTo( fHandle, X, Y );
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TCanvas.LineTo(X, Y: Integer);
+BEGIN
+ ForeBack( Pen.Color, Brush.Color );
+ gdk_draw_line( fDrawable, fHandle, fPenPos.X, fPenPos.Y, X, Y );
+ fPenPos := MakePoint( X, Y );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.MoveTo(X, Y: Integer);
+begin
+ RequiredState( HandleValid );
+ Windows.MoveToEx( fHandle, X, Y, nil );
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TCanvas.MoveTo(X, Y: Integer);
+BEGIN
+ fPenPos := MakePoint( X, Y );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+procedure TCanvas.ObjectChanged(Sender: PGraphicTool);
+begin
+ DeselectHandles;
+end;
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall;
+begin
+ RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
+ Windows.Pie( fHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.Polygon(const Points: array of TPoint);
+type
+ PPoints = ^TPoints;
+ TPoints = array[0..0] of TPoint;
+begin
+ RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
+ {$IFDEF F_P} Windows_Polygon
+ {$ELSE DELPHI} Windows.Polygon
+ {$ENDIF}( fHandle, PPoints(@Points)^, High(Points) + 1);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.Polyline(const Points: array of TPoint);
+type
+ PPoints = ^TPoints;
+ TPoints = array[0..0] of TPoint;
+begin
+ RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
+ {$IFDEF F_P}Windows_Polyline
+ {$ELSE DELPHI}Windows.Polyline
+ {$ENDIF}( fHandle, PPoints(@Points)^, High(Points) + 1);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
+begin
+ RequiredState( HandleValid or BrushValid or PenValid or ChangingCanvas );
+ Windows.Rectangle( fHandle, X1, Y1, X2, Y2);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
+begin
+ RequiredState( HandleValid or BrushValid or PenValid or ChangingCanvas );
+ Windows.RoundRect( fHandle, X1, Y1, X2, Y2, X3, Y3);
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.TextArea(const Text: KOLString; var Sz: TSize;
+ var P0: TPoint);
+begin
+ Sz := TextExtent( Text );
+ P0.x := 0; P0.y := 0;
+ TOnTextArea( GlobalCanvas_OnTextArea )( @Self, Sz, P0 );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF _D3orHigher}
+procedure TCanvas.WTextArea(const Text: KOLWideString; var Sz: TSize;
+ var P0: TPoint);
+begin
+ Sz := WTextExtent( Text );
+ P0.x := 0; P0.y := 0;
+ TOnTextArea( GlobalCanvas_OnTextArea )( @Self, Sz, P0 );
+end;
+{$ENDIF _D3orHigher}
+
+{$IFDEF GDI}
+{$IFDEF TEXT_EXTENT_OLD}
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TCanvas.TextExtent(const Text: KOLString): TSize;
+var DC : HDC;
+ ClearHandle : Boolean;
+begin
+ ClearHandle := False;
+ RequiredState( HandleValid or FontValid );
+ DC := fHandle;
+ if DC = 0 then
+ begin
+ DC := CreateCompatibleDC( 0 );
+ ClearHandle := True;
+ SetHandle( DC );
+ If Not (fIsAlienDC or fIsPaintDC) then
+ ClearHandle := True; //************ // Added By Gerasimov
+ end;
+ RequiredState( HandleValid or FontValid );
+ GetTextExtentPoint32( fHandle, PKOLChar(Text), Length(Text), Result);
+ {$IFDEF FIX_ITALIC_TEXT_WIDTH}
+ if fsItalic in Font.FontStyle then
+ begin
+ inc( Result.cx, Result.cy div 4 );
+ end;
+ {$ENDIF}
+ if ClearHandle then
+ SetHandle( 0 );
+ { DC must be freed here automatically (never leaks):
+ if Canvas created on base of existing DC, no memDC created,
+ if Canvas has fHandle:HDC = 0, it is not fIsPaintDC always. }
+end;
+{$ENDIF PAS_VERSION}
+{$ELSE TEXT_EXTENT_NEW}
+{$IFDEF ASM_UNICODE}{$ELSE notASM_VERSION}
+function TCanvas.TextExtent(const Text: KOLString): TSize;
+begin
+ RequiredState( HandleValid or FontValid );
+ GetTextExtentPoint32( fHandle, PKOLChar(Text), Length(Text), Result);
+ {$IFDEF FIX_ITALIC_TEXT_WIDTH}
+ if Font.fData.Font.Italic then
+ inc( Result.cx, Result.cy div 4 );
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF TEXT_EXTENT_NEW}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION TCanvas.TextExtent(const Text: KOLString): TSize;
+VAR layout: PPangoLayout;
+ context: PPangoContext;
+BEGIN
+ //RequiredState( HandleValid or FontValid );
+ IF fOwnerControl <> nil THEN
+ BEGIN
+ context := nil;
+ layout := gtk_widget_create_pango_layout(
+ PControl( fOwnerControl ).fEventboxHandle, nil );
+ END ELSE
+ BEGIN //todo: seems not working in such way... What to do for memory bitmap?
+ context := pango_context_new;
+ //layout := gtk_widget_create_pango_layout( fHandle, PChar( Text ) );
+ layout := pango_layout_new( context );
+ END;
+ pango_layout_set_font_description( layout, Font.FontHandle );
+ pango_layout_set_text( layout, PAnsiChar( Text ), Length( Text ) );
+ pango_layout_get_size( layout, @ Result.cx, @ Result.cy );
+ g_object_unref( layout );
+ IF context <> nil THEN g_object_unref( context );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+function TCanvas.TextHeight(const Text: KOLString): Integer;
+begin
+ Result := TextExtent(Text).cY;
+end;
+
+{$IFDEF GDI}
+procedure TCanvas.TextOutA(X, Y: Integer; const Text: AnsiString); stdcall;
+begin
+ RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ Windows.TextOutA(FHandle, X, Y, PAnsiChar(Text), Length(Text));
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.TextOut(X, Y: Integer; const Text: KOLString); stdcall;
+begin
+ RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ {$IFDEF UNICODE_CTRLS}Windows.TextOutW
+ {$ELSE} Windows.TextOutA
+ {$ENDIF}(FHandle, X, Y, PKOLChar(Text), Length(Text));
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TCanvas.TextOut(X, Y: Integer; CONST Text: AnsiString); STDCALL;
+VAR Options: Integer;
+BEGIN
+ Options := 0;
+ if Brush.BrushStyle <> bsClear then Options := ETO_OPAQUE;
+ ExtTextOut( X, Y, Options, MakeRect( 0,0,0,0 ), Text, [ ] );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.TextRect(const Rect: TRect; X, Y: Integer; const Text: Ansistring);
+var
+ Options: Integer;
+begin
+ //Changing;
+ RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ Options := ETO_CLIPPED;
+ if ( fBrush <> nil ) and (fBrush.fData.Brush.Style <> bsClear)
+ or ( fBrush = nil ) then Inc(Options, ETO_OPAQUE);
+ Windows.ExtTextOutA( fHandle, X, Y, Options,
+ @Rect, PAnsiChar(Text),
+ Length(Text), nil); // KOL_ANSI
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TCanvas.TextRect(CONST Rect: TRect; X, Y: Integer; CONST Text: Ansistring);
+VAR Options: Integer;
+BEGIN
+ Options := ETO_CLIPPED;
+ IF Brush.BrushStyle <> bsClear THEN Options := Options or ETO_OPAQUE;
+ ExtTextOut( X, Y, Options, Rect, Text, [] ); // KOL_ANSI
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF GDI}
+procedure TCanvas.ExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; const Text: AnsiString;
+ const Spacing: array of Integer );
+begin
+ RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ windows.ExtTextOutA(FHandle, X, Y, Options, @Rect, PAnsiChar(Text), Length(Text), @Spacing[ 0 ]); // KOL_ANSI have not Ex
+end;
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TCanvas.ExtTextOut( X, Y: Integer; Options: DWORD; CONST Rect: TRect;
+ CONST Text: AnsiString; CONST Spacing: ARRAY of Integer );
+VAR context: PPangoContext;
+ layout: PPangoLayout;
+ w, h: Integer;
+ pixmap: PGdkPixmap;
+BEGIN
+ ////RequiredState( {HandleValid or} FontValid or BrushValid or ChangingCanvas );
+ w := Rect.Right - Rect.Left;
+ h := Rect.Bottom - Rect.Top;
+ IF fOwnerControl <> nil THEN
+ BEGIN
+ context := nil;
+ layout := gtk_widget_create_pango_layout(
+ PControl( fOwnerControl ).fEventboxHandle, nil );
+ END ELSE
+ BEGIN //todo: seems not working in such way... What to do for memory bitmap?
+ context := pango_context_new;
+ //layout := gtk_widget_create_pango_layout( fHandle, PChar( Text ) );
+ layout := pango_layout_new( context );
+ END;
+ pango_layout_set_font_description( layout, Font.FontHandle );
+ pango_layout_set_text( layout, PAnsiChar( Text ), Length( Text ) );
+ IF Options AND ETO_CLIPPED = 0 THEN
+ BEGIN
+ pango_layout_get_size( layout, @ w, @ h );
+ w := w div PANGO_SCALE;
+ h := h div PANGO_SCALE;
+ END;
+ pixmap := gdk_pixmap_new( PControl( fOwnerControl ).fEventboxHandle.window,
+ w, h, -1 ); //todo: use MainForm
+ IF Options AND ETO_OPAQUE <> 0 THEN
+ BEGIN
+ ForeBack( Brush.Color, Brush.Color );
+ gdk_draw_rectangle( GDK_DRAWABLE( pixmap ), fHandle, 1, 0, 0, w, h );
+ END ELSE
+ BEGIN
+ gdk_draw_drawable( GDK_DRAWABLE( pixmap ), fHandle, fDrawable,
+ Rect.Left, Rect.Top, 0, 0, w, h );
+ END;
+ ForeBack( Font.Color, Brush.Color );
+ gdk_draw_layout( GDK_DRAWABLE( pixmap ), fHandle, X, Y, layout );
+ g_object_unref( layout );
+ gdk_draw_drawable( fDrawable, fHandle, GDK_DRAWABLE( pixmap ),
+ 0, 0, Rect.Left, Rect.Top, w, h );
+ g_object_unref( pixmap );
+ IF context <> nil THEN
+ g_object_unref( context );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE}
+procedure TCanvas.DrawText(Text: AnsiString; var Rect:TRect; Flags:DWord);
+begin
+ RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ Windows.DrawTextA(Handle, PAnsiChar(Text), -1, Rect, Flags); // KOL_ANSI
+end;
+{$ENDIF PAS_VERSION}
+
+function TCanvas.ClipRect: TRect;
+begin
+ RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ GetClipBox(Handle, Result);
+end;
+{$ENDIF WIN_GDI}
+
+function TCanvas.TextWidth(const Text: KOLString): Integer;
+begin
+ Result := TextExtent(Text).cX;
+end;
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TCanvas.GetBrush: PGraphicTool;
+begin
+ if ( fBrush = nil ) then
+ begin
+ fBrush := NewBrush;
+ if ( fOwnerControl <> nil ) then
+ begin
+ fBrush.fData.Color := PControl(fOwnerControl).fColor;
+ if ( PControl(fOwnerControl).fBrush <> nil ) then
+ fBrush.Assign( PControl(fOwnerControl).fBrush );
+ // both statements above needed
+ end;
+ AssignChangeEvents;
+ end;
+ Result := fBrush;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION TCanvas.GetBrush: PGraphicTool;
+BEGIN
+ IF ( fBrush = nil ) THEN
+ BEGIN
+ fBrush := NewBrush;
+ IF ( fOwnerControl <> nil ) THEN
+ BEGIN
+ fBrush.fData.Color := PControl(fOwnerControl).fColor;
+ IF ( PControl(fOwnerControl).fBrush <> nil ) THEN
+ fBrush.Assign( PControl(fOwnerControl).fBrush );
+ // both statements above needed
+ END;
+ AssignChangeEvents;
+ END;
+ Result := fBrush;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TCanvas.GetFont: PGraphicTool;
+begin
+ if ( fFont = nil ) then
+ begin
+ fFont := NewFont;
+ if ( fOwnerControl <> nil ) then
+ begin
+ fFont.Color := PControl(fOwnerControl).fTextColor;
+ if ( PControl(fOwnerControl).fFont <> nil ) then
+ fFont.Assign( PControl(fOwnerControl).fFont );
+ end;
+ AssignChangeEvents;
+ end;
+ Result := fFont;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TCanvas.GetPen: PGraphicTool;
+begin
+ if ( fPen = nil ) then
+ begin
+ fPen := NewPen;
+ AssignChangeEvents;
+ end;
+ Result := fPen;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TCanvas.GetHandle: HDC;
+begin
+ /////////////////////////////////
+ if Assigned( fOnGetHandle ) then
+ /////////////////////////////////
+ begin
+ Result := fOnGetHandle( @Self );
+ SetHandle( Result );
+ end else
+ Result := fHandle;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION TCanvas.GetHandle: HDC;
+BEGIN
+ ////////////////////////////////
+ IF Assigned( fOnGetHandle ) THEN
+ ////////////////////////////////
+ fHandle := fOnGetHandle( @Self );
+ Result := fHandle;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TCanvas.AssignChangeEvents;
+begin
+ if ( fBrush <> nil ) then
+ fBrush.fOnGTChange := ObjectChanged;
+ if ( fPen <> nil ) then
+ fPen.fOnGTChange := ObjectChanged;
+ if ( fFont <> nil ) then
+ fFont.fOnGTChange := ObjectChanged;
+end;
+{$ENDIF PAS_VERSION}
+{$IFDEF WIN_GDI}
+
+{$IFNDEF _FPC}
+{$IFNDEF _D2}
+procedure TCanvas.WDrawText(WText: KOLWideString; var Rect: TRect;
+ Flags: DWord);
+begin
+ RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ Windows.DrawTextW(Handle,PWideChar(WText),-1,Rect,Flags);
+end;
+
+procedure TCanvas.WExtTextOut(X, Y: Integer; Options: DWORD;
+ const Rect: TRect; const WText: KOLWideString;
+ const Spacing: array of Integer);
+begin
+ RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ Windows.ExtTextOutW(FHandle, X, Y, Options, @Rect, PWideChar(WText), Length(WText), @Spacing[ 0 ]);
+end;
+
+procedure TCanvas.WTextOut(X, Y: Integer; const WText: KOLWideString);
+begin
+ RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ Windows.TextOutW(FHandle, X, Y, PWideChar(WText), Length(WText));
+ MoveTo(X + WTextWidth(WText), Y);
+end;
+
+procedure TCanvas.WTextRect(const Rect: TRect; X, Y: Integer;
+ const WText: KOLWideString);
+var
+ Options: Integer;
+begin
+ RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ Options := ETO_CLIPPED;
+ if ( fBrush <> nil ) and (fBrush.fData.Brush.Style <> bsClear)
+ or ( fBrush = nil ) then Inc(Options, ETO_OPAQUE);
+ Windows.ExtTextOutW( fHandle, X, Y, Options,
+ @Rect, PWideChar(WText),
+ Length(WText), nil);
+end;
+
+function TCanvas.WTextExtent(const WText: KOLWideString): TSize;
+var DC : HDC;
+ ClearHandle : Boolean;
+begin
+ ClearHandle := False;
+ RequiredState( HandleValid or FontValid );
+ DC := fHandle;
+ if DC = 0 then
+ begin
+ DC := CreateCompatibleDC( 0 );
+ ClearHandle := True;
+ SetHandle( DC );
+ end;
+ RequiredState( HandleValid or FontValid );
+ Windows.GetTextExtentPoint32W( fHandle, PWideChar(WText), Length(WText), Result);
+ if ClearHandle then
+ SetHandle( 0 );
+end;
+
+function TCanvas.WTextHeight(const WText: KOLWideString): Integer;
+begin
+ Result := WTextExtent( WText ).cy;
+end;
+
+function TCanvas.WTextWidth(const WText: KOLWideString): Integer;
+begin
+ Result := WTextExtent( WText ).cx;
+end;
+{$ENDIF _D2}
+{$ENDIF _FPC}
+
+{$ENDIF WIN_GDI}
+function MakeInt64( Lo, Hi: DWORD ): I64;
+begin
+ Result.Lo := Lo;
+ Result.Hi := Hi;
+end;
+
+{$IFDEF PAS_ONLY}
+{$ELSE}
+function Int2Int64( X: Integer ): I64;
+asm
+ MOV [EDX], EAX
+ MOV ECX, EDX
+ CDQ
+ MOV [ECX+4], EDX
+end;
+
+procedure IncInt64( var I64: I64; Delta: Integer );
+asm
+ ADD [EAX], EDX
+ ADC dword ptr [EAX+4], 0
+end;
+
+procedure DecInt64( var I64: I64; Delta: Integer );
+asm
+ SUB [EAX], EDX
+ SBB dword ptr [EDX], 0
+end;
+
+function Add64( const X, Y: I64 ): I64;
+asm
+ PUSH ESI
+ XCHG ESI, EAX
+ LODSD
+ ADD EAX, [EDX]
+ MOV [ECX], EAX
+ LODSD
+ ADC EAX, [EDX+4]
+ MOV [ECX+4], EAX
+ POP ESI
+end;
+
+function Sub64( const X, Y: I64 ): I64;
+asm
+ PUSH ESI
+ XCHG ESI, EAX
+ LODSD
+ SUB EAX, [EDX]
+ MOV [ECX], EAX
+ LODSD
+ SBB EAX, [EDX+4]
+ MOV [ECX+4], EAX
+ POP ESI
+end;
+
+function Neg64( const X: I64 ): I64;
+asm
+ MOV ECX, [EAX]
+ NEG ECX
+ MOV [EDX], ECX
+ MOV ECX, 0
+ SBB ECX, [EAX+4]
+ MOV [EDX+4], ECX
+end;
+
+function Mul64EDX( const X: I64; M: Integer ): I64;
+asm
+ PUSH ESI
+ PUSH EDI
+ XCHG ESI, EAX
+ MOV EDI, ECX
+ MOV ECX, EDX
+ LODSD
+ MUL ECX
+ STOSD
+ XCHG EDX, ECX
+ LODSD
+ MUL EDX
+ ADD EAX, ECX
+ STOSD
+ POP EDI
+ POP ESI
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function Mul64i( const X: I64; Mul: Integer ): I64;
+var Minus: Boolean;
+begin
+ Minus := FALSE;
+ if Mul < 0 then
+ begin
+ Minus := TRUE;
+ Mul := -Mul;
+ end;
+ Result := Mul64EDX( X, Mul );
+ if Minus then
+ Result := Neg64( Result );
+end;
+{$ENDIF PAS_VERSION}
+
+function Div64EDX( const X: I64; D: Integer ): I64;
+asm
+ PUSH ESI
+ PUSH EDI
+ XCHG ESI, EAX
+ MOV EDI, ECX
+ MOV ECX, EDX
+ MOV EAX, [ESI+4]
+ CDQ
+ DIV ECX
+ MOV [EDI+4], EAX
+ LODSD
+ DIV ECX
+ STOSD
+ POP EDI
+ POP ESI
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function Div64i( const X: I64; D: Integer ): I64;
+var Minus: Boolean;
+begin
+ Minus := FALSE;
+ if D < 0 then
+ begin
+ D := -D;
+ Minus := TRUE;
+ end;
+ Result := X;
+ if Sgn64( Result ) < 0 then
+ begin
+ Result := Neg64( Result );
+ Minus := not Minus;
+ end;
+ Result := Div64EDX( Result, D );
+ if Minus then
+ Result := Neg64( Result );
+end;
+{$ENDIF PAS_VERSION}
+
+function Mod64i( const X: I64; D: Integer ): Integer;
+begin
+ Result := Sub64( X, Mul64i( Div64i( X, D ), D ) ).Lo;
+end;
+
+function Sgn64( const X: I64 ): Integer;
+asm
+ XOR EDX, EDX
+ CMP [EAX+4], EDX
+ XCHG EAX, EDX
+ JG @@ret_1
+ JL @@ret_neg
+ CMP [EDX], EAX
+ JZ @@exit
+@@ret_1:
+ INC EAX
+ RET
+@@ret_neg:
+ DEC EAX
+@@exit:
+end;
+
+function Cmp64( const X, Y: I64 ): Integer;
+begin
+ Result := Sgn64( Sub64( X, Y ) );
+end;
+
+function Int64_2Str( X: I64 ): AnsiString;
+var M: Boolean;
+ Y: Integer;
+ Buf: array[ 0..31 ] of AnsiChar;
+ I: Integer;
+begin
+ M := FALSE;
+ case Sgn64( X ) of
+ -1: begin M := TRUE; X := Neg64( X ); end;
+ 0: begin Result := '0'; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ I := 31;
+ Buf[ 31 ] := #0;
+ while Sgn64( X ) > 0 do
+ begin
+ Dec( I );
+ Y := Mod64i( X, 10 );
+ Buf[ I ] := AnsiChar( Y + Integer( '0' ) );
+ X := Div64i( X, 10 );
+ end;
+ if M then
+ begin
+ Dec( I );
+ Buf[ I ] := '-';
+ end;
+ Result := PAnsiChar( @Buf[ I ] );
+end;
+
+function Int64_2Hex( X: I64; MinDigits: Integer ): KOLString;
+begin
+ if (MinDigits <= 8) and (X.Hi <> 0) then
+ Result := Int2Hex( X.Hi, 1 ) + Int2Hex( X.Lo, 8 )
+ else if X.Hi <> 0 then
+ Result := Int2Hex( X.Hi, MinDigits - 8 ) + Int2Hex( X.Lo, 8 )
+ else Result := Int2Hex( X.Lo, MinDigits );
+end;
+
+function Str2Int64( const S: AnsiString ): I64;
+var I: Integer;
+ M: Boolean;
+begin
+ Result.Lo := 0;
+ Result.Hi := 0;
+ I := 1;
+ if S = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ M := FALSE;
+ if S[ 1 ] = '-' then
+ begin
+ M := TRUE;
+ Inc( I );
+ end else if S[ 1 ] = '+' then
+ Inc( I );
+ while I <= Length( S ) do
+ begin
+ if (S[ I ] < '0') or (S[ I ] > '9') then
+ break;
+ Result := Mul64i( Result, 10 );
+ IncInt64( Result, Integer( S[ I ] ) - Integer( '0' ) );
+ Inc( I );
+ end;
+ if M then
+ Result := Neg64( Result );
+end;
+
+function Int64_2Double( const X: I64 ): Double;
+asm
+ FILD qword ptr [EAX]
+ FSTP @Result
+end;
+
+function Double2Int64( D: Double ): I64;
+asm
+ FLD D
+ FISTP qword ptr [EAX]
+end;
+{$ENDIF PAS_ONLY}
+
+function IsNan(const AValue: Double): Boolean;
+{$IFDEF _D2orD3}
+type PI64 = ^I64;
+{$ENDIF}
+begin
+ Result := (PI64(@AValue).Hi and $7FF00000 = $7FF00000) and
+ ((PI64(@AValue).Hi and $000FFFFF <> 0) or (PI64(@AValue).Lo <> 0));
+end;
+
+function IsInfinity(const AValue: Double): Boolean;
+{$IFDEF _D2orD3}
+type PI64 = ^I64;
+{$ENDIF}
+begin
+ Result := (PI64(@AValue).Hi and $7FF00000 = $7FF00000) and
+ (PI64(@AValue).Hi and $000FFFFF = $00000000);
+end;
+
+{$IFDEF PAS_ONLY} {$DEFINE PAS_INTPOW} {$ENDIF}
+{$IFDEF F_P} {$DEFINE PAS_INTPOW} {$ENDIF}
+
+function IntPower(Base: Extended; Exponent: Integer): Extended;
+{$IFDEF PAS_ONLY}
+begin
+ Result := 1.0;
+ if Exponent = 0 then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Exponent < 0 then begin
+ Exponent := -Exponent;
+ Base := 1.0 / Base;
+ end;
+ REPEAT
+ Result := Result * Base;
+ Dec( Exponent );
+ UNTIL Exponent=0;
+end;
+{$ELSE DELPHI}
+// This version of code by Galkov: Changes in comparison to Delphi standard:
+// no Overflow exception if Exponent is very big negative value
+// (just 0 in result in such case).
+asm
+ fld1 { Result := 1 }
+ test eax,eax // check Exponent for 0, return 0 ** 0 = 1
+ jz @@3 // (though Mathematics says that this is not so...)
+ fld Base
+ jg @@2
+ fdivr ST,ST(1) { Base := 1 / Base }
+ neg eax
+ jmp @@2
+@@1: fmul ST,ST { X := Base * Base }
+@@2: shr eax,1
+ jnc @@1
+ fmul ST(1),ST { Result := Result * X }
+ jnz @@1
+ fstp st { pop X from FPU stack }
+@@3: fwait
+end;
+{$ENDIF PAS_ONLY}
+
+function NextPowerOf2( n: DWORD ): DWORD;
+begin
+ Result := 1;
+ while (Result < n) and (Result <> 0) do
+ Result := Result shl 1;
+end;
+
+function Str2Double( const S: KOLString ): Double;
+var I: Integer;
+ M, Pt: Boolean;
+ D: Double;
+ Ex: Integer;
+begin
+ Result := 0.0;
+ if S = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ M := FALSE;
+ I := 1;
+ if S[ 1 ] = '-' then
+ begin
+ M := TRUE;
+ Inc( I );
+ end;
+ Pt := FALSE;
+ D := 1.0;
+ while I <= Length( S ) do
+ begin
+ case S[ I ] of
+ '.' {$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' )
+ else
+ begin
+ D := D * 0.1;
+ Result := Result + (Integer( S[ I ] ) - Integer( '0' )) * D;
+ end;
+ 'e', 'E': begin
+ Ex := Str2Int( CopyEnd( S, I + 1 ) );
+ Result := Result * IntPower( 10.0, Ex );
+ break;
+ end;
+ end;
+ Inc( I );
+ end;
+ if M then
+ Result := -Result;
+end;
+
+function Str2Extended( const S: KOLString ): Extended;
+var I: Integer;
+ M, Pt: Boolean;
+ D: Extended;
+ Ex: Integer;
+begin
+ Result := 0.0;
+ if S = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ M := FALSE;
+ I := 1;
+ if S[ 1 ] = '-' then
+ begin
+ M := TRUE;
+ Inc( I );
+ end;
+ Pt := FALSE;
+ D := 1.0;
+ while I <= Length( S ) do
+ begin
+ case S[ I ] of
+ '.' {$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' )
+ else
+ begin
+ D := D * 0.1;
+ Result := Result + (Integer( S[ I ] ) - Integer( '0' )) * D;
+ end;
+ 'e', 'E': begin
+ Ex := Str2Int( CopyEnd( S, I + 1 ) );
+ Result := Result * IntPower( 10.0, Ex );
+ break;
+ end;
+ end;
+ Inc( I );
+ end;
+ if M then
+ Result := -Result;
+end;
+
+{$IFNDEF PAS_ONLY}
+function TruncD( D: Double ): Double;
+asm
+ FLD D
+ PUSH ECX
+ FNSTCW [ESP]
+ POP ECX
+ PUSH ECX
+ OR byte ptr [ESP+1], $0C
+ FLDCW [ESP]
+ PUSH ECX
+ FRNDINT
+ FSTP @Result
+ FLDCW [ESP]
+ POP ECX
+ POP ECX
+end;
+{$ENDIF}
+
+function IfThenElseBool( t, e: Boolean; Cond: Boolean ): Boolean;
+begin
+ if cond then Result := t else Result := e;
+end;
+function IfThenElseInt( t, e: Integer; Cond: Boolean ): Integer;
+begin
+ if cond then Result := t else Result := e;
+end;
+function IfThenElseStr( const t, e: AnsiString; Cond: Boolean ): AnsiString;
+begin
+ if cond then Result := t else Result := e;
+end;
+{$IFDEF _D5orHigher}
+function IfThenElse( t, e: Boolean; Cond: Boolean ): Boolean; overload;
+begin
+ if cond then Result := t else Result := e;
+end;
+function IfThenElse( t, e: Integer; Cond: Boolean ): Integer; overload;
+begin
+ if cond then Result := t else Result := e;
+end;
+function IfThenElse( t, e: AnsiString; Cond: Boolean ): AnsiString; overload;
+begin
+ if cond then Result := t else Result := e;
+end;
+function IfThenElse( t, e: Double; Cond: Boolean ): Double; overload;
+begin
+ if cond then Result := t else Result := e;
+end;
+{$ENDIF}
+
+// Precision 15
+function Extended2Str( E: Extended ): KOLString;
+ function UnpackFromBuf( const Buf: array of Byte; N: Integer ): KOLString;
+ var I, J, K, L: Integer;
+ begin
+ SetLength( Result, 16 );
+ J := 1;
+ for I := 7 downto 0 do
+ begin
+ K := Buf[ I ] shr 4;
+ Result[ J ] := KOLChar( Ord('0') + K );
+ Inc( J );
+ K := Buf[ I ] and $F;
+ Result[ J ] := KOLChar( Ord('0') + K );
+ Inc( J );
+ end;
+ //Assert( Result[ 1 ] = '0', 'error!' );
+ Delete( Result, 1, 1 );
+ if N <= 0 then
+ begin
+ while N < 0 do
+ begin
+ Result := '0' + Result;
+ Inc( N );
+ end;
+ Result := '0.' + Result;
+ end else
+ if N < Length( Result ) then
+ begin
+ Result := Copy( Result, 1, N ) + '.' + CopyEnd( Result, N + 1 );
+ end else
+ begin
+ while N > Length( Result ) do
+ begin
+ Result := Result + '0';
+ end;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ L := Length( Result );
+ while L > 1 do
+ begin
+ if (Result[ L ] <> '0')
+ and (Result[ L ] <> '.') then
+ break;
+ Dec( L );
+ if Result[ L + 1 ] = '.' then break;
+ end;
+ if L < Length( Result ) then Delete( Result, L + 1, MaxInt );
+ end;
+var
+ S: Boolean;
+var F: Extended;
+ N: Integer;
+ Buf1: array[ 0..9 ] of Byte;
+ I10: Integer;
+begin
+ Result := '0';
+ if E = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ S := E < 0;
+ if S then E := -E;
+
+ N := 15;
+ F := 5E12;
+ I10 := 10;
+ while E < F do
+ begin
+ Dec( N );
+ E := E * I10;
+ end;
+ if N = 15 then
+ while E >= 1E13 do
+ begin
+ Inc( N );
+ E := E / I10;
+ end;
+
+ while TRUE do
+ begin
+ {$IFDEF PAS_ONLY}
+ if TRUNC(Abs(E)) >= 10000000 then
+ break;
+ {$ELSE}
+ asm
+ FLD [E]
+ FBSTP [Buf1]
+ end;
+ if Buf1[ 7 ] <> 0 then break;
+ {$ENDIF}
+ E := E * I10;
+ Dec( N );
+ end;
+ Result := UnpackFromBuf( Buf1, N );
+ if S then Result := '-' + Result;
+end;
+
+function Extended2StrDigits( D: Double; n: Integer ): KOLString;
+var i, m: Integer;
+label start;
+begin
+start:
+ Result := Extended2Str( D );
+ i := IndexOfChar( Result, '.' ); //pos( '.', Result );
+ if n <= 0 then
+ begin
+ if i <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ delete( Result, i, MaxInt );
+ end else
+ begin
+ if i <= 0 then
+ begin
+ i := Length( Result ) + 1;
+ Result := Result + '.';
+ end;
+ if Length( Result ) - i < n then
+ Result := Result + StrRepeat( '0', n + i - Length( Result ) )
+ else
+ begin
+ m := i + n;
+ if Length( Result ) <= m then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if (Result[m+1] > '5')
+ or (Length( Result ) > m+1)
+ and (Result[m+2] > '0') then
+ begin
+ n := m;
+ inc( Result[n] );
+ while Result[n] > '9' do
+ begin
+ Result[n] := '0';
+ dec( n );
+ if n = 0 then
+ begin
+ Result := '1' + Result;
+ break;
+ end;
+ if Result[n] = '.' then dec(n);
+ inc( Result[n] );
+ end;
+ end;
+ delete( Result, m+1, MaxInt );
+ end;
+ end;
+end;
+
+function Double2Str( D: Double ): KOLString;
+begin
+ Result := Extended2Str( D );
+end;
+
+function Double2StrEx( D: Double ): KOLString;
+var E, E1, E2: Double;
+ S: KOLString;
+begin
+ Result := Double2Str( D );
+ E := Str2Double( Result );
+ E1 := E - D;
+ if E1 < 0.0 then E1 := -E1;
+ if E1 < 1e-307 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ while TRUE do
+ begin
+ E := D - (E - D) * 0.3;
+ S := Double2Str( E );
+ if S = Result then break;
+ E := Str2Double( S );
+ E2 := E - D;
+ if E2 < 0.0 then E2 := -E2;
+ if E2 > E1 * 0.75 then break;
+ Result := S;
+ if E2 < E1 * 0.1 then break;
+ end;
+end;
+
+function GetBits( N: DWORD; first, last: Byte ): DWord;
+{$IFDEF F_P}
+begin
+ Result := 0;
+ if last > 31 then last := 31;
+ if first > last then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := (N and not ($FFFFFFFF shl last)) shr first;
+end;
+{$ELSE DELPHI}
+asm
+ XCHG EAX, EDX // (1) EDX=N, AL=first
+ {$IFDEF PARANOIA} DB $3C, 31 {$ELSE} CMP AL, 31 {$ENDIF} // first(AL) > 31 ?
+ JBE @@1 // (2) если да, то Result := 0;
+@@0:
+ XOR EAX, EAX // (2)
+ RET // (1)
+@@1:
+
+ XCHG EAX, ECX // (1) AL = last CL = first
+ SHR EDX, CL // (2) EDX = N shr first
+ SUB AL, CL // (2) AL = last - first
+ JL @@0 // (2) если last < first то Result := 0;
+
+ {$IFDEF PARANOIA} DB $3C, 32 {$ELSE} CMP AL, 32 {$ENDIF} // (2) last - first >= 32 ?
+ XCHG ECX, EAX // (1) CL = last - first
+ XCHG EAX, EDX // (1) EAX = N shr first
+ JAE @@exit // (2) если last - first > 31, то Result := EAX;
+ SBB EDX, EDX // (2) EDX = -1
+ DEC EDX // (1) EDX = 1111...10 = -2
+ SHL EDX, CL // (2) EDX = 111...100..0 (где n(0)=last-first+1)
+ NOT EDX // (2) EDX = маска 000..0111...1 (где n(1)=last-first+1)
+ AND EAX, EDX // (2)
+@@exit:
+ // EAX = результат, (1 байт на команду RET)
+end;
+{$ENDIF F_P/DELPHI}
+
+function GetBitsL( N: DWORD; from, len: Byte ): DWord;
+{$IFDEF F_P}
+begin
+ Result := GetBits( N, from, from + len - 1 );
+end;
+{$ELSE DELPHI}
+asm
+ ADD CL, DL
+ DEC CL
+ JMP GetBits
+end;
+{$ENDIF F_P/DELPHI}
+
+{$IFNDEF FPC}
+function MulDiv( A, B, C: Integer ): Integer;
+asm
+ IMUL EDX
+ IDIV ECX
+end;
+{$ENDIF}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION}
+function Int2Hex( Value : DWord; Digits : Integer ) : KOLString;
+const
+ HexDigitChr: array[ 0..15 ] of KOLChar = ( '0','1','2','3','4','5','6','7',
+ '8','9','A','B','C','D','E','F' );
+var Buf: array[ 0..8 ] of KOLChar;
+ Dest : PKOLChar;
+begin
+ Dest := @Buf[ 8 ];
+ Dest^ := #0;
+ repeat
+ Dec( Dest );
+ Dest^ := '0';
+ if Value <> 0 then
+ begin
+ Dest^ := HexDigitChr[ Value and $F ];
+ Value := Value shr 4;
+ end;
+ Dec( Digits );
+ until (Value = 0) and (Digits <= 0);
+ Result := Dest;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function Hex2Int( const Value : KOLString) : Integer;
+var I : Integer;
+begin
+ Result := 0;
+ I := 1;
+ if Value = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Value[ 1 ] = '$' then Inc( I );
+ while I <= Length( Value ) do
+ begin
+ if (Value[ I ] >= '0')
+ and (Value[ I ] <= '9') then
+ Result := (Result shl 4) or (Ord(Value[I]) - Ord('0'))
+ else if (Value[ I ] >= 'A')
+ and (Value[ I ] <= 'F') then
+ Result := (Result shl 4) or (Ord(Value[I]) - Ord('A') + 10)
+ else if (Value[ I ] >= 'a')
+ and (Value[ I ] <= 'f') then
+ Result := (Result shl 4) or (Ord(Value[I]) - Ord('a') + 10)
+ else break;
+ Inc( I );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function Octal2Int( const Value: AnsiString ) : Integer;
+var I: Integer;
+begin
+ Result := 0;
+ for I := 1 to Length( Value ) do
+ begin
+ if (Value[ I ] >= '0') and (Value[ I ] <= '7') then
+ Result := Result * 8 + Ord( Value[ I ] ) - Ord( '0' )
+ else break;
+ end;
+end;
+
+function Binary2Int( const Value: AnsiString ) : Integer;
+var I: Integer;
+begin
+ Result := 0;
+ for I := 1 to Length( Value ) do
+ begin
+ if (Value[ I ] = '0') or (Value[ I ] = '1') then
+ Result := Result * 2 + Ord( Value[ I ] ) - Ord( '0' )
+ else break;
+ end;
+end;
+
+function ToRadix( number: Radix_Int; radix: Integer; min_digits: Integer ): KOLString;
+var Buf: array[ 0..64 ] of KOLChar;
+ p: PKOLChar;
+ n: Integer;
+ {$IFDEF _D5orHigher}
+ numd: Extended;
+ {$ENDIF}
+begin
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( (radix >= 2) and (radix <= 36), 'Radix base must be between 2 and 36' );
+ Assert( min_digits <= 64, 'Maximum possible digits number is 64' );
+ {$ENDIF KOL_ASSERTIONS}
+ p := @ Buf[ 64 ];
+ p^ := #0;
+ while (number <> 0) do
+ begin
+ dec( p );
+ {$IFDEF _D5orHigher}
+ if number < 0 then
+ begin
+ numd := 1.0 * I64( number ).Hi * $10000 * $10000 + I64( number ).Lo;
+ number := Round( numd / radix );
+ n := Round( numd - 1.0 * number * radix );
+ if n < 0 then
+ begin
+ n := radix + n;
+ dec( number );
+ end;
+ end else
+ {$ENDIF}
+ begin
+ n := number mod radix;
+ number := number div radix;
+ end;
+ if n <= 9 then p^ := KOLChar( n + Ord( '0' ) )
+ else p^ := KOLChar( n - 10 + Ord( 'A' ) );
+ dec( min_digits );
+ end;
+ while (min_digits > 0) do
+ begin
+ dec( p );
+ p^ := '0';
+ dec( min_digits );
+ end;
+ Result := p;
+end;
+
+function FromRadixStr( var Rslt: Radix_int; s: PKOLChar; radix: Integer ): PKOLChar;
+var n: Integer;
+begin
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( (radix >= 2) and (radix <= 36), 'Radix base must be between 2 and 36' );
+ {$ENDIF KOL_ASSERTIONS}
+ Rslt := 0;
+ while s^ <> #0 do
+ begin
+ CASE s^ OF
+ '0'..'9': n := Ord( s^ ) - Ord( '0' );
+ 'a'..'z': n := Ord( s^ ) - Ord( 'a' ) + 10;
+ 'A'..'Z': n := Ord( s^ ) - Ord( 'A' ) + 10;
+ else n := 100;
+ END;
+ if n >= radix then break;
+ Rslt := Rslt * radix + n;
+ inc( s );
+ end;
+ Result := s;
+end;
+
+function FromRadix( const s: AnsiString; radix: Integer ): Radix_int;
+begin
+ Result := 0;
+ if s = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FromRadixStr( Result, @ s[ 1 ], radix );
+end;
+
+function InsertSeparators( const s: KOLString; chars_between: Integer; Separator: KOLChar ): KOLString;
+var L, from_L, n: Integer;
+begin
+ if (s = '') or (chars_between <= 0) then
+ begin
+ Result := s;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ From_L := Length( s );
+ L := From_L + From_L div chars_between;
+ SetLength( Result, L );
+ while L >= 1 do
+ begin
+ for n := 1 to chars_between do
+ begin
+ Result[ L ] := s[ from_L ];
+ dec( L );
+ dec( from_L );
+ if L < 1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result[ L ] := Separator;
+ dec( L );
+ end;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+function cHex2Int( const Value : KOLString) : Integer;
+begin
+ if (Length(Value)>2) and (Value[1]='0')
+ and ((Value[2]='x') or (Value[2]='X')) then
+ Result := Hex2Int( CopyEnd( Value, 3 ) )
+ else Result := Hex2Int( Value );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function Int2Str( Value : Integer ) : KOLString;
+var Buf : Array[ 0..15 ] of KOLChar;
+ Dst : PKOLChar;
+ Minus : Boolean;
+ D: DWORD;
+begin
+ Dst := @Buf[ 15 ];
+ Dst^ := #0;
+ Minus := False;
+ if Value < 0 then
+ begin
+ Value := -Value;
+ Minus := True;
+ end;
+ D := Value;
+ repeat
+ Dec( Dst );
+ Dst^ := KOLChar( (D mod 10) + Byte( '0' ) );
+ D := D div 10;
+ until D = 0;
+ if Minus then
+ begin
+ Dec( Dst );
+ Dst^ := '-';
+ end;
+ Result := Dst;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure Int2PChar( s: PAnsiChar; Value: Integer );
+var Buf : array[ 0..15 ] of AnsiChar;
+ Dst : PAnsiChar;
+ Minus : Boolean;
+ D: DWORD;
+begin
+ Dst := @Buf[ 15 ];
+ Dst^ := #0;
+ Minus := False;
+ if Value < 0 then
+ begin
+ Value := -Value;
+ Minus := True;
+ end;
+ D := Value;
+ repeat
+ Dec( Dst );
+ Dst^ := AnsiChar( (D mod 10) + Byte( '0' ) );
+ D := D div 10;
+ until D = 0;
+ if Minus then
+ begin
+ Dec( Dst );
+ Dst^ := '-';
+ end;
+ StrCopy( s, Dst );
+end;
+
+function UInt2Str( Value: DWORD ): AnsiString;
+var Buf : Array[ 0..15 ] of AnsiChar;
+ Dst : PAnsiChar;
+ D: DWORD;
+begin
+ Dst := @Buf[ 15 ];
+ Dst^ := #0;
+ D := Value;
+ repeat
+ Dec( Dst );
+ Dst^ := AnsiChar( (D mod 10) + Byte( '0' ) );
+ D := D div 10;
+ until D = 0;
+ Result := Dst;
+end;
+
+function Int2StrEx( Value, MinWidth: Integer ): KOLString;
+begin
+ Result := Int2Str( Value );
+ while Length( Result ) < MinWidth do
+ Result := ' ' + Result;
+end;
+
+function Int2Rome( Value: Integer ): KOLString;
+const RomeDigs = KOLString('IVXLCDMT');
+ function RomeNum( N, FromIdx: Integer ): KOLString;
+ begin
+ CASE N OF
+ 1, 2, 3: Result := StrRepeat( RomeDigs[ FromIdx ], N );
+ 4: Result := KOLString('') + KOLString(RomeDigs[ FromIdx ]) +
+ KOLString(RomeDigs[ FromIdx + 1 ]);
+ 5, 6, 7, 8: Result := KOLString(RomeDigs[ FromIdx + 1 ]) +
+ StrRepeat( RomeDigs[ FromIdx ], N - 5 );
+ 9: Result := KOLString('') + KOLString(RomeDigs[ FromIdx ]) +
+ KOLString(RomeDigs[ FromIdx + 2 ]);
+ else Result := '';
+ END;
+ end;
+var I, J: Integer;
+begin
+ Result := '';
+ if Value < 1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Value > 8999 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ // maximum possible is TMMMCMXCIX, i.e. 8999
+ J := 1;
+ for I := 1 to 3 do
+ begin
+ Result := RomeNum( Value mod 10, J ) + Result;
+ Value := Value div 10;
+ if Value = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Inc( J, 2 );
+ end;
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION}
+function Int2Ths( I : Integer ): KOLString;
+var S : KOLString;
+begin
+ S := Int2Str( I );
+ Result := '';
+ while S <> '' do
+ begin
+ if Result <> '' then
+ Result := KOLString(ThsSeparator) + Result;
+ Result := CopyTail( S, 3 ) + Result;
+ S := Copy( S, 1, Length( S ) - 3 );
+ end;
+ if Copy( Result, 1, 2 ) = KOLString('-') + KOLString(ThsSeparator) then
+ Result := '-' + CopyEnd( Result, 3 );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function Int2Digs( Value, Digits : Integer ) : KOLString;
+var M : KOLString;
+begin
+ Result := Int2Str( Value );
+ M := '';
+ if Value < 0 then
+ begin
+ M := '-';
+ Result := CopyEnd( Result, 2 );
+ end;
+ if Digits >= 0 then
+ while Length( M + Result ) < Digits do
+ Result := '0' + Result
+ else
+ while Length( Result ) < -Digits do
+ Result := '0' + Result;
+ Result := M + Result;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+{$IFDEF _D2009orHigher} const Suffix: AnsiString = 'KMGT';
+{$ELSE} const Suffix = 'KMGT'; {$ENDIF}
+function Num2Bytes( Value : Double ) : KOLString;
+var V, I : Integer;
+begin
+ Result := '';
+ I := 0;
+ while (Value >= 1024) and (I < 4) do
+ begin
+ Inc( I );
+ Value := Value / 1024.0;
+ end;
+ Result := Int2Str( Trunc( Value ) );
+ V := Trunc( (Value - Trunc( Value )) * 100 );
+ if V <> 0 then
+ begin
+ if (V mod 10) = 0 then
+ V := V div 10;
+ Result := Result + ',' + Int2Str( V );
+ end;
+ if I > 0 then
+ Result := Result + KOLString( Suffix[ I ] );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function S2Int( S: PKOLChar ): Integer;
+var M : Integer;
+begin
+ Result := 0;
+ if S = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ M := 1;
+ if S^ = '-' then
+ begin
+ M := -1;
+ Inc( S );
+ end else
+ if S^ = '+' then
+ Inc( S );
+ while (S^>='0') and (S^<='9') do
+ begin
+ Result := Result * 10 + Integer( S^ ) - Integer( '0' );
+ Inc( S );
+ end;
+ if M < 0 then Result := -Result;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function Str2Int(const Value : KOLString) : Integer;
+begin
+ Result := S2Int( PKOLChar( Value ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF PAS_ONLY}
+function StrCopy( Dest, Source: PAnsiChar ): PAnsiChar;
+var L: Integer;
+begin
+ L := StrLen(Source);
+ Move(Source^, Dest^, L+1);
+ Result := Dest;
+end;
+{$ELSE}
+function StrCopy( Dest, Source: PAnsiChar ): PAnsiChar; assembler;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [Dest]
+ MOV EDX, [Source]
+ {$ENDIF F_P}
+ PUSH EDI
+ PUSH ESI
+ MOV ESI,EAX
+ MOV EDI,EDX
+ OR ECX, -1
+ XOR AL,AL
+ REPNE SCASB
+ NOT ECX
+ MOV EDI,ESI
+ MOV ESI,EDX
+ MOV EDX,ECX
+ MOV EAX,EDI
+ SHR ECX,2
+ REP MOVSD
+ MOV ECX,EDX
+ AND ECX,3
+ REP MOVSB
+ POP ESI
+ POP EDI
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$ENDIF PAS_ONLY}
+
+function StrCat( Dest, Source: PAnsiChar ): PAnsiChar;
+begin
+ StrCopy( StrScan( Dest, #0 ), Source );
+ Result := Dest;
+end;
+
+{$IFDEF PAS_ONLY}
+function StrScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar;
+begin
+ while Str^ <> Chr do
+ begin
+ if Str^ = #0 then break;
+ inc(Str);
+ end;
+ Result := Str;
+end;
+{$ELSE}
+function StrScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; assembler;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [Str]
+ MOVZX EDX, [Chr]
+ {$ENDIF}
+ PUSH EDI
+ PUSH EAX
+ MOV EDI,Str
+ OR ECX, -1
+ XOR AL,AL
+ REPNE SCASB
+ NOT ECX
+ POP EDI
+ XCHG EAX, EDX
+ REPNE SCASB
+
+ XCHG EAX, EDI
+ POP EDI
+
+ JE @@1
+ XOR EAX, EAX
+ RET
+
+@@1: DEC EAX
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$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
+ {$IFDEF F_P}
+ MOV EAX, [Str]
+ MOVZX EDX, [Chr]
+ {$ENDIF F_P}
+ PUSH EDI
+ MOV EDI,Str
+ MOV ECX,0FFFFFFFFH
+ XOR AL,AL
+ REPNE SCASB
+ NOT ECX
+ STD
+ DEC EDI
+ MOV AL,Chr
+ REPNE SCASB
+ MOV EAX,0
+ JNE @@1
+ MOV EAX,EDI
+ INC EAX
+@@1: CLD
+ POP EDI
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$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 break;
+ inc(Str);
+ dec(Len);
+ end;
+ Result := Str;
+end;
+{$ELSE}
+function StrScanLen(Str: PAnsiChar; Chr: AnsiChar; Len: Integer): PAnsiChar; assembler;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [Str]
+ MOVZX EDX, [Chr]
+ MOV ECX, [Len]
+ {$ENDIF F_P}
+ PUSH EDI
+ XCHG EDI, EAX
+ XCHG EAX, EDX
+ REPNE SCASB
+ XCHG EAX, EDI
+ POP EDI
+ { -> EAX => to next character after found or to the end of Str,
+ ZF = 0 if character found. }
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$ENDIF}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TrimLeft(const S: KOLString): KOLString;
+var
+ I, L: Integer;
+begin
+ L := Length(S);
+ I := 1;
+ while (I <= L) and (S[I] <= ' ') do Inc(I);
+ Result := Copy(S, I, Maxint);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TrimRight(const S: KOLString): KOLString;
+var
+ I: Integer;
+begin
+ I := Length(S);
+ while (I > 0) and (S[I] <= ' ') do Dec(I);
+ Result := Copy(S, 1, I);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+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
+ {$IFDEF F_P}
+ MOV EAX, [S]
+ {$ENDIF}
+ XOR ECX, ECX
+@@1:
+ MOV CL, byte ptr [EAX]
+ JECXZ @@exit {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ SUB CL, 'A'
+ CMP CL, 'Z'-'A'
+ JA @@2
+ ADD byte ptr [EAX], 32
+@@2: INC EAX
+ JMP @@1
+@@exit:
+end {$IFDEF F_P} [ 'EAX', 'ECX' ] {$ENDIF};
+{$ENDIF PAS_ONLY}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function LowerCase(const S: Ansistring): Ansistring;
+var I : Integer;
+begin
+ Result := S;
+ for I := 1 to Length( S ) do
+ if (Result[ I ] >= 'A') and (Result[ I ] <= 'Z') then
+ Inc( Result[ I ], 32 );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function UpperCase(const S: Ansistring): Ansistring;
+var I : Integer;
+begin
+ Result := S;
+ for I := 1 to Length( S ) do
+ if (Result[ I ] >= 'a') and (Result[ I ] <= 'z') then
+ Dec( Result[ I ], 32 );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF F_P}
+function DummyStrFun( const S: AnsiString ): AnsiString;
+begin
+ Result := S;
+end;
+{$ENDIF F_P}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function CopyEnd( const S : KOLString; Idx : Integer ) : KOLString;
+begin
+ Result := Copy( S, Idx, MaxInt );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function CopyTail( const S : KOLString; Len : Integer ) : KOLString;
+var L : Integer;
+begin
+ L := Length( S );
+ if L < Len then
+ Len := L;
+ Result := '';
+ if Len = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := Copy( S, L - Len + 1, Len );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+procedure DeleteTail( var S : KOLString; Len : Integer );
+var L : Integer;
+begin
+ L := Length( S );
+ if Len > L then
+ Len := L;
+ Delete( S, L - Len + 1, Len );
+end;
+{$ENDIF 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;
+begin
+ Result := -1;
+ if S = '' then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ l := Length(S);
+ for I := 1 to l do
+ begin
+ if S[I] = Chr then
+ begin
+ Result := I;
+ break;
+ end;
+ 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 := Integer( F ) - Integer( 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 := Integer( F ) - Integer( 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}
+
+{$IFDEF _D3orHigher}
+function WIndexOfChar( const S : KOLWideString; Chr : WideChar ) : Integer;
+var i, l : integer;
+begin
+ Result := -1;
+ if S = '' then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ l := Length(S);
+ for I := 1 to l do
+ begin
+ if S[I] = Chr then
+ begin
+ Result := I;
+ break;
+ end;
+ end;
+end;
+{$ENDIF}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function IndexOfCharsMin( const S, Chars : KOLString ) : Integer;
+var I, J : Integer;
+begin
+ Result := -1;
+ for I := 1 to Length( Chars ) do
+ begin
+ J := IndexOfChar( S, Chars[ I ] );
+ if J > 0 then
+ begin
+ if (Result <= 0) or (J < Result) then
+ Result := J;
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF _D3orHigher}
+function WIndexOfCharsMin( const S, Chars : KOLWideString ) : Integer;
+var I, J : Integer;
+begin
+ Result := -1;
+ for I := 1 to Length( Chars ) do
+ begin
+ J := WIndexOfChar( S, Chars[ I ] );
+ if J > 0 then
+ begin
+ if (Result <= 0) or (J < Result) then
+ Result := J;
+ end;
+ end;
+end;
+{$ENDIF}
+
+{$IFNDEF _FPC}
+{$IFNDEF _D2}
+function IndexOfWideCharsMin( const S, Chars : KOLWideString ) : Integer;
+var I, J : Integer;
+begin
+ Result := -1;
+ for I := 1 to Length( Chars ) do
+ begin
+ J := pos( Chars[ I ], S );
+ if J > 0 then
+ begin
+ if (Result < 0) or (J < Result) then
+ Result := J;
+ end;
+ end;
+end;
+{$ENDIF _D2}
+{$ENDIF _FPC}
+
+ {$DEFINE ASM_LOCAL}
+{$IFDEF PAS_VERSION} {$UNDEF ASM_LOCAL}{$ENDIF}
+{$IFDEF UNICODE_CTRLS}{$UNDEF ASM_LOCAL}{$ENDIF}
+{$IFDEF _D2} {$UNDEF ASM_LOCAL}{$ENDIF}
+{$IFDEF _D3} {$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;
+var Pos : Integer;
+begin
+ Pos := IndexOfCharsMin( S, Separators );
+ if Pos <= 0 then
+ Pos := Length( S )+1;
+ Result := Copy( S, 1, Pos-1 );
+ Delete( S, 1, Pos );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF _D3orHigher}
+function ParseW( var S : KOLWideString; const Separators : KOLWideString ) : KOLWideString;
+var Pos : Integer;
+begin
+ Pos := WIndexOfCharsMin( S, Separators );
+ if Pos <= 0 then
+ Pos := Length( S )+1;
+ Result := Copy( S, 1, Pos-1 );
+ Delete( S, 1, Pos );
+end;
+{$ENDIF}
+
+{$IFNDEF _FPC}
+{$IFNDEF _D2}
+function WParse( var S : KOLWideString; const Separators : KOLWideString ) : KOLWideString;
+var Pos : Integer;
+begin
+ Pos := IndexOfWideCharsMin( S, Separators );
+ if Pos <= 0 then
+ Pos := Length( S ) + 1;
+ Result := S;
+ S := Copy( Result, Pos + 1, MaxInt );
+ Result := Copy( Result, 1, Pos - 1 );
+end;
+{$ENDIF _D2}
+{$ENDIF _FPC}
+
+function ParsePascalString( var S : KOLString; const Separators : KOLString ) : KOLString;
+var Pos, Idx : Integer;
+ Hex, Spc : Boolean;
+ procedure SkipSpaces;
+ begin
+ if not Spc then
+ while (Length( S ) >= Pos) and (S[ Pos ] = ' ') do
+ Inc( Pos );
+ end;
+var Buf : KOLString;
+ Ou, Val : Integer;
+begin
+ Pos := 1;
+ Spc := IndexOfChar( Separators, ' ' ) >= 0;
+ SkipSpaces;
+ if Length( S ) < Pos then
+ begin
+ Result := S;
+ S := '';
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Buf := PKOLChar( S );
+ Ou := 1;
+ if (S[ Pos ] = '''') or (S[ Pos ] = '#') then
+ begin
+ // skip here string constant expression
+ while Pos <= Length( S ) do
+ begin
+ if S[ Pos ] = '''' then
+ begin
+ Inc( Pos );
+ while Pos <= Length( S ) do
+ begin
+ if S[ Pos ] = '''' then
+ if (Pos = Length( S )) or (S[ Pos+1 ] <> '''') then
+ begin
+ Inc( Pos );
+ break;
+ end else Inc( Pos );
+ Buf[ Ou ] := S[ Pos ];
+ Inc( Ou );
+ Inc( Pos );
+ end;
+ end else
+ if S[ Pos ] = '#' then
+ begin
+ Inc( Pos ); Hex := False; Val := 0;
+ if (Pos < Length( S )) and (S[ Pos ] = '$') then
+ begin
+ Inc( Pos ); Hex := True;
+ end;
+ Dec( Pos );
+ while Pos < Length( S ) do
+ begin
+ Inc( Pos );
+ if (S[ Pos ] >= '0') and (S[ Pos ] <= '9') or
+ Hex and ( (S[ Pos ] >= 'a') and (S[ Pos ] <= 'f') or
+ (S[ Pos ] >= 'A') and (S[ Pos ] <= 'F') ) then
+ begin
+ if Hex then
+ Val := Val * 16
+ else Val := Val * 10;
+ if S[ Pos ] <= '9' then
+ Val := Val + Integer( S[ Pos ] ) - Integer( '0' )
+ else if S[ Pos ] <= 'F' then
+ Val := Val + 10 + Integer( S[ Pos ] ) - Integer( 'A' )
+ else Val := Val + 10 + Integer( S[ Pos ] ) - Integer( 'a' );
+ continue;
+ end;
+ Inc( Pos ); break;
+ end;
+ Buf[ Ou ] := KOLChar( Val );
+ Inc( Ou );
+ end else break;
+ SkipSpaces;
+ if S[ Pos ] <> '+' then break;
+ SkipSpaces;
+ end;
+ end;
+ Idx := IndexOfCharsMin( CopyEnd( S, Pos ), Separators );
+ if Idx <= 0 then
+ begin
+ Result := Copy( Buf, 1, Ou - 1 ) + CopyEnd( S, Pos );
+ S := '';
+ end else
+ begin
+ Result := Copy( Buf, 1, Ou - 1 ) + Copy( S, Pos, Idx - 1 );
+ S := CopyEnd( S, Pos + Idx );
+ end;
+end;
+
+function String2PascalStrExpr( const S : KOLString ) : KOLString;
+var I, Strt : Integer;
+ function String2DoubleQuotas( const S : KOLString ) : KOLString;
+ var I, J : Integer;
+ begin
+ if IndexOfChar( S, '''' ) <= 0 then
+ Result := S
+ else
+ begin
+ J := 0;
+ for I := 1 to Length( S ) do
+ if S[ I ] = '''' then Inc( J );
+ SetLength( Result, Length( S ) + J );
+ J := 1;
+ for I := 1 to Length( S ) do
+ begin
+ Result[ J ] := S[ I ];
+ Inc( J );
+ if S[ I ] = '''' then
+ begin
+ Result[ J ] := '''';
+ Inc( J );
+ end;
+ end;
+ end;
+ end;
+begin
+ Result := '';
+ if S = '' then
+ begin
+ Result := '''''';
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Strt := 1;
+ for I := 1 to Length( S ) + 1 do
+ begin
+ if (I > Length( S )) or (S[ I ] < ' ') or (S[ I ] >= #$7F) then
+ begin
+ if (I > Strt) and (I > 1) then
+ begin
+ if Result <> '' then
+ Result := Result + '+';
+ Result := Result + '''' + String2DoubleQuotas( Copy( S, Strt, I - Strt ) ) + '''';
+ end;
+ if I > Length( S ) then break;
+ if Result <> '' then
+ Result := Result + '+'
+ else Result := Result + '''''+';
+ Result := Result + '#' + Int2Str( Integer( S[ I ] ) );
+ Strt := I + 1;
+ end;
+ end;
+end;
+
+{$IFDEF PAS_ONLY}
+function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;
+var PP1, PP2: PByte;
+begin
+ Result := FALSE;
+ PP1 := P1;
+ PP2 := P2;
+ while (Length > 0) do
+ begin
+ if (PP1^ <> PP2^) then
+ Exit; //>>>>>>>>>>>>>>>>>>>>>>>>
+ inc(PP1);
+ inc(PP2);
+ dec(Length);
+ end;
+ Result := TRUE;
+end;
+{$ELSE}
+function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [P1]
+ MOV EDX, [P2]
+ MOV ECX, [Length]
+ {$ENDIF}
+ PUSH ESI
+ PUSH EDI
+ MOV ESI,P1
+ MOV EDI,P2
+ MOV EDX,ECX
+ XOR EAX,EAX
+ AND EDX,3
+ SHR ECX,1
+ SHR ECX,1
+ REPE CMPSD
+ JNE @@2
+ MOV ECX,EDX
+ REPE CMPSB
+ JNE @@2
+@@1: INC EAX
+@@2: POP EDI
+ POP ESI
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$ENDIF}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function AllocMem( Size : Integer ) : Pointer;
+begin
+ Result := nil;
+ if Size > 0 then
+ begin
+ GetMem( Result, Size );
+ //FillChar( Result^, Size, 0 );
+ ZeroMemory( Result, Size );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure DisposeMem( var Addr : Pointer );
+begin
+ if Addr <> nil then
+ FreeMem( Addr );
+ Addr := nil;
+end;
+
+{$IFDEF WIN}
+function AnsiUpperCase(const S: AnsiString): AnsiString;
+var Len: Integer;
+begin
+ Len := Length(S);
+ SetString(Result, PAnsiChar(S), Len);
+ if Len > 0 then CharUpperBuffA(Pointer(Result), Len);
+end;
+
+function AnsiLowerCase(const S: Ansistring): Ansistring;
+var
+ Len: Integer;
+begin
+ Len := Length(S);
+ SetString(Result, PAnsiChar(S), Len);
+ if Len > 0 then CharLowerBuffA(Pointer(Result), Len);
+end;
+
+function KOLUpperCase(const S: KOLString): KOLString;
+var Len: Integer;
+begin
+ Len := Length(S);
+ SetString(Result, PKOLChar( S ), Len);
+ if Len > 0 then CharUpperBuff(PKOLChar(Result), Len);
+end;
+
+function KOLLowerCase(const S: KOLString): KOLString;
+var
+ Len: Integer;
+begin
+ Len := Length(S);
+ SetString(Result, PKOLChar(S), Len);
+ if Len > 0 then CharLowerBuff(PKOLChar(Result), Len);
+end;
+
+{$IFDEF _D3orHigher}
+function WUpperCase(const S: KOLWideString): KOLWideString;
+var Len: Integer;
+begin
+ Len := Length(S);
+ SetString(Result, PWideChar( S ), Len);
+ if Len > 0 then CharUpperBuffW(PWideChar(Result), Len);
+end;
+
+function WLowerCase(const S: KOLWideString): KOLWideString;
+var
+ Len: Integer;
+begin
+ Len := Length(S);
+ SetString(Result, PWideChar(S), Len);
+ if Len > 0 then CharLowerBuffW(PWideChar(Result), Len);
+end;
+{$ENDIF}
+{$ENDIF WIN}
+
+{$IFNDEF _D2}
+{$IFNDEF _FPC}
+
+{$IFDEF WIN}
+function WAnsiUpperCase(const S: KOLWideString): KOLWideString;
+var Len: Integer;
+begin
+ Result := S;
+ Len := Length(S);
+ if Len > 0 then CharUpperBuffW(Pointer(Result), Len);
+end;
+{$ENDIF WIN}
+
+{$IFDEF WIN}
+function WAnsiLowerCase(const S: KOLWideString): KOLWideString;
+var Len: Integer;
+begin
+ Result := S;
+ Len := Length(S);
+ if Len > 0 then CharLowerBuffW(Pointer(Result), Len);
+end;
+{$ENDIF WIN}
+
+{$IFDEF WIN}
+function WStrComp(const S1, S2: KOLWideString): Integer;
+var i: Integer;
+begin
+ for i := 1 to min( Length( S1 ), Length( S2 ) ) do
+ begin
+ Result := Ord( S1[ i ] ) - Ord( S2[ i ] );
+ if Result <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := Length( S1 ) - Length( S2 );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE}
+function _WStrComp(S1, S2: PWideChar): Integer;
+var
+ L, R : PWideChar;
+begin
+ L := S1;
+ R := S2;
+ Result := 0;
+ repeat
+ if L^ = R^ then
+ begin
+ if L^ = #0 then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Inc(L);
+ Inc(R);
+ end else
+ begin
+ Result := (Word(L^) - Word(R^));
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ until (False);
+end;
+{$ENDIF}
+
+{$IFDEF PAS_ONLY}
+function _WStrLComp(S1, S2: PWideChar; Len: Integer): Integer;
+begin
+ while (Len > 0) and (S1^ <> #0) and (S2^ <> #0) do
+ begin
+ Result := Ord(S1^) - Ord(S2^);
+ if Result <> 0 then Exit; // >>>>>>>>>>>>>>>>>>>>
+ dec(Len);
+ end;
+ Result := 0;
+end;
+{$ELSE}
+function _WStrLComp(S1, S2: PWideChar; Len: Integer): Integer;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [S1]
+ MOV EDX, [S2]
+ MOV ECX, [Len]
+ {$ENDIF F_P}
+ PUSH EDI
+ PUSH ESI
+ MOV EDI,EDX
+ XCHG ESI,EAX
+ CMP EAX, EAX
+ REPE CMPSW
+ MOVZX EAX, word ptr [ESI-2]
+ MOVZX EDX, word ptr [EDI-2]
+ SUB EAX,EDX
+ POP ESI
+ POP EDI
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$ENDIF}
+
+function WStrScan(Str: PWideChar; Chr: WideChar): PWideChar;
+begin
+ while (Str^ <> Chr) and (Str^ <> #0) do inc( Str );
+ Result := Str;
+end;
+
+function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar;
+begin
+ Result := Str;
+ while Result^ <> #0 do inc( Result );
+ while (DWORD( Result ) >= DWORD( Str )) and
+ (Result^ <> Chr) do dec( Result );
+ if (DWORD( Result ) < DWORD( Str )) then
+ Result := nil;
+end;
+{$ENDIF WIN}
+{$ENDIF _FPC}
+{$ENDIF _D2}
+
+{$IFDEF WIN}
+function AnsiCompareStr(const S1, S2: KOLString): Integer;
+begin
+ Result := CompareString(LOCALE_USER_DEFAULT, 0, PKOLChar(S1), -1, PKOLChar(S2), -1 ) - 2;
+end;
+{$ENDIF WIN}
+
+{$IFDEF WIN}
+function AnsiCompareStrA(const S1, S2: AnsiString): Integer;
+begin
+ Result := CompareStringA(LOCALE_USER_DEFAULT, 0, PAnsiChar(S1), -1, PAnsiChar(S2), -1 ) - 2;
+end;
+{$ENDIF WIN}
+
+{$IFDEF WIN}
+function _AnsiCompareStr(S1, S2: PKOLChar): Integer;
+begin
+ Result := CompareString( LOCALE_USER_DEFAULT, 0, S1, -1,
+ S2, -1) - 2;
+end;
+{$ENDIF WIN}
+
+type
+ TSortAnsiRec = record
+ A: array[ AnsiChar ] of PAnsiChar;
+ end;
+ PSortAnsiRec = ^TSortAnsiRec;
+var SortAnsiOrderNoCase: array[ AnsiChar ] of SmallInt;
+ SortAnsiOrder: array[ AnsiChar ] of SmallInt;
+
+{$IFDEF WIN}
+function _AnsiCompareStrA_Slow(S1, S2: PAnsiChar): Integer;
+begin
+ Result := CompareStringA( LOCALE_USER_DEFAULT, 0, S1, -1,
+ S2, -1) - 2;
+end;
+{$ENDIF WIN}
+
+function CompareAnsiRec( R: PSortAnsiRec; const e1, e2: Integer ): Integer;
+begin
+ Result := _AnsiCompareStrA_Slow(
+ R.A[AnsiChar(e1)],
+ R.A[AnsiChar(e2)]
+ );
+end;
+
+procedure SwapAnsiRec( R: PSortAnsiRec; const e1, e2: Integer );
+{$IFDEF PAS_ONLY}
+var a: PAnsiChar;
+{$ENDIF}
+begin
+ {$IFDEF PAS_ONLY}
+ a := R.A[AnsiChar(e1)];
+ R.A[AnsiChar(e1)] := R.A[AnsiChar(e2)];
+ R.A[AnsiChar(e2)] := a;
+ {$ELSE}
+ Swap( Integer( R.A[AnsiChar(e1)] ),
+ Integer( R.A[AnsiChar(e2)] ) );
+ {$ENDIF}
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+function _AnsiCompareStrA_Fast2(S1, S2: PAnsiChar): Integer;
+begin
+ if S1 = nil then
+ S1 := '';
+ if S2 = nil then
+ S2 := '';
+ Result := 0;
+ while TRUE do
+ begin
+ Result := SortAnsiOrder[ S1^ ] - SortAnsiOrder[ S2^ ];
+ if Result <> 0 then break;
+ if (S1^ = #0) or (S2^ = #0) then break;
+ inc( S1 );
+ inc( S2 );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function _AnsiCompareStrA_Fast(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;
+
+{$IFDEF WIN}
+function AnsiCompareStrNoCase(const S1, S2: KOLString): Integer;
+begin
+ Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PKOLChar(S1), -1,
+ PKOLChar(S2), -1 ) - 2;
+end;
+{$ENDIF WIN}
+
+{$IFDEF WIN}
+function AnsiCompareStrNoCaseA(const S1, S2: AnsiString): Integer;
+begin
+ Result := CompareStringA(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PAnsiChar(S1), -1,
+ PAnsiChar(S2), -1 ) - 2;
+end;
+{$ENDIF WIN}
+
+{$IFDEF WIN}
+function _AnsiCompareStrNoCase(S1, S2: PKOLChar): Integer;
+begin
+ Result := CompareString( LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1,
+ S2, -1) - 2;
+end;
+{$ENDIF WIN}
+
+{$IFDEF WIN}
+function _AnsiCompareStrNoCaseA_Slow(S1, S2: PAnsiChar): Integer;
+begin
+ Result := CompareStringA( LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1,
+ S2, -1) - 2;
+end;
+{$ENDIF WIN}
+
+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}
+//{$DEFINE DEBUG_SORTFAST}
+{$IFDEF DEBUG_SORTFAST}
+var DBSF: Integer;
+{$ENDIF}
+function _AnsiCompareStrNoCaseA_Fast2(S1, S2: PAnsiChar): Integer;
+{$IFDEF DEBUG_SORTFAST}
+var S01, S02: PChar;
+{$ENDIF}
+begin
+ if S1 = nil then
+ S1 := '';
+ if S2 = nil then
+ S2 := '';
+ {$IFDEF DEBUG_SORTFAST}
+ S01 := S1;
+ S02 := S2;
+ {$ENDIF}
+ Result := 0;
+ while TRUE do
+ begin
+ Result := SortAnsiOrderNoCase[ S1^ ] - SortAnsiOrderNoCase[ S2^ ];
+ if Result <> 0 then break;
+ if (S1^ = #0) or (S2^ = #0) then break;
+ inc( S1 );
+ inc( S2 );
+ end;
+ {$IFDEF DEBUG_SORTFAST}
+ inc( DBSF );
+ if Result < 0 then
+ LogFileOutput( GetStartDir + 'LT.txt', Int2Str( DBSF ) + ': ' +
+ '"' + S01 + '" < "' + S02 + '"' )
+ else if Result > 0 then
+ LogFileOutput( GetStartDir + 'GT.txt', Int2Str( DBSF ) + ': ' +
+ '"' + S01 + '" > "' + S02 + '"' )
+ else LogFileOutput( GetStartDir + 'EQ.txt', Int2Str( DBSF ) + ': ' +
+ '"' + S01 + '" = "' + S02 + '"' )
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+function _AnsiCompareStrNoCaseA_Fast(S1, S2: PAnsiChar): Integer;
+var c: AnsiChar;
+ R: TSortAnsiRec;
+ Buf: array[ 0..767 ] of AnsiChar;
+ P: PAnsiChar;
+ {$IFDEF PAS_ONLY}
+ a: PAnsiChar;
+ {$ENDIF}
+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);
+ 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( Integer( R.A[Pred(c)] ), Integer( R.A[c] ) );
+ {$ENDIF}
+ end;
+ 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 );
+end;
+
+function AnsiCompareText( const S1, S2: KOLString ): Integer;
+begin
+ Result := AnsiCompareStrNoCase( S1, S2 );
+end;
+
+function AnsiCompareTextA( const S1, S2: AnsiString ): Integer;
+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
+ {$IFDEF F_P}
+ MOV EAX, [Dest]
+ MOV EDX, [Source]
+ MOV ECX, [MaxLen]
+ {$ENDIF F_P}
+ PUSH EDI
+ PUSH ESI
+ PUSH EBX
+ MOV ESI,EAX
+ MOV EDI,EDX
+ MOV EBX,ECX
+ XOR AL,AL
+ TEST ECX,ECX
+ JZ @@1
+ REPNE SCASB
+ JNE @@1
+ INC ECX
+@@1: SUB EBX,ECX
+ MOV EDI,ESI
+ MOV ESI,EDX
+ MOV EDX,EDI
+ MOV ECX,EBX
+ SHR ECX,2
+ REP MOVSD
+ MOV ECX,EBX
+ AND ECX,3
+ REP MOVSB
+ STOSB
+ MOV EAX,EDX
+ POP EBX
+ POP ESI
+ POP EDI
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$ENDIF}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function StrPCopy(Dest: PAnsiChar; const Source: Ansistring): PAnsiChar;
+begin
+ Result := StrLCopy(Dest, PAnsiChar(Source), Length(Source));
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function StrEq( const S1, S2 : AnsiString ) : Boolean;
+begin
+ Result := (Length( S1 ) = Length( S2 )) and
+ (LowerCase( S1 ) = LowerCase( S2 ));
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function AnsiEq( const S1, S2 : KOLString ) : Boolean;
+begin
+ Result := AnsiCompareStrNoCase( S1, S2 ) = 0;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFNDEF _D2}
+{$IFNDEF _FPC}
+function WAnsiEq( const S1, S2 : KOLWideString ) : Boolean;
+begin
+ Result := WAnsiLowerCase( S1 )=WAnsiLowerCase( S2 );
+end;
+{$ENDIF _FPC}
+{$ENDIF _D2}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function StrIn(const S: AnsiString; const A: array of AnsiString): Boolean;
+var I : Integer;
+begin
+ for I := Low( A ) to High( A ) do
+ if StrEq( S, A[ I ] ) then
+ begin
+ Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := False;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFNDEF _D2}
+{$IFNDEF _FPC}
+function WStrIn( const S : KOLWideString; const A : array of KOLWideString ) : Boolean;
+var I : Integer;
+begin
+ for I := Low( A ) to High( A ) do
+ if WAnsiEq( S, A[ I ] ) then
+ begin
+ Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := False;
+end;
+{$ENDIF _FPC}
+{$ENDIF _D2}
+
+function CharIn( C: KOLChar; const A: TSetofChar ): Boolean;
+begin
+ Result := (DWord( C ) <= 255) and (AnsiChar( C ) in A);
+end;
+
+function StrIs( const S : AnsiString; const A : Array of AnsiString; var Idx: Integer ) : Boolean;
+var I : Integer;
+begin
+ Idx := -1;
+ for I := Low( A ) to High( A ) do
+ if StrEq( S, A[ I ] ) then
+ begin
+ Idx := I;
+ Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := False;
+end;
+
+function IntIn( Value: Integer; const List: array of Integer ): Boolean;
+var I: Integer;
+begin
+ Result := FALSE;
+ for I := 0 to High( List ) do
+ begin
+ if Value = List[ I ] then
+ begin
+ Result := TRUE;
+ break;
+ end;
+ end;
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function _StrSatisfy( S, Mask : PKOLChar ) : Boolean;
+label next_char;
+begin
+next_char:
+ Result := True;
+ if (S^ = #0) and (Mask^ = #0) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if (Mask^ = '*') and (Mask[1] = #0) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if S^ = #0 then
+ begin
+ while Mask^ = '*' do
+ Inc( Mask );
+ Result := Mask^ = #0; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := False;
+ if Mask^ = #0 then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Mask^ = '?' then
+ begin
+ Inc( S ); Inc( Mask ); goto next_char;
+ end;
+ if Mask^ = '*' then
+ begin
+ Inc( Mask );
+ while S^ <> #0 do
+ begin
+ Result := _StrSatisfy( S, Mask );
+ if Result then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Inc( S );
+ end;
+ exit; // (Result = False) {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := S^ = Mask^;
+ Inc( S ); Inc( Mask );
+ if Result then goto next_char;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function StrSatisfy( const S, Mask: KOLString ): Boolean;
+begin
+ Result := FALSE;
+ if (S = '') or (Mask = '') then Exit;
+ Result := _StrSatisfy( PKOLChar( {$IFDEF UNICODE_CTRLS} WAnsiLowerCase
+ {$ELSE} AnsiLowerCase {$ENDIF} ( S ) ),
+ PKOLChar( {$IFDEF UNICODE_CTRLS} WAnsiLowerCase
+ {$ELSE} AnsiLowerCase {$ENDIF} ( Mask ) ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} // Pascal
+function _2StrSatisfy( S, Mask: PKOLChar ): Boolean;
+begin
+ Result := StrSatisfy( S, Mask );
+end;
+{$ENDIF PAS_VERSION}
+
+function StrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean;
+var I: Integer;
+begin
+ I := pos( From, S );
+ if I > 0 then
+ begin
+ S := Copy( S, 1, I - 1 ) + ReplTo + CopyEnd( S, I + Length( From ) );
+ Result := TRUE;
+ end else Result := FALSE;
+end;
+
+function KOLStrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean;
+var I: Integer;
+begin
+ I := pos( From, S );
+ if I > 0 then
+ begin
+ S := Copy( S, 1, I - 1 ) + ReplTo + CopyEnd( S, I + Length( From ) );
+ Result := TRUE;
+ end else Result := FALSE;
+end;
+
+{$IFDEF _FPC}
+procedure SetLengthW( var W: KOLWideString; NewLength: Integer );
+begin
+ while Length( W ) < NewLength do
+ W := W + ' ' + W;
+ if Length( W ) > NewLength then
+ Delete( W, NewLength + 1, Length( W ) - NewLength );
+end;
+
+function CopyW( const W: KOLWideString; From, Count: Integer ): KOLWideString;
+begin
+ Result := '';
+ if Count <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ SetLengthW( Result, Count );
+ Move( W[ From ], Result[ 1 ], Count * Sizeof( WideChar ) );
+end;
+
+function posW( const S1, S2: AnsiString ): Integer; // not used. When use, change AnsiString to WideString ?
+var I, L1: Integer;
+begin
+ L1 := Length( S1 );
+ for I := 1 to Length( S2 )-L1+1 do
+ begin
+ if Copy( S2, I, L1 ) = S1 then
+ begin
+ Result := I; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ Result := 0;
+end;
+{$ENDIF _FPC}
+
+{$IFDEF ASM_VERSION}
+ procedure DoMove(const from; var to_; count: Integer);
+ asm
+ PUSH ESI
+ PUSH EDI
+ XCHG ESI, EAX
+ MOV EDI, EDX
+ REP MOVSB
+ POP EDI
+ POP ESI
+ end;
+{$ENDIF}
+
+{$IFNDEF _FPC}
+{$IFNDEF _D2}
+function WStrReplace( var S: KOLWideString; const From, ReplTo: KOLWideString ): Boolean;
+var I: Integer;
+begin
+ I := pos( From, S );
+ if I > 0 then
+ begin
+ S := Copy( S, 1, I - 1 ) + ReplTo + Copy( S, I + Length( From ), MaxInt );
+ Result := TRUE;
+ end else Result := FALSE;
+end;
+
+function WStrRepeat( const S: KOLWideString; Count: Integer ): KOLWideString;
+var {$IFDEF ASM_VERSION} {$ELSE} I, {$ENDIF} L: Integer;
+begin
+ L := Length( S );
+ SetLength( Result, L * Count );
+ if L = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF ASM_VERSION}
+ Move( S[1], Result[1], L * Sizeof(WideChar) );
+ if Count > 1 then
+ DoMove( Result[1], Result[1+L], (Count-1)*L*Sizeof(WideChar) );
+ {$ELSE}
+ for I := 0 to Count-1 do
+ Move( S[ 1 ], Result[ 1 + I * L ], L * Sizeof( WideChar ) );
+ {$ENDIF PAS_VERSION}
+end;
+{$ENDIF _D2}
+{$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
+ L := Length( S );
+ SetLength( Result, L * Count );
+ 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
+ if S <> '' then
+ begin
+ N := 0;
+ if S[ 1 ] = #10 then
+ begin
+ S[ 1 ] := #0;
+ inc( N );
+ end;
+ for I := Length(S) downto 2 do
+ begin
+ if (S[I]=#10) and (S[I-1]<>#13) then
+ S[I] := #0;
+ if S[I] = #0 then inc( N );
+ end;
+ if N > 0 then
+ begin
+ SetLength( S, N+Length(S) );
+ J := Length(S);
+ for I := Length(S)-N downto 1 do
+ begin
+ if S[I] = #0 then
+ begin
+ S[J] := #10;
+ S[J-1] := #13;
+ dec( J );
+ end else S[J] := S[I];
+ dec(J);
+ end;
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+var Koi8_to_Ansi: array[ Char ] of AnsiChar;
+procedure Koi8ToAnsi( s: PAnsiChar );
+var c: AnsiChar;
+begin
+ if Koi8_to_Ansi[ #1 ] = #0 then
+ begin
+ for c := #1 to #255 do
+ begin
+ Koi8_to_Ansi[ c ] := c;
+ if (c >= #$C0) and (c <= #$FF) then
+ Koi8_to_Ansi[ c ] := KOI8_Rus[ c ];
+ end;
+ end;
+ while s^ <> #0 do
+ begin
+ s^ := Koi8_to_Ansi[ s^ ];
+ inc( s );
+ end;
+end;
+
+{$IFDEF PAS_ONLY}
+function StrComp(const Str1, Str2: PAnsiChar): Integer;
+var S1, S2: PAnsiChar;
+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
+ {$IFDEF F_P}
+ MOV EAX, [Str1]
+ MOV EDX, [Str2]
+ {$ENDIF F_P}
+ PUSH EDI
+ PUSH ESI
+ MOV EDI,EDX
+ XCHG ESI,EAX
+ OR ECX, -1
+ XOR EAX,EAX
+ REPNE SCASB
+ NOT ECX
+ MOV EDI,EDX
+ XOR EDX,EDX
+ REPE CMPSB
+ MOV AL,[ESI-1]
+ MOV DL,[EDI-1]
+ SUB EAX,EDX
+ POP ESI
+ POP EDI
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$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;
+ end;
+end;
+
+{$IFDEF PAS_ONLY}
+function StrLComp(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer;
+var S1, S2: PAnsiChar;
+ c1, c2: AnsiChar;
+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);
+ dec(MaxLen);
+ end;
+ Result := 0;
+end;
+
+function StrLComp_NoCase(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer;
+var S1, S2: PAnsiChar;
+ c1, c2: AnsiChar;
+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;
+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;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [Str1]
+ MOV EDX, [Str2]
+ {$ENDIF F_P}
+ PUSH EDI
+ PUSH ESI
+ MOV EDI,EDX
+ XCHG ESI,EAX
+ OR ECX, -1
+ XOR EAX,EAX
+ REPNE SCASB
+
+ NOT ECX
+ MOV EDI,EDX
+ @@0:
+ XOR EDX,EDX
+ REPE CMPSB
+ MOV AL,[ESI-1]
+ MOV AH, AL
+ SUB AH, 'a'
+ CMP AH, 25
+ JA @@1
+ SUB AL, $20
+ @@1:
+ MOV DL,[EDI-1]
+ MOV AH, DL
+ SUB AH, 'a'
+ CMP AH, 25
+ JA @@2
+ SUB DL, $20
+ @@2:
+ MOV AH, 0
+ SUB EAX,EDX
+ JNZ @@exit
+ CMP DL, 0
+ JNZ @@0
+
+ @@exit:
+ POP ESI
+ POP EDI
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+
+function StrLComp_NoCase(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [Str1]
+ MOV EDX, [Str2]
+ MOV ECX, [MaxLen]
+ {$ENDIF F_P}
+ PUSH EDI
+ PUSH ESI
+ PUSH EBX
+ MOV EDI,EDX
+ MOV ESI,EAX
+ MOV EBX,ECX
+ XOR EAX,EAX
+ OR ECX,ECX
+ JE @@exit
+ REPNE SCASB
+ SUB EBX,ECX
+ MOV ECX,EBX
+ MOV EDI,EDX
+ @@0:
+ XOR EDX,EDX
+ REPE CMPSB
+ MOV AL,[ESI-1]
+ MOV AH, AL
+ SUB AH, 'a'
+ CMP AH, 25
+ JA @@1
+ SUB AL, $20
+ @@1:
+ MOV DL,[EDI-1]
+ MOV AH, DL
+ SUB AH, 'a'
+ CMP AH, 25
+ JA @@2
+ SUB DL, $20
+ @@2:
+ MOV AH, 0
+ SUB EAX,EDX
+ JECXZ @@exit
+ JZ @@0
+
+ @@exit:
+ POP EBX
+ POP ESI
+ POP EDI
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$ELSE not SMALLER_CODE}
+function StrComp_NoCase2(const Str1, Str2: PAnsiChar): Integer;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [Str1]
+ MOV EDX, [Str2]
+ {$ENDIF F_P}
+ PUSH ESI
+ XCHG ESI, EAX
+ @@1:
+ MOVZX EAX, BYTE PTR [EDX]
+ 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
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+
+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;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [Str1]
+ MOV EDX, [Str2]
+ MOV ECX, [MaxLen]
+ {$ENDIF F_P}
+ PUSH EDI
+ PUSH ESI
+ PUSH EBX
+ MOV EDI,EDX
+ 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
+ POP EBX
+ POP ESI
+ POP EDI
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+
+function StrLComp_NoCase1(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer;
+begin
+ Init_Upper;
+ StrComp_NoCase := @StrComp_NoCase2;
+ Result := StrLComp_NoCase2( Str1, Str2, MaxLen );
+end;
+{$ENDIF}
+
+function StrLComp(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; assembler;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [Str1]
+ MOV EDX, [Str2]
+ MOV ECX, [MaxLen]
+ {$ENDIF F_P}
+ PUSH EDI
+ PUSH ESI
+ PUSH EBX
+ MOV EDI,EDX
+ MOV ESI,EAX
+ MOV EBX,ECX
+ XOR EAX,EAX
+ OR ECX,ECX
+ JE @@1
+ REPNE SCASB
+ SUB EBX,ECX
+ MOV ECX,EBX
+ MOV EDI,EDX
+ XOR EDX,EDX
+ REPE CMPSB
+ MOV AL,[ESI-1]
+ MOV DL,[EDI-1]
+ SUB EAX,EDX
+@@1: POP EBX
+ POP ESI
+ POP EDI
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$ENDIF PAS_ONLY}
+
+function StrLen(const Str: PAnsiChar): Cardinal; assembler;
+asm
+ {$IFDEF F_P}
+ MOV EAX, [Str]
+ {$ENDIF F_P}
+ XCHG EAX, EDI
+ XCHG EDX, EAX
+ OR ECX, -1
+ XOR EAX, EAX
+ CMP EAX, EDI
+ JE @@exit0
+ REPNE SCASB
+ DEC EAX
+ DEC EAX
+ SUB EAX,ECX
+@@exit0:
+ MOV EDI,EDX
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+
+{$IFDEF ASM_UNICODE}
+{$ELSE PAS_VERSION} //Pascal
+function __DelimiterLast( Str, Delimiters: PKOLChar ): PKOLChar;
+var
+ P, F : PKOLChar;
+begin
+ P := Str;
+ Result := P + {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}( Str );
+ while Delimiters^ <> #0 do
+ begin
+ F := {$IFDEF UNICODE_CTRLS} WStrRScan {$ELSE} StrRScan {$ENDIF}
+ ( P, Delimiters^ );
+ if F <> nil then
+ if (Result^ = #0) or (Integer(F) > Integer(Result)) then
+ Result := F;
+ Inc( Delimiters );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF _D3orHigher}
+function W__DelimiterLast( Str, Delimiters: PWideChar ): PWideChar;
+var
+ P, F : PWideChar;
+begin
+ P := Str;
+ Result := P + WStrLen( Str );
+ while Delimiters^ <> #0 do
+ begin
+ F := WStrRScan( P, Delimiters^ );
+ if F <> nil then
+ if (Result^ = #0) or (Integer(F) > Integer(Result)) then
+ Result := F;
+ Inc( Delimiters );
+ end;
+end;
+{$ENDIF _D3orHigher}
+
+{$IFDEF WIN}
+{$IFNDEF PARAMS_DEFAULT}
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION}
+function SkipSpaces( P: PKOLChar ): PKOLChar;
+begin
+ while (P[0] <> #0) and (P[0] <= ' ') do Inc(P);
+ Result := P;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE}
+function SkipParam(P: PKOLChar): PKOLChar;
+begin
+ P := SkipSpaces( P );
+ while P[0] > ' ' do
+ if P[0] = '"' then
+ begin
+ Inc(P);
+ while (P[0] <> #0) and (P[0] <> '"') do
+ Inc(P);
+ if P[0] <> #0 then Inc(P);
+ end else Inc(P);
+ Result := P;
+end;
+{$ENDIF}
+
+{$UNDEF ASM_LOCAL}
+{$IFDEF _D3orHigher}
+{$IFDEF ASM_UNICODE}
+ {$DEFINE ASM_LOCAL}
+{$ENDIF ASM_UNICODE}
+{$ENDIF _D3orHigher}
+
+{$IFDEF ASM_LOCAL}
+function ParamStr( Idx: Integer ): KOLString;
+asm
+ PUSH EDI
+ MOV EDI, EDX
+ TEST EAX, EAX
+ JNE @@1
+ SUB ESP, 260
+ MOV ECX, ESP
+ PUSH 260
+ PUSH ECX
+ PUSH 0
+ CALL GetModuleFileName
+ XCHG ECX, EAX
+ MOV EDX, ESP
+ MOV EAX, EDI
+ CALL System.@LStrFromPCharLen
+ ADD ESP, 260
+ JMP @@exit
+@@1:
+ PUSH EAX
+ CALL GetCommandLine
+ POP ECX
+ INC ECX
+@@loop: CALL SkipSpaces
+ MOV EDX, EAX
+ CALL SkipParam
+ LOOP @@loop
+ MOV ECX, EAX
+ SUB ECX, EDX
+ CMP ECX, 2
+ JL @@ready
+ CMP byte ptr [EDX], '"'
+ JNE @@ready
+ CMP byte ptr [EAX-1], '"'
+ JNE @@ready
+ INC EDX
+ DEC EAX
+@@ready: SUB EAX, EDX
+ XCHG ECX, EAX
+ XCHG EAX, EDI
+ CALL System.@LStrFromPCharLen
+@@exit: POP EDI
+end;
+{$ELSE PAS_VERSION}
+function ParamStr( Idx: Integer ): KOLString;
+var P, P1: PKOLChar;
+ Buffer: array[ 0..260 ] of KOLChar;
+begin
+ if Idx = 0 then
+ SetString( Result, Buffer, GetModuleFileName( 0, Buffer, Sizeof( Buffer ) ) )
+ else
+ begin
+ P := GetCommandLine;
+ repeat
+ P1 := SkipSpaces( P );
+ P := SkipParam(P1);
+ Dec(Idx);
+ until (Idx < 0); // or (P = P1);
+ if Integer(P-P1) >= 2 then
+ if (P1^ = '"') and ( (P-1)^ = '"') then
+ begin
+ inc( P1 );
+ dec( P );
+ end;
+ SetString( Result, P1, P-P1 );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION}
+function ParamCount: Integer;
+var p: PKOLChar;
+begin
+ p := GetCommandLine;
+ Result := -1;
+ while p^ <> #0 do
+ begin
+ inc( Result );
+ p := SkipParam( p );
+ p := SkipSpaces( p );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF PARAMS_DEFAULT}
+{$ENDIF WIN}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function DelimiterLast( const Str, Delimiters: KOLString ): Integer;
+var PStr: PKOLChar;
+begin
+ PStr := PKOLChar( Str );
+ Result := Integer( __DelimiterLast( PStr, PKOLChar( Delimiters ) ) )
+ - Integer( PStr )
+ + {$IFDEF UNICODE_CTRLS} 2 {$ELSE} 1 {$ENDIF}; // {Viman}
+ {$IFDEF UNICODE_CTRLS} Result := Result div SizeOf( WideChar ) {$ENDIF};
+end;
+{$ENDIF PAS_VERSION}
+
+// Thanks to Marco Bobba - Marisa Bo for this code
+{$IFDEF ASM_UNICODE}{$ELSE}
+function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean;
+begin
+ Result := FALSE;
+ if (Str = nil) or (Pattern = nil) then
+ begin
+ Result := (Integer(Str) = Integer(Pattern));
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+
+ while Pattern^ <> #0 do
+ begin
+ if Str^ <> Pattern^ then Exit;
+ inc( Str );
+ inc( Pattern );
+ end;
+ Result := TRUE;
+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
+ {$IFDEF F_P}
+ MOV EAX, [Str]
+ MOV EDX, [Pattern]
+ {$ENDIF F_P}
+ XOR ECX, ECX
+ @@1:
+ MOV CL, [EDX] // pattern[ i ]
+ INC EDX
+ MOV CH, [EAX] // str[ i ]
+ INC EAX
+ JECXZ @@2 // str = pattern; CL = #0, CH = #0
+ CMP CL, 'a'
+ JB @@cl_ok
+ CMP CL, 'z'
+ JA @@cl_ok
+ SUB CL, 32
+ @@cl_ok:
+ CMP CH, 'a'
+ JB @@ch_ok
+ CMP CH, 'z'
+ JA @@ch_ok
+ SUB CH, 32
+ @@ch_ok:
+ CMP CL, CH
+ JE @@1
+ @@2:
+ TEST CL, CL
+ SETZ AL
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$ENDIF PAS_ONLY}
+
+
+{$IFNDEF _FPC}
+
+{$IFDEF WIN}
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function Format( const fmt: KOLString; params: Array of const ): KOLString;
+var Buffer: array[ 0..1023 ] of KOLChar;
+ ElsArray, El: PDWORD;
+ I : Integer;
+ P : PDWORD;
+begin
+ ElsArray := nil;
+ if High( params ) >= 0 then
+ GetMem( ElsArray, (High( params ) + 1) * sizeof( Pointer ) );
+ El := ElsArray;
+ for I := 0 to High( params ) do
+ begin
+ P := @params[ I ];
+ P := Pointer( P^ );
+ El^ := DWORD( P );
+ Inc( El );
+ end;
+ wvsprintf( PKOLChar(@Buffer[0]), PKOLChar( fmt ), Pointer( ElsArray ) );
+ Result := Buffer;
+ if ElsArray <> nil then
+ FreeMem( ElsArray );
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN}
+
+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 {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$ENDIF PAS_ONLY}
+
+{$ENDIF not_FPC}
+
+function WCharIn( C: KOLChar; const Chars: array of KOLChar ): Boolean;
+var i: Integer;
+begin
+ Result := TRUE;
+ for i := 0 to High( Chars ) do
+ if Chars[i] = C then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := FALSE;
+end;
+
+/////////////////////////////////////////////////////////////////////////
+//
+//
+// F I L E S
+//
+//
+/////////////////////////////////////////////////////////////////////////
+{
+ This part of the unit modified by Tim Slusher and Vladimir Kladov.
+}
+{* Set of utility methods to work with files
+ and reqistry.
+ When programming KOL, which is Windows API-oriented, You should
+ avoid alien (for Windows) embedded Pascal files handling, and
+ use API-calls which implemented very well. This set of functions
+ is intended to make this easier.
+ Also TDirList object implementation present here and some registry
+ access functions, which allow to make code more elegant.
+}
+
+{$UNDEF ASM_LOCAL}
+{$IFDEF ASM_VERSION}
+ {$DEFINE ASM_LOCAL}
+{$ENDIF PAS_VERSION}
+
+{$IFDEF WIN}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function FileCreate(const FileName: KOLString; OpenFlags: DWord): THandle;
+var Attr: DWORD;
+begin
+ Attr := (OpenFlags shr 16) and $1FFF;
+ if Attr = 0 then Attr := FILE_ATTRIBUTE_NORMAL;
+ Result := CreateFile( PKOLChar(FileName), OpenFlags and $F0000000,
+ OpenFlags and $F, nil, (OpenFlags shr 8) and $F,
+ Attr, 0 );
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN}
+
+{$IFDEF _D3orHigher}
+function WFileCreate(const FileName: KOLWideString; OpenFlags: DWord): THandle;
+var Attr: DWORD;
+begin
+ Attr := (OpenFlags shr 16) and $1FFF;
+ if Attr = 0 then Attr := FILE_ATTRIBUTE_NORMAL;
+ Result := CreateFileW( PWideChar(FileName), OpenFlags and $F0000000,
+ OpenFlags and $F, nil, (OpenFlags shr 8) and $F,
+ Attr, 0 );
+end;
+{$ENDIF _D3orHigher}
+
+{$IFDEF WIN}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function FileClose(Handle: THandle): Boolean;
+begin
+ Result := CloseHandle(Handle);
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN}
+
+{$IFDEF WIN}
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function FileExists( const FileName : KOLString ) : Boolean;
+{$IFDEF FILE_EXISTS_EX}
+var FD: TFindFileData;
+ LFT: TFileTime;
+ Hi, Lo: Word;
+ e: DWORD;
+{$ELSE}
+var Code: Integer;
+{$ENDIF}
+begin
+ {$IFDEF FILE_EXISTS_EX}
+ Result := FALSE;
+ e := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS );
+ if Find_First( Filename, FD ) then
+ begin
+ if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then
+ begin
+ FileTimeToLocalFileTime( FD.ftLastWriteTime, LFT );
+ if FileTimeToDosDateTime( LFT, Hi, Lo ) then
+ Result := TRUE;
+ end;
+ Find_Close( FD );
+ end;
+ SetErrorMode( e );
+ {$ELSE}
+ Code := GetFileAttributes(PKOLChar(FileName));
+ Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0);
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN}
+
+{$IFDEF _D3orHigher}
+function WFileExists( const FileName: KOLWideString ) : Boolean;
+{$IFDEF notimplemented_FILE_EXISTS_EX}
+var FD: TFindFileData;
+ //F: DWORD;
+ LFT: TFileTime;
+ Hi, Lo: Word;
+{$ELSE}
+var Code: Integer;
+{$ENDIF}
+begin
+ {$IFDEF notimplemented_FILE_EXISTS_EX}
+ Result := FALSE;
+ if not WFind_First( Filename, FD ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 then Exit; {>>>>>>>>}
+ FileTimeToLocalFileTime( FD.ftLastWriteTime, LFT );
+ if FileTimeToDosDateTime( LFT, Hi, Lo ) then Result := TRUE;
+ WFind_Close( FD );
+ {$ELSE}
+ Code := GetFileAttributesW(PWideChar(FileName));
+ Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0);
+ {$ENDIF}
+end;
+{$ENDIF _D3orHigher}
+
+{$IFDEF WIN}
+{$IFDEF ASM_STREAM}
+function FileSeek(Handle: THandle; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize;
+asm
+ MOVZX ECX, CL
+ PUSH ECX
+ PUSH 0
+ PUSH EDX
+ PUSH EAX
+ CALL SetFilePointer
+end;
+{$ELSE PAS_VERSION} //Pascal
+function FileSeek(Handle: THandle; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize;
+{$IFDEF STREAM_LARGE64}
+var HiPtr: DWORD;
+{$ENDIF}
+begin
+ {$IFDEF STREAM_LARGE64}
+ HiPtr := MoveTo shr 32;
+ Result := SetFilePointer(Handle, DWORD( MoveTo ), @ HiPtr, Ord( MoveMethod ) );
+ if (DWORD( Result ) = $FFFFFFFF {INVALID_SET_FILE_POINTER}) and
+ (GetLastError <> NO_ERROR) then
+ Result := -1; // Int64(-1)
+ if Result >= 0 then
+ Result := Result or (HiPtr shl 32);
+ {$ELSE}
+ Result := SetFilePointer(Handle, MoveTo, nil, Ord( MoveMethod ) );
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN}
+
+{$IFDEF WIN}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function FileRead(Handle: THandle; var Buffer; Count: DWord): DWord;
+begin
+ if not ReadFile(Handle, Buffer, Count, Result, nil) then
+ Result := 0;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function File2Str(Handle: THandle): AnsiString;
+var Pos, Size: DWORD;
+begin
+ Result := '';
+ if Handle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Pos := FileSeek( Handle, 0, spCurrent );
+ Size := GetFileSize( Handle, nil );
+ SetString( Result, nil, Size - Pos + 1 );
+ FileRead( Handle, Result[ 1 ], Size - Pos );
+ Result[ Size - Pos + 1 ] := #0;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFNDEF _D2}
+function File2WStr(Handle: THandle): KOLWideString;
+var Pos, Size: DWORD;
+begin
+ Result := '';
+ if Handle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Pos := FileSeek( Handle, 0, spCurrent );
+ Size := GetFileSize( Handle, nil );
+ SetString( Result, nil, (Size - Pos + 1) div Sizeof( WideChar ) + 1 ); // fixed by zhoudi
+ FileRead( Handle, Result[ 1 ], Size - Pos );
+ Result[ Length(Result) ] := #0; // fixed by zhoudi
+end;
+{$ENDIF _D2}
+
+{$IFDEF WIN}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function FileWrite(Handle: THandle; const Buffer; Count: DWord): DWord;
+begin
+ if not WriteFile(Handle, Buffer, Count, Result, nil) then
+ Result := 0;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function FileEOF( Handle: THandle ) : Boolean;
+var Siz, Pos : DWord;
+begin
+ Siz := GetFileSize( Handle, nil );
+ Pos := FileSeek( Handle, 0, spCurrent );
+ Result := Pos >= Siz;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF WIN}
+{$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;
+begin
+ Result := '';
+ Src := FileName;
+ while Src <> '' do
+ begin
+ S := Parse( Src, '\' );
+ if Result <> '' then
+ Result := Result + '\';
+ if (Result = '') and (Length( S ) = 2) and (S[ 2 ] = ':') then
+ Result := S
+ else
+ begin
+ {$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
+ ( PKOLChar( Result + S ), 0, SFI, Sizeof( SFI ), SHGFI_DISPLAYNAME );
+ if SFI.szDisplayName[ 0 ] <> #0 then
+ S := SFI.szDisplayName;
+ Result := Result + S;
+ end;
+ end;
+ if ExtractFileExt( Result ) = '' then
+ // case when flag 'Hide extensions for registered file types' is set on
+ // in the Explorer:
+ Result := Result + ExtractFileExt( FileName );
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN}
+
+{$IFDEF WIN}
+function FileShortPath( const FileName: KOLString ): KOLString;
+var Buf: array[ 0..MAX_PATH ] of KOLChar;
+begin
+ GetShortPathName( PKOLChar( FileName ), Buf, Sizeof( Buf ) );
+ Result := Buf;
+end;
+
+function FileIconSystemIdx( const Path: KOLString ): Integer;
+var SFI: TShFileInfo;
+begin
+ SFI.iIcon := 0; // Bartov
+ {$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
+ ( PKOLChar( Path ), 0, SFI, sizeof( SFI ), SHGFI_SMALLICON or SHGFI_SYSICONINDEX );
+ Result := SFI.iIcon;
+end;
+
+function FileIconSysIdxOffline( const Path: KOLString ): Integer;
+var SFI: TShFileInfo;
+begin
+ SFI.iIcon := 0; // Bartov
+ {$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
+ ( PKOLChar( Path ), FILE_ATTRIBUTE_NORMAL, SFI, sizeof( SFI ),
+ SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES );
+ Result := SFI.iIcon;
+end;
+{$ENDIF WIN}
+
+procedure LogFileOutput( const filepath, str: KOLString );
+var F: THandle;
+ Tmp: KOLString;
+begin
+ F := FileCreate( filepath, ofOpenWrite or ofOpenAlways or ofShareDenyWrite );
+ if F = INVALID_HANDLE_VALUE then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FileSeek( F, 0, spEnd );
+ Tmp := str + {$IFDEF LIN} #10 {$ELSE} #13#10 {$ENDIF};
+ FileWrite( F, PKOLChar( Tmp )^, Length( Tmp ) * Sizeof(KOLChar) );
+ FileClose( F );
+end;
+
+function StrLoadFromFile( const Filename: KOLString ): AnsiString;
+var F: THandle;
+begin
+ {$IFDEF WIN}
+ if KOLLowerCase(Filename) = 'con' then
+ Result := File2Str(GetStdHandle(STD_INPUT_HANDLE))
+ else
+ {$ENDIF WIN}
+ begin
+ Result := '';
+ F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite );
+ if F = INVALID_HANDLE_VALUE then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := File2Str( F );
+ FileClose( F ); {Dark Knight}
+ end;
+end;
+
+function Str2File( Filename: PKOLChar; Str: PAnsiChar ): Boolean;
+var L: Integer;
+begin
+ L := StrLen( Str );
+ Result := Mem2File( Filename, Str, L ) = L;
+end;
+
+function WStr2File( Filename: PKOLChar; Str: PWideChar ): Boolean;
+var L: Integer;
+begin
+ L := WStrLen( Str );
+ Result := Mem2File( Filename, Str, L * Sizeof(WideChar) ) = L;
+end;
+
+function StrSaveToFile( const Filename: KOLString; const Str: AnsiString ): Boolean;
+begin
+ Result := Mem2File( PKOLChar( Filename ), PAnsiChar( Str ), Length( Str ) )
+ = Length( Str );
+end;
+
+{$IFNDEF _D2}
+function WStrLoadFromFile( const Filename: KOLString ): KOLWideString;
+var F: THandle;
+begin
+ {$IFDEF WIN}
+ //if StrEq( Filename, 'CON' ) then
+ if KOLLowerCase(Filename) = 'con' then
+ Result := File2WStr(GetStdHandle(STD_INPUT_HANDLE))
+ else
+ {$ENDIF WIN}
+ begin
+ Result := '';
+ F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite );
+ if F = INVALID_HANDLE_VALUE then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := File2WStr( F );
+ FileClose( F ); {Dark Knight}
+ end;
+end;
+
+function WStrSaveToFile( const Filename: KOLString; const Str: KOLWideString ): Boolean;
+var BytesToSave: Integer;
+begin
+ BytesToSave := Length( Str ) * Sizeof(WideChar);
+ Result := Mem2File( PKOLChar( Filename ), PWideChar( Str ), BytesToSave )
+ = BytesToSave; // fixed by zhoudi
+end;
+{$ENDIF _D2}
+
+function Mem2File( Filename: PKOLChar; Mem: Pointer; Len: Integer ): Integer;
+var F: THandle;
+begin
+ Result := 0;
+ F := //FileCreate( Filename, ofOpenWrite or ofCreateAlways );
+ CreateFile( Filename, GENERIC_WRITE, 0, nil, CREATE_ALWAYS, 0, 0 );
+ if F = INVALID_HANDLE_VALUE then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := FileWrite( F, Mem^, Len );
+ CloseHandle( F );
+end;
+
+function File2Mem( Filename: PKOLChar; Mem: Pointer; MaxLen: Integer ): Integer;
+var F: THandle;
+begin
+ Result := 0;
+ F := //FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite );
+ CreateFile( Filename, GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0 );
+ if F = INVALID_HANDLE_VALUE then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := FileRead( F, Mem^, MaxLen );
+ CloseHandle( F );
+end;
+
+{$IFDEF WIN}
+function Find_First( const FilePathName: KOLString; var F: TFindFileData ): Boolean;
+begin
+ {$IFDEF UNICODE_CTRLS}
+ F.FindHandle := THandle( FindFirstFileExW( PKOLChar( FilePathName ),
+ FindExInfoStandard, PWin32FindDataW( @ F ),
+ FindExSearchNameMatch, nil, 0 ) );
+ {$ELSE}
+ F.FindHandle := FindFirstFile( PKOLChar( FilePathName ),
+ PWin32FindData( @ F )^ );
+ {$ENDIF}
+ Result := F.FindHandle <> INVALID_HANDLE_VALUE;
+end;
+function Find_Next( var F: TFindFileData ): Boolean;
+begin
+ Result := FindNextFile( F.FindHandle,
+ {$IFDEF UNICODE_CTRLS} PWin32FindDataW {$ELSE} PWin32FindData {$ENDIF}
+ ( @ F )^ );
+end;
+procedure Find_Close( var F: TFindFileData );
+begin
+ Windows.FindClose( F.FindHandle );
+end;
+{$ENDIF WIN}
+
+{$IFDEF WIN}
+function FileSize( const Path: KOLString ) : {$IFDEF _D2orD3} Integer {$ELSE} Int64 {$ENDIF};
+var FD : TFindFileData;
+begin
+ Result := 0;
+ if not Find_First( Path, FD ) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF _D2orD3}
+ Result := FD.nFileSizeLow;
+ {$ELSE}
+ I64( Result ).Lo := FD.nFileSizeLow;
+ I64( Result ).Hi := FD.nFileSizeHigh;
+ {$ENDIF}
+ Find_Close( FD );
+end;
+{$ENDIF WIN}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+procedure FileTime( const Path: KOLString;
+ CreateTime, LastAccessTime, LastModifyTime: PFileTime ); stdcall;
+var FD : TFindFileData;
+ procedure CopyTime( Dest, Src: PFileTime );
+ begin
+ if Dest <> nil then
+ Dest^ := Src^;
+ end;
+begin
+ if not Find_First( Path, FD ) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Find_Close( FD );
+ CopyTime( CreateTime, @ FD.ftCreationTime );
+ CopyTime( LastModifyTime, @ FD.ftLastWriteTime );
+ CopyTime( LastAccessTime, @ FD.ftLastAccessTime );
+end;
+{$ENDIF PAS_VERSION}
+
+function GetUniqueFilename( PathName: KOLString ) : KOLString;
+var Path, Nam, Ext : KOLString;
+ I, J, K : Integer;
+begin
+ Result := PathName;
+ Path := ExtractFilePath( PathName );
+ if not DirectoryExists( Path ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Nam := ExtractFileNameWOext( PathName );
+ if Nam = '' then
+ begin
+ Path := ExcludeTrailingPathDelimiter( Path );
+ PathName := Path;
+ Result := Path;
+ end;
+ Nam := ExtractFileNameWOext( PathName );
+ Ext := ExtractFileExt( PathName );
+ I := Length( Nam );
+ for J := I downto 1 do
+ if not ((Nam[ J ] >= '0') and (Nam[ J ] <= '9')) then
+ begin
+ I := J;
+ break;
+ end;
+ K := Str2Int( CopyEnd( Nam, I + 1 ) );
+ while FileExists( Result ) do
+ begin
+ Inc( K );
+ Result := Path + Copy( Nam, 1, I ) + Int2Str( K ) + Ext;
+ end;
+end;
+
+{$IFDEF WIN}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function CompareSystemTime(const D1, D2 : TSystemTime) : Integer;
+{$IFDEF DATE0_1601}
+var ft1, ft2: TFileTime;
+{$ELSE}
+var R: Integer;
+ procedure CompareFields(const F1, F2 : Integer);
+ begin
+ if R <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if F1 = F2 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if F1 < F2 then
+ R := -1
+ else R := 1;
+ end;
+{$ENDIF DATE0_0001}
+begin
+ {$IFDEF DATE0_1601}
+ SystemTimeToFileTime( D1, ft1 );
+ SystemTimeToFileTime( D2, ft2 );
+{$IFDEF FPC}
+ Result := CompareFileTime( @ft1, @ft2 );
+{$ELSE}
+ Result := CompareFileTime( ft1, ft2 );
+{$ENDIF}
+ {$ELSE}
+ R := 0;
+ CompareFields( D1.wYear, D2.wYear );
+ CompareFields( D1.wMonth, D2.wMonth );
+ CompareFields( D1.wDay, D2.wDay );
+ CompareFields( D1.wHour, D2.wHour );
+ CompareFields( D1.wMinute, D2.wMinute );
+ CompareFields( D1.wSecond, D2.wSecond );
+ CompareFields( D1.wMilliseconds, D2.wMilliseconds );
+ Result := R;
+ {$ENDIF DATE0_0001}
+end;
+{$ENDIF PAS_VERSION}
+
+function FileTimeCompare( const FT1, FT2 : TFileTime ) : Integer;
+begin
+{$IFDEF FPC}
+ Result := CompareFileTime( @FT1, @FT2 );
+{$ELSE}
+ Result := CompareFileTime( FT1, FT2 );
+{$ENDIF}
+end;
+{$ENDIF WIN}
+
+{$IFDEF WIN}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function DirectoryExists(const Name: KOLString): Boolean;
+var
+ Code: Integer;
+ e: DWORD;
+begin
+ e := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS );
+ Code := GetFileAttributes(PKOLChar(Name));
+ Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
+ SetErrorMode( e );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION}
+function DiskPresent( const DrivePath: KOLString ): Boolean;
+var e: DWORD;
+ restore: Boolean;
+begin
+ e := 0;
+ Restore := FALSE;
+ //if Copy( DrivePath, 1, 2 ) <> '\\' then
+ if (DrivePath <> '') and (DrivePath[1] <> '\') then
+ CASE GetDriveType( PKOLChar( DrivePath ) ) OF
+ DRIVE_REMOVABLE, DRIVE_CDROM, DRIVE_RAMDISK:
+ begin
+ e := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS );
+ Restore := TRUE;
+ end;
+ END;
+ Result := DirectoryExists( DrivePath );
+ if Restore then SetErrorMode( e );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF _D3orHigher}
+function WDirectoryExists(const Name: KOLWideString): Boolean;
+var
+ Code: Integer;
+begin
+ Code := GetFileAttributesW(PWideChar(Name));
+ Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
+end;
+{$ENDIF _D3orHigher}
+
+{$ENDIF WIN}
+
+function CheckDirectoryContent( const Name: KOLString; SubDirsOnly: Boolean;
+ const Mask: KOLString ): Boolean;
+var FD: TFindFileData;
+begin
+ Result := TRUE;
+ if DirectoryExists( Name ) then
+ begin
+ if Find_First( IncludeTrailingPathDelimiter( Name ) + Mask, FD ) then
+ begin
+ repeat
+ if not {$IFDEF UNICODE_CTRLS}WStrIn{$ELSE}StrIn{$ENDIF}( FD.cFileName, ['.','..'] ) then
+ begin
+ if SubDirsOnly and LongBool(FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY)
+ or not SubDirsOnly then
+ begin
+ Result := FALSE;
+ break;
+ end;
+ end;
+ until not Find_Next( FD );
+ Find_Close( FD );
+ end;
+ end;
+end;
+
+function DirectoryEmpty(const Name: KOLString): Boolean;
+begin
+ Result := CheckDirectoryContent( Name, FALSE, '*.*' );
+end;
+
+function DirectoryHasSubdirs( const Path: KOLString ): Boolean;
+begin
+ Result := not CheckDirectoryContent( Path, TRUE, '*.*' );
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+ {$IFDEF WIN}
+ {$UNDEF LINUX_USE_HOME_STARTFDIR}
+ {$ENDIF}
+function GetStartDir : KOLString;
+{$IFNDEF LINUX_USE_HOME_STARTFDIR}
+var Buffer:array[0..MAX_PATH] of KOLChar;
+ I : Integer;
+{$ENDIF}
+begin
+ {$IFDEF LINUX_USE_HOME_STARTFDIR}
+ Result := getenv( 'HOME' );
+ {$ELSE}
+ I := GetModuleFileName( 0, Buffer, MAX_PATH );
+ for I := I downto 0 do
+ if Buffer[ I ] = {$IFDEF LIN} '/' {$ELSE} '\' {$ENDIF} then
+ begin
+ Buffer[ I + 1 ] := #0;
+ break;
+ end;
+ Result := Buffer;
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+function ExePath: KOLString;
+var Buffer: array[ 0..MAX_PATH+1 ] of KOLChar;
+begin
+ Buffer[ MAX_PATH+1 ] := #0;
+ GetModuleFileName( 0, Buffer, MAX_PATH+1 );
+ Result := Buffer;
+end;
+
+function ModulePath: KOLString;
+var Buffer: array[ 0..MAX_PATH+1 ] of KOLChar;
+begin
+ Buffer[ MAX_PATH+1 ] := #0;
+ GetModuleFileName( hInstance, Buffer, MAX_PATH+1 );
+ Result := Buffer;
+end;
+
+{$IFNDEF PAS_ONLY}
+function DirectorySize( const Path: KOLString ): I64;
+var DirList: PDirList;
+ I: Integer;
+begin
+ Result := MakeInt64( 0, 0 );
+ DirList := NewDirList( Path, {$IFDEF LIN} '*' {$ELSE} '*.*' {$ENDIF}, 0 );
+ for I := 0 to DirList.Count-1 do
+ begin
+ if LongBool( DirList.Items[ I ].dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY ) then
+ Result := Add64( Result, DirectorySize( DirList.Path + DirList.Names[ I ] ) )
+ else Result := Add64( Result, MakeInt64( DirList.Items[ I ].nFileSizeLow,
+ DirList.Items[ I ].nFileSizeHigh ) );
+ end;
+ DirList.Free;
+end;
+{$ENDIF}
+
+{$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+function GetFileList(const dir: KOLString): PKOLStrList;
+var
+ Srch: TFindFileData;
+ succ: Boolean;
+begin
+ result := nil;
+ succ := Find_First(dir, Srch);
+ while succ do begin
+ if (not (Srch.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0))then begin
+ if Result = nil then begin
+ Result := NewKOLStrList;
+ end;
+ Result.Add(Srch.cFileName);
+ end;
+ succ := Find_Next(Srch);
+ end;
+ Find_Close(Srch);
+end;
+
+{$ENDIF WIN}
+function ExcludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
+begin
+ Result := S;
+ if Result <> '' then
+ if Result[ Length( Result ) ] = C then
+ Delete( Result, Length( Result ), 1 );
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PASCAL}
+function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
+begin
+ Result := S;
+ if (Result = '') or (Result[ Length( Result ) ] <> C) then
+ Result := Result + KOLString(C);
+end;
+{$ENDIF PAS_VERSION}
+
+
+//---------------------------------------------------------
+// Following functions/procedures are created by Edward Aretino:
+// IncludeTrailingPathDelimiter, ExcludeTrailingPathDelimiter,
+// ForceDirectories, CreateDir, ChangeFileExt
+//---------------------------------------------------------
+function IncludeTrailingPathDelimiter(const S: KOLString): KOLString;
+begin
+ Result := IncludeTrailingChar( S, {$IFDEF UNIX} '/' {$ELSE} '\' {$ENDIF} );
+end;
+
+function ExcludeTrailingPathDelimiter(const S: KOLString): KOLString;
+begin
+ Result := ExcludeTrailingChar( S, {$IFDEF UNIX} '/' {$ELSE} '\' {$ENDIF} );
+end;
+
+function ExtractFileDrive( const Path: KOLString ) : KOLString;
+var i, j: Integer;
+begin
+ Result := Path;
+ if Result = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if pos( KOLString(':'), Result ) > 1 then
+ Result := Parse( Result, ':' ) + ':\'
+ else if Length( Result ) > 2 then
+ begin
+ j := 0;
+ for i := 3 to Length( Result ) do
+ if Result[ i ] = '\' then
+ begin
+ inc( j );
+ if j = 2 then
+ begin
+ Result := Copy( Result, 1, i );
+ break;
+ end;
+ end;
+ Result := IncludeTrailingPathDelimiter( Result );
+ end else if Length( Result ) = 1 then
+ Result := Result + ':\';
+end;
+
+{$IFDEF ASM_LStrFromPCharLen} // LStrFromPCharLen - there are no in D2
+function ExtractFilePath( const Path : AnsiString ) : AnsiString;
+asm
+ PUSH EDX
+ MOV EDX, [DirDelimiters]
+ CALL EAX2PChar
+ PUSH EAX
+ CALL __DelimiterLast
+ XCHG EDX, EAX
+ XOR ECX, ECX // ECX = 0
+ POP EAX
+ CMP byte ptr [EDX], CL
+ JZ @@ret_0
+ SUB EDX, EAX
+ INC EDX
+ XCHG EDX, EAX
+ XCHG ECX, EAX // EAX = 0
+@@ret_0:
+ POP EAX
+ {$IFDEF _D2009orHigher}
+ PUSH 0
+ {$ENDIF}
+ CALL System.@LStrFromPCharLen
+end;
+{$ELSE} //Pascal
+function ExtractFilePath( const Path : KOLString ) : KOLString;
+//var I : Integer;
+var P, P0: PKOLChar;
+begin
+ P0 := PKOLChar( Path );
+ P := __DelimiterLast( P0, ':\/' );
+ if P^ = #0 then
+ Result := ''
+ else Result := Copy( Path, 1, P - P0 + 1 );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF _D3orHigher}
+function WExtractFilePath( const Path: KOLWideString ) : KOLWideString;
+var P, P0: PWideChar;
+begin
+ P0 := PWideChar( Path );
+ P := W__DelimiterLast( P0, ':\/' );
+ if P^ = #0 then
+ Result := ''
+ else Result := Copy( Path, 1, P - P0 + 1 );
+end;
+{$ENDIF}
+
+{$IFDEF ASM_VERSION}{$IFNDEF _D2}
+{$DEFINE ASM_LStrFromPCharLen}
+{$ENDIF}
+{$ENDIF PAS_VERSION}
+
+function IsNetworkPath( const Path: KOLString ): Boolean;
+begin
+ Result := (Length( Path ) >= 2) and (Path[1] = '\') and (Path[2] = '\');
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function ExtractFileName( const Path : KOLString ) : KOLString;
+var P: PKOLChar;
+begin
+ P := __DelimiterLast( PKOLChar( Path ), ':\/' );
+ if P^ = #0 then
+ Result := Path
+ else Result := P + 1;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PASCAL}
+function ExtractFileNameWOext( const Path : KOLString ) : KOLString;
+begin
+ Result := ExtractFileName( Path );
+ Result := Copy( Result, 1, Length( Result ) - Length( ExtractFileExt( Result ) ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function ExtractFileExt( const Path : KOLString ) : KOLString;
+var P: PKOLChar;
+begin
+ P := __DelimiterLast( PKOLChar( Path ), '.' );
+ Result := P;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PASCAL}
+function ReplaceExt( const Path, NewExt: KOLString ): KOLString;
+begin
+ 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);
+end;
+
+function CreateDir(const Dir: KOLString): Boolean;
+begin
+ Result := {$IFDEF WIN} {Windows.}CreateDirectory(PKOLChar(Dir), nil)
+ {$ELSE LIN} Libc.__mkdir(PAnsiChar(Dir), S_IRWXU or S_IRWXG or S_IRWXO) = 0
+ {$ENDIF};
+end;
+
+function ChangeFileExt(FileName: KOLString; const Extension: KOLString): KOLString;
+var
+ FileExt: KOLString;
+begin
+ FileExt := ExtractFileExt(FileName);
+ DeleteTail(FileName, Length(FileExt));
+ Result := FileName+ Extension;
+end;
+
+function ReplaceFileExt( const Path, NewExt: KOLString ): KOLString;
+begin
+ Result := ExtractFilePath( Path ) +
+ ExtractFileNameWOext( ExtractFileName( Path ) ) +
+ NewExt;
+end;
+
+{$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+function ExtractShortPathName( const Path: KOLString ): KOLString;
+var
+ Buffer: array[0..MAX_PATH - 1] of KOLChar;
+begin
+ SetString(Result, Buffer,
+ GetShortPathName(PKOLChar(Path), Buffer, SizeOf(Buffer) div Sizeof(KOLChar)));
+end;
+
+{$IFDEF GDI}
+function FilePathShortened( const Path: KOLString; MaxLen: Integer ): KOLString;
+begin
+ Result := FilePathShortenPixels( Path, 0, MaxLen );
+end;
+
+function PixelsLength( DC: HDC; const Text: KOLString ): Integer;
+var Sz: TSize;
+begin
+ if DC = 0 then
+ Result := Length( Text )
+ else
+ begin
+ {$IFDEF UNICODE_CTRLS}Windows.GetTextExtentPoint32W
+ {$ELSE} Windows.GetTextExtentPoint32A
+ {$ENDIF}( DC, PKOLChar( Text ), Length( Text ), Sz );
+ Result := Sz.cx;
+ end;
+end;
+
+function FilePathShortenPixels( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
+var L0, L1: Integer;
+ Prev: KOLString;
+begin
+ Result := Path;
+ L0 := PixelsLength( DC, Result );
+ while L0 > MaxPixels do
+ begin
+ Prev := Result;
+ L1 := pos( KOLString('\...\'), Result ); // ambiguous
+ if L1 <= 0 then
+ Result := ExcludeTrailingPathDelimiter( ExtractFilePath( Result ) )
+ else Result := Copy( Result, 1, L1 - 1 );
+ if Result <> '' then
+ Result := IncludeTrailingPathDelimiter( ExtractFilePath( Result ) ) +
+ '...\' + ExtractFileName( Path );
+ if (Result = '') or (Result = Prev) then
+ begin
+ L1 := Length( ExtractFilePath( Result ) );
+ while (PixelsLength( DC, Result ) > MaxPixels) and (L1 > 1) do
+ begin
+ Dec( L1 );
+ Result := Copy( Result, 1, L1 ) + '...\' + ExtractFileName( Result );
+ end;
+ if PixelsLength( DC, Result ) > MaxPixels then
+ begin
+ L1 := MaxPixels + 1;
+ while ((MaxPixels > 0) and (L1 > 1) or (MaxPixels = 0) and (L1 > 0)) and
+ (PixelsLength( DC, Result ) > MaxPixels) do
+ begin
+ Dec( L1 );
+ Result := Copy( ExtractFileName( Path ), 1, L1 ) + '...';
+ end;
+ end;
+ break;
+ end;
+ L0 := PixelsLength( DC, Result );
+ end;
+end;
+{$ENDIF GDI}
+
+procedure CutFirstDirectory(var S: KOLString);
+var
+ Root: Boolean;
+ P: Integer;
+begin
+ if S = '\' then
+ S := ''
+ else
+ begin
+ if S[1] = '\' then
+ begin
+ Root := True;
+ Delete(S, 1, 1);
+ end else
+ Root := False;
+ if S[1] = '.' then
+ Delete(S, 1, 4);
+ P := Pos( KOLString('\'), S );
+ if P <> 0 then
+ begin
+ Delete(S, 1, P);
+ S := '...\' + S;
+ end else
+ S := '';
+ if Root then
+ S := '\' + S;
+ end;
+end;
+
+{$IFDEF GDI}
+function MinimizeName( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
+var
+ Drive, Dir, Name: KOLString;
+begin
+ Result := Path;
+ Dir := ExtractFilePath(Result);
+ Name := ExtractFileName(Result);
+
+ if (Length(Dir) >= 2) and (Dir[2] = ':') then
+ begin
+ Drive := Copy(Dir, 1, 2);
+ Delete(Dir, 1, 2);
+ end else Drive := '';
+ while ((Dir <> '') or (Drive <> '')) and (PixelsLength(DC, Result) > MaxPixels) do
+ begin
+ if Dir = '\...\' then
+ begin
+ Drive := '';
+ Dir := '...\';
+ end else if Dir = '' then
+ Drive := ''
+ else CutFirstDirectory(Dir);
+ Result := Drive + Dir + Name;
+ end;
+end;
+{$ENDIF GDI}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION}
+function GetSystemDir: KOLString;
+var Buf: array[ 0..MAX_PATH-1 ] of KOLChar;
+begin
+ GetSystemDirectory( @ Buf[ 0 ], MAX_PATH );
+ Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION}
+function GetWindowsDir : KOLString;
+var Buf : array[ 0..MAX_PATH-1 ] of KOLChar;
+begin
+ GetWindowsDirectory( @Buf[ 0 ], MAX_PATH );
+ Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION}
+function GetWorkDir : KOLString;
+var Buf: array[ 0..MAX_PATH ] of KOLChar;
+begin
+ GetCurrentDirectory( MAX_PATH, @ Buf[ 0 ] );
+ Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN}
+
+{$IFDEF ASM_UNICODE}{$ELSE PASCAL}
+function GetTempDir : KOLString;
+{$IFDEF WIN} var Buf : Array[ 0..MAX_PATH ] of KOLChar; {$ENDIF WIN}
+begin
+ {$IFDEF LIN} Result := '/tmp/'; {$ELSE WIN}
+ GetTempPath( MAX_PATH + 1, @Buf[ 0 ] );
+ Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
+ {$ENDIF WIN}
+end;
+{$ENDIF}
+
+{$IFDEF WIN}
+{$IFDEF ASM_UNICODE}{$ELSE PASCAL}
+function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString;
+var Buf: array[ 0..MAX_PATH ] of KOLChar;
+begin
+ GetTempFileName( PKOLChar( DirPath ), PKOLChar( Prefix ), 0, Buf );
+ Result := Buf;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN}
+
+function GetFileListStr(FPath{e.g.'c:\tmp\'}, FMask{e.g.'*.*'}: KOLString): KOLString;
+{* List of files in string, separating each path from others with FileOpSeparator.
+ E.g.: 'c:\tmp\unit1.dcu'#13'c:\tmp\unit1.~pa' (for use with DeleteFile2Recycle())}
+var
+ Srch: TFindFileData;
+ succ: Boolean;
+ dir:KOLString;
+begin
+ result := '';
+ if (FPath<>'') then FPath := IncludeTrailingPathDelimiter( FPath );
+ if (FMask<>'') and (FMask[1]={$IFDEF LIN} '/' {$ELSE} '\' {$ENDIF}) then
+ FMask := CopyEnd(FMask,2);
+ dir:=FPath+FMask;
+ succ := Find_First(dir, Srch);
+ while succ do begin
+ if (not (Srch.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0))then begin
+ if Result<>'' then Result := Result + KOLString(FileOpSeparator);
+ Result := Result + FPath + KOLString(Srch.cFileName);
+ end;
+ succ := Find_Next(Srch);
+ end;
+ Find_Close(Srch);
+end;
+
+function DeleteFiles( const DirPath: KOLString ): Boolean;
+var Files, Name: KOLString;
+begin
+ Files := GetFileListStr( ExtractFilePath( DirPath ), ExtractFileName( DirPath ) );
+ Result := TRUE;
+ while Files <> '' do
+ begin
+ Name := Parse( Files, FileOpSeparator );
+ Result := Result and DeleteFile( PKOLChar( Name ) );
+ end;
+end;
+
+{$IFDEF WIN_GDI} //>>>>>>>>>>>>
+function DeleteFile2Recycle( const Filename : KOLString ) : Boolean;
+begin
+ Result := DoFileOp( Filename, '', FO_DELETE, FOF_ALLOWUNDO or
+ FOF_NOCONFIRMATION or FOF_SIMPLEPROGRESS, 'Deleting...' );
+end;
+
+function CopyMoveFiles( const FromList, ToList: KOLString; Move: Boolean ): Boolean;
+begin
+ Result := DoFileOp(FromList, ToList, FO_COPY - Integer( Move ),
+ FOF_ALLOWUNDO, nil); //|\\ FO_COPY = 2, FO_MOVE = 1
+
+end;
+
+{$IFNDEF PAS_ONLY}
+function DiskFreeSpace( const Path: KOLString ): I64;
+type TGetDFSEx = function( Path: PKOLChar; CallerFreeBytes, TotalBytes, FreeBytes: Pointer )
+ : Bool; stdcall;
+var GetDFSEx: TGetDFSEx;
+ Kern32: THandle;
+ V: TOSVersionInfo;
+ Ex: Boolean;
+ SpC, BpS, NFC, TNC: DWORD;
+ FBA, TNB: I64;
+begin
+ GetDFSEx := nil;
+ V.dwOSVersionInfoSize := Sizeof( V );
+ GetVersionEx( POSVersionInfo( @ V )^ ); // bug in Windows.pas !
+ Ex := FALSE;
+ if V.dwPlatformId = VER_PLATFORM_WIN32_NT then
+ Ex := V.dwMajorVersion >= 4
+ else if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then
+ begin
+ Ex := V.dwMajorVersion > 4;
+ if not Ex then
+ if V.dwMajorVersion = 4 then
+ begin
+ Ex := V.dwMinorVersion > 0;
+ if not Ex then
+ Ex := LoWord( V.dwBuildNumber ) >= $1111;
+ end;
+ end;
+ if Ex then
+ begin
+ Kern32 := GetModuleHandle( 'kernel32' );
+ GetDFSEx := GetProcAddress( Kern32, 'GetDiskFreeSpaceExA' );
+ end;
+ if Assigned( GetDFSEx ) then
+ GetDFSEx( PKOLChar( Path ), @ FBA, @ TNB, @Result )
+ else
+ begin
+ GetDiskFreeSpace( PKOLChar( Path ), SpC, BpS, NFC, TNC );
+ Result := Mul64i( MakeInt64( SpC * BpS, 0 ), NFC );
+ end;
+end;
+{$ENDIF}
+
+function DoFileOp( const FromList, ToList: KOLString; FileOp: UINT; Flags: Word;
+ Title: PKOLChar): Boolean;
+var FOS : {$IFDEF UNICODE_CTRLS}TSHFileOpStructW{$ELSE}TSHFileOpStruct{$ENDIF};
+ Buf : PKOLChar;
+ L : Integer;
+ ToList0: KOLString;
+begin
+ L := Length( FromList );
+ Buf := AllocMem( (L+2) * Sizeof( KOLChar ) );
+ Move( FromList[ 1 ], Buf^, L * Sizeof( KOLChar ) );
+ for L := L downto 0 do
+ if Buf[ L ] = FileOpSeparator then Buf[ L ] := #0;
+ //FillChar( FOS, Sizeof( FOS ), #0 );
+ ZeroMemory( @FOS, Sizeof( FOS ) );
+ if Applet <> nil then
+ FOS.Wnd := Applet.Handle;
+ FOS.wFunc := FileOp;
+ FOS.lpszProgressTitle := Title;
+ FOS.pFrom := Buf;
+ ToList0 := ToList + #0;
+ FOS.pTo := PKOLChar( ToList0 );
+ FOS.fFlags := Flags;
+ FOS.fAnyOperationsAborted := True;
+ Result := {$IFDEF UNICODE_CTRLS}SHFileOperationW{$ELSE}SHFileOperationA{$ENDIF}( FOS ) = 0;
+ if Result then
+ Result := not FOS.fAnyOperationsAborted;
+ FreeMem( Buf );
+end;
+{$ENDIF WIN_GDI}
+
+{$IFDEF WIN}
+function DirIconSysIdxOffline( const Path: KOLString ): Integer;
+var SFI: TShFileInfo;
+begin
+ SFI.iIcon := 0; // Bartov
+ {$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
+ ( PKOLChar( Path ), FILE_ATTRIBUTE_DIRECTORY, SFI, sizeof( SFI ),
+ SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES );
+ Result := SFI.iIcon;
+end;
+{$ENDIF WIN}
+
+{ TDirList }
+
+{$IFDEF SPEED_FASTER}
+ {$DEFINE DIRLIST_FASTER}
+{$ENDIF}
+
+function NewDirList( const DirPath, Filter: KOLString; Attr: DWORD ): PDirList;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TDirList';
+ {$ENDIF}
+ Result.ScanDirectory( DirPath, Filter, Attr );
+end;
+
+function NewDirListEx( const DirPath, Filters: KOLString; Attr: DWORD ): PDirList;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TDirListEx';
+ {$ENDIF}
+ Result.ScanDirectoryEx( DirPath, Filters, Attr );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TDirList.Clear;
+begin
+ Free_And_Nil( FListPositions );
+ Free_And_Nil( fStoreFiles );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TDirList.Destroy;
+begin
+ Clear;
+ FPath := '';
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function FindFilter(const Filter: KOLString): KOLString;
+begin
+ Result := Filter;
+ if Result = '' then Result := '*.*';
+end;
+{$ENDIF PAS_VERSION}
+
+function TDirList.Get(Idx: Integer): PFindFileData;
+begin
+ {$IFDEF DIRLIST_FASTER}
+ Result := FListPositions.Items[ Idx ];
+ {$ELSE}
+ Result := Pointer( Integer( fStoreFiles.fMemory )
+ + Integer( FListPositions.Items[ Idx ] ) );
+ {$ENDIF}
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TDirList.GetCount: Integer;
+begin
+ Result := 0;
+ if FListPositions = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := FListPositions.Count;
+end;
+{$ENDIF PAS_VERSION}
+
+function TDirList.GetNames(Idx: Integer): KOLString;
+var FData: PFindFileData;
+begin
+ FData := Get( Idx );
+ Result := FData.cFileName;
+end;
+
+function TDirList.GetIsDirectory(Idx: Integer): Boolean;
+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;
+{$IFDEF F_P}
+const Dot: AnsiString = '.';
+{$ENDIF F_P}
+var I: Integer;
+ F: PKOLChar;
+ HasOnlyNegFilters: Boolean;
+ dots: Boolean;
+begin
+ Result := (((FileAttr and FindAttr) = FindAttr) or
+ LongBool(FindAttr and FILE_ATTRIBUTE_NORMAL));
+ if not Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+
+ dots := (FileName^ = {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF})
+ and ( (FileName[1] = {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF})
+ and (FileName[2] = #0)
+ or (FileName[1] = #0) );
+
+ if not dots then
+ if LongBool( FindAttr and FILE_ATTRIBUTE_NORMAL ) and
+ (FindAttr <> FILE_ATTRIBUTE_NORMAL) then
+ if LongBool( FindAttr and FILE_ATTRIBUTE_DIRECTORY ) and
+ LongBool( FileAttr and FILE_ATTRIBUTE_DIRECTORY ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+
+ HasOnlyNegFilters := TRUE;
+ for I := 0 to fFilters.Count - 1 do
+ begin
+ F := fFilters.ItemPtrs[ I ];
+ if F = '' then continue;
+ if FileName = F then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if dots then
+ continue;
+ if F[ 0 ] = '^' then
+ begin
+ if StrSatisfy( FileName, PKOLChar(@F[ 1 ]) ) then
+ begin
+ Result := False; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end else
+ begin
+ HasOnlyNegFilters := FALSE;
+ if StrSatisfy( FileName, F ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+
+ 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;
+ Action: TDirItemAction;
+ {$IFDEF FORCE_ALTERNATEFILENAME}
+ IsUnicode: KOLString;
+ {$ENDIF}
+ {$IFDEF UNICODE_CTRLS}
+ {$IFDEF SPEED_FASTER}
+ {$IFDEF DIRLIST_OPTIMIZE_ASCII}
+ P: PKOLChar;
+ {$ENDIF}
+ {$ENDIF}
+ {$ENDIF}
+begin
+ Clear;
+ FPath := DirPath;
+ if FPath = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FPath := IncludeTrailingPathDelimiter( FPath );
+ if (fFilters = nil) then
+ begin
+ fFilters := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
+ if Filter = '*.*' then
+ fFilters.Add( '*' )
+ else fFilters.Add( Filter );
+ end;
+ if Find_First( PKOLChar( FPath + FindFilter( Filter ) ), FindData ) then
+ begin // D[u]fa. fix mem leaks (FList, fFilters)
+ FListPositions := NewList;
+ while True do
+ begin
+ {$IFDEF FORCE_ALTERNATEFILENAME} //+MtsVN
+ IsUnicode := FindData.cFileName;
+ if (IsUnicode <> '.') and (IsUnicode <> '..') then
+ begin
+ if pos('?', IsUnicode) > 0 then
+ CopyMemory( @FindData.cFileName, @FindData.cAlternateFileName,
+ SizeOf(FindData.cAlternateFileName));
+ end;
+ {$ENDIF}
+ if SatisfyFilter( PKOLChar(@FindData.cFileName[0]),
+ FindData.dwFileAttributes, Attr ) then
+ begin
+ Action := diAccept;
+ if Assigned( OnItem ) then
+ OnItem( @Self, FindData, Action );
+ CASE Action OF
+ diSkip: ;
+ diAccept:
+ begin
+ 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}
+ {$ENDIF}
+ fStoreFiles.Write( FindData, Sizeof( FindData ) );
+ {$IFDEF DIRLIST_FASTER}
+ FListPositions.Add( fStoreFiles.fData.fJustWrittenBlkAddress );
+ {$ENDIF}
+ end;
+ diCancel: break;
+ END;
+ end;
+ if not Find_Next( FindData ) then break;
+ end;
+ 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);
+var F, FF: KOLString;
+begin
+ FF := Filters;
+ Free_And_Nil( fFilters );
+ fFilters := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
+ repeat
+ F := Trim( Parse( FF, ';' ) );
+ if F <> '' then
+ fFilters.Add( F );
+ until FF = '';
+ ScanDirectory( DirPath, '', Attr );
+end;
+{$ENDIF PAS_VERSION}
+
+type
+ PSortDirData = ^TSortDirData;
+ TSortDirData = packed Record
+ CountRules: Integer;
+ FoldersFirst, CaseSensitive, InvertSortOrder : Boolean;
+ Rules : array[ 0..10 ] of TSortDirRules;
+ Dir : PDirList;
+ end;
+
+function CompareDirItems( const Data : PSortDirData; const e1, e2 : DWORD ) : Integer;
+var I : Integer;
+ Item1, Item2 : PFindFileData;
+ S1, S2 : PKOLChar;
+ {$IFDEF UNICODE_CTRLS}
+ W1, W2: KOLWideString;
+ {$ENDIF}
+ IsDir1, IsDir2 : Boolean;
+ {$IFDEF _D4orHigher}
+ sz1, sz2: I64;
+ {$ENDIF}
+begin
+ Item1 := Data.Dir.Get( e1 ); // fList.Items[ e1 ];
+ Item2 := Data.Dir.Get( e2 ); // fList.Items[ e2 ];
+ Result := 0;
+ if Data.FoldersFirst then
+ begin
+ IsDir1 := (Item1.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0;
+ IsDir2 := (Item2.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0;
+ if IsDir1 <> IsDir2 then
+ begin
+ if IsDir1 then Result := -1 else Result := 1;
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ for I := 0 to High(Data.Rules){Data.CountRules} do
+ begin
+ case Data.Rules[ I ] of
+ sdrByName:
+ begin
+ S1 := Item1.cFileName;
+ 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!
+ while TRUE do
+ begin
+ Result := SortAnsiOrderNoCase[ Char( S1^ ) ]
+ - SortAnsiOrderNoCase[ Char( S2^ ) ];
+ if Result <> 0 then break;
+ if S1^ = #0 then break;
+ inc( S1 );
+ inc( S2 );
+ end;
+ if Result = 0 then
+ Result := _AnsiCompareStr( Item1.cFileName, Item2.cFileName );
+ end else
+ {$ENDIF}
+ {$ENDIF}
+ begin
+ W1 := S1;
+ W2 := S2;
+ CharUpperBuffW(Pointer(@W1[1]), Length(W1));
+ CharUpperBuffW(Pointer(@W2[1]), Length(W2));
+ Result := _WStrComp( @W1[1], @W2[1] );
+ end;
+ {$ELSE not UNICODE_CTRLS}
+ Result := _AnsiCompareStrNoCaseA( S1, S2 );
+ if Result = 0 then
+ Result := _AnsiCompareStr( S1, S2 );
+ {$ENDIF}
+ end else
+ Result := {$IFDEF UNICODE_CTRLS}
+ _WStrComp( S1, S2 )
+ {$ELSE}
+ _AnsiCompareStrA( S1, S2 )
+ {$ENDIF};
+ end;
+ sdrByExt:
+ begin
+ S1 := Item1.cFileName;
+ S2 := Item2.cFileName;
+ S1 := {$IFDEF UNICODE_CTRLS} @ S1[ DelimiterLast( KOLWideString( S1 ), '.' ) - 1 ]
+ {$ELSE} __DelimiterLast( S1, '.' ) {$ENDIF};
+ S2 := {$IFDEF UNICODE_CTRLS} @ S2[ DelimiterLast( KOLWideString( S2 ), '.' ) - 1 ]
+ {$ELSE} __DelimiterLast( S2, '.' ) {$ENDIF};
+ if not Data.CaseSensitive then
+ Result := {$IFDEF UNICODE_CTRLS}
+ WStrComp( WAnsiUpperCase( S1 ), WAnsiUpperCase( S2 ) )
+ {$ELSE} _AnsiCompareStrNoCase( S1, S2 ) {$ENDIF}
+ else Result := {$IFDEF UNICODE_CTRLS} WStrComp( S1, S2 )
+ {$ELSE} _AnsiCompareStr( S1, S2 ) {$ENDIF};
+ end;
+ sdrBySize, sdrBySizeDescending:
+ begin
+ {$IFDEF _D5orHigher}
+ sz1 := MakeInt64( Item1.nFileSizeLow, Item1.nFileSizeHigh );
+ sz2 := MakeInt64( Item2.nFileSizeLow, Item2.nFileSizeHigh );
+ if Int64(sz1) < Int64(sz2) then
+ Result := -1
+ else if Int64(sz1) > Int64(sz2) then
+ Result := 1
+ else
+ Result := 0;
+ {$ELSE}
+ {$IFDEF _D4orHigher}
+ sz1 := MakeInt64( Item1.nFileSizeLow, Item1.nFileSizeHigh );
+ sz2 := MakeInt64( Item2.nFileSizeLow, Item2.nFileSizeHigh );
+ Result := Cmp64(sz1, sz2);
+ {$ELSE}
+ if Item1.nFileSizeHigh < Item2.nFileSizeHigh then
+ Result := -1
+ else if Item1.nFileSizeHigh > Item2.nFileSizeHigh then
+ Result := 1
+ else if Item1.nFileSizeLow < Item2.nFileSizeLow then
+ Result := -1
+ else if Item1.nFileSizeLow > Item2.nFileSizeLow then
+ Result := 1;
+ {$ENDIF}
+ {$ENDIF}
+ if Data.Rules[ I ] = sdrBySizeDescending then
+ Result := -Result;
+ end;
+{$IFDEF FPC}
+ sdrByDateCreate:
+ Result := CompareFileTime( @Item1.ftCreationTime, @Item2.ftCreationTime );
+ sdrByDateChanged:
+ Result := CompareFileTime( @Item1.ftLastWriteTime, @Item2.ftLastWriteTime );
+ sdrByDateAccessed:
+ Result := CompareFileTime( @Item1.ftLastAccessTime, @Item2.ftLastAccessTime );
+{$ELSE}
+ sdrByDateCreate:
+ Result := CompareFileTime( Item1.ftCreationTime, Item2.ftCreationTime );
+ sdrByDateChanged:
+ Result := CompareFileTime( Item1.ftLastWriteTime, Item2.ftLastWriteTime );
+ sdrByDateAccessed:
+ Result := CompareFileTime( Item1.ftLastAccessTime, Item2.ftLastAccessTime );
+{$ENDIF}
+ sdrNone: break;
+ end; {case}
+ if Result <> 0 then break;
+ end;
+ if Data.InvertSortOrder then
+ Result := -Result;
+end;
+
+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 );
+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;
+
+ function RulePresent( Rule : TSortDirRules ) : Boolean;
+ var K : Integer;
+ begin
+ Result := True;
+ for K := J - 1 downto 0 do
+ if Rule = SortDirData.Rules[ K ] then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := False;
+ end;
+
+ procedure AddRule( Rule : TSortDirRules );
+ begin
+ if Rule in [sdrFoldersFirst, sdrCaseSensitive, sdrInvertOrder] then
+ begin
+ if Rule = sdrFoldersFirst then
+ SortDirData.FoldersFirst := TRUE;
+ if Rule = sdrCaseSensitive then
+ SortDirData.CaseSensitive := TRUE;
+ if Rule = sdrInvertOrder then
+ 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 );
+ end;
+begin
+ if FListPositions = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ ZeroMemory( @ SortDirData, Sizeof( SortDirData ) ); //.CaseSensitive := false; // MTsv DN
+ J := 0;
+ for I := 0 to High(Rules) do
+ AddRule( Rules[ I ] );
+ for I := 0 to High(DefSortDirRules) do
+ AddRule( DefSortDirRules[ I ] );
+ SortDirData.CountRules := J;
+ SortDirData.Dir := @Self;
+ {$IFDEF UNICODE_CTRLS}
+ {$IFDEF SPEED_FASTER}
+ _AnsiCompareStrNoCaseA( '', '' );
+ {$ENDIF}
+ {$ENDIF}
+ SortData( Pointer( @SortDirData ), FListPositions.fCount, @CompareDirItems, @SwapDirItems );
+end;
+{$ENDIF PAS_VERSION}
+
+function TDirList.FileList(const Separator: KOLString; Dirs,
+ FullPaths: Boolean): KOLString;
+var I: Integer;
+begin
+ Result := '';
+ for I := 0 to Count-1 do
+ begin
+ if not Dirs and IsDirectory[ I ] then Continue;
+ if FullPaths then
+ Result := Result + Path;
+ Result := Result + Names[ I ] + Separator;
+ end;
+end;
+
+procedure TDirList.DeleteItem(Idx: Integer);
+begin
+ FListPositions.Delete( Idx );
+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;
+ 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}
+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;
+ 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}
+end;
+
+{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+////////////////////////////////////////////////////////////////////////
+// R E G I S T R Y //
+////////////////////////////////////////////////////////////////////////
+
+{ -- registry -- }
+
+function RegKeyOpenRead( Key: HKey; const SubKey: KOLString ): HKey;
+begin
+ if RegOpenKeyEx( Key, PKOLChar( SubKey ), 0, KEY_READ, Result ) <> ERROR_SUCCESS then
+ Result := 0;
+end;
+
+function RegKeyOpenWrite( Key: HKey; const SubKey: KOLString ): HKey;
+begin
+ if RegOpenKeyEx( Key, PKOLChar( SubKey ), 0, KEY_READ or KEY_WRITE, Result ) <> ERROR_SUCCESS then
+ Result := 0;
+end;
+
+function RegKeyOpenCreate( Key: HKey; const SubKey: KOLString ): HKey;
+var dwDisp: DWORD;
+begin
+ if RegCreateKeyEx( Key, PKOLChar( SubKey ), 0, nil, 0, KEY_ALL_ACCESS, nil, Result,
+ @dwDisp ) <> ERROR_SUCCESS then
+ Result := 0;
+end;
+
+function RegKeyGetDw( Key: HKey; const ValueName: KOLString ): DWORD;
+var dwType, dwSize: DWORD;
+begin
+ dwSize := sizeof( DWORD );
+ Result := 0;
+ if (Key = 0) or
+ (RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType, PByte( @Result ), @dwSize ) <> ERROR_SUCCESS)
+ or (dwType <> REG_DWORD) then Result := 0;
+end;
+
+{$IFDEF REGKEYGETSTREX_ALWAYS}
+function RegKeyGetStr( Key: HKey; const ValueName: KOLString ): KOLString;
+begin
+ Result := RegKeyGetStrEx( Key, ValueName
+ {$IFDEF OPTIONAL_REG_EXPAND_SZ}, FALSE {$ENDIF} );
+end;
+{$ELSE}
+function RegKeyGetStr( Key: HKey; const ValueName: KOLString ): KOLString;
+var dwType, dwSize: DWORD;
+ Buffer: PKOLChar;
+
+ function Query: Boolean;
+ begin
+ Result := RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType,
+ Pointer( Buffer ), @dwSize ) = ERROR_SUCCESS;
+ end;
+begin
+ Result := '';
+ if Key = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ dwSize := 0;
+ Buffer := nil;
+ if not Query or (dwType <> REG_SZ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ GetMem( Buffer, dwSize * Sizeof( KOLChar ) );
+ if Query then
+ Result := Buffer;
+ FreeMem( Buffer );
+end;
+{$ENDIF}
+
+function RegKeyGetStrEx( Key: HKey; const ValueName: KOLString
+ {$IFDEF OPTIONAL_REG_EXPAND_SZ} ; ExpandEnvVars: Boolean {$ENDIF} ):
+KOLString;
+var dwType, dwSize: DWORD;
+ Buffer, Buffer2: PKOLChar;
+ Sz: Integer;
+ function Query: Boolean;
+ begin
+ Result := RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType,
+ Pointer( Buffer ), @dwSize ) = ERROR_SUCCESS;
+ end;
+begin
+ Result := '';
+ if Key = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ dwSize := 0;
+ Buffer := nil;
+ if not Query or ((dwType <> REG_SZ) and (dwtype <> REG_EXPAND_SZ)) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ GetMem( Buffer, dwSize * Sizeof( KOLChar ) );
+ if Query then
+ begin
+ if (dwtype = REG_EXPAND_SZ) {$IFDEF OPTIONAL_REG_EXPAND_SZ} and (ExpandEnvVars) {$ENDIF} then
+ begin
+ Sz := ExpandEnvironmentStrings(Buffer,nil,0);
+ GetMem(Buffer2,Sz * Sizeof( KOLChar )); //
+ ExpandEnvironmentStrings(Buffer, Buffer2, Sz); //
+ Result:=Buffer2; //
+ FreeMem(Buffer2); //
+ end else Result := Buffer;
+ end;
+ FreeMem( Buffer );
+end;
+
+function RegKeySetDw( Key: HKey; const ValueName: KOLString; Value: DWORD ): Boolean;
+begin
+ Result := (Key <> 0) and (RegSetValueEx( Key, PKOLChar( ValueName ), 0,
+ REG_DWORD, @Value, sizeof( DWORD ) ) = ERROR_SUCCESS);
+end;
+
+function RegKeySetStr( Key: HKey; const ValueName: KOLString; const Value: KOLString ): Boolean;
+begin
+ Result := (Key <> 0) and (RegSetValueEx( Key, PKOLChar( ValueName ), 0,
+ REG_SZ, PKOLChar(Value),
+ (Length( Value ) + 1)*Sizeof(KOLChar) ) = ERROR_SUCCESS);
+end;
+
+function RegKeySetStrEx( Key: HKey; const ValueName: KOLString; const Value: KOLString;
+ expand: Boolean): Boolean;
+var dwType: DWORD;
+begin
+ dwType := REG_SZ;
+ if expand then
+ dwType := REG_EXPAND_SZ;
+ Result := (Key <> 0) and (RegSetValueEx(Key, PKOLChar(ValueName), 0, dwType,
+ PKOLChar(Value), (Length(Value) + 1)*Sizeof(KOLChar)) = ERROR_SUCCESS);
+end;
+
+procedure RegKeyClose( Key: HKey );
+begin
+ if Key <> 0 then
+ RegCloseKey( Key );
+end;
+
+function RegKeyDelete( Key: HKey; const SubKey: KOLString ): Boolean;
+begin
+ Result := FALSE;
+ if Key <> 0 then
+ Result := RegDeleteKey( Key, PKOLChar( SubKey ) ) = ERROR_SUCCESS;
+end;
+
+function RegKeyDeleteValue( Key: HKey; const SubKey: KOLString ): Boolean;
+begin
+ Result := FALSE;
+ if Key <> 0 then
+ Result := RegDeleteValue( Key, PKOLChar( SubKey ) ) = ERROR_SUCCESS;
+end;
+
+function RegKeyExists( Key: HKey; const SubKey: KOLString ): Boolean;
+var K: Integer;
+begin
+ if Key = 0 then
+ begin
+ Result := FALSE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ K := RegKeyOpenRead( Key, SubKey );
+ Result := K <> 0;
+ if K <> 0 then
+ RegKeyClose( K );
+end;
+
+function RegKeyValExists( Key: HKey; const ValueName: KOLString ): Boolean;
+var dwType, dwSize: DWORD;
+begin
+ Result := (Key <> 0) and
+ (RegQueryValueEx( Key, PKOLChar( ValueName ), nil,
+ @dwType, nil, @dwSize ) = ERROR_SUCCESS);
+end;
+
+function RegKeyValueSize( Key: HKey; const ValueName: KOLString ): Integer;
+begin
+ Result := 0;
+ if Key = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ RegQueryValueEx( Key, PKOLChar( ValueName ), nil, nil, nil, @ DWORD( Result ) );
+end;
+
+function RegKeyGetBinary( Key: HKey; const ValueName: KOLString; var Buffer; Count: Integer ): Integer;
+begin
+ Result := 0;
+ if Key = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := Count;
+ RegQueryValueEx( Key, PKOLChar( ValueName ), nil, nil, @ Buffer, @ Result );
+end;
+
+function RegKeySetBinary( Key: HKey; const ValueName: KOLString; const Buffer; Count: Integer ): Boolean;
+begin
+ Result := (Key <> 0) and (RegSetValueEx( Key, PKOLChar( ValueName ), 0,
+ REG_BINARY, @ Buffer, Count ) = ERROR_SUCCESS);
+end;
+
+function RegKeyGetDateTime(Key: HKey; const ValueName: KOLString): TDateTime;
+begin
+ RegKeyGetBinary( Key, ValueName, Result, Sizeof( Result ) );
+end;
+
+function RegKeySetDateTime(Key: HKey; const ValueName: KOLString; DateTime: TDateTime): Boolean;
+begin
+ Result := RegKeySetBinary( Key, ValueName, DateTime, Sizeof( DateTime ) );
+end;
+
+{$IFDEF OLD_REGKEYGETSUBKEYS}
+//-----------------------------------------------
+// functions by Valerian Luft <luft@valerian.de>
+//-----------------------------------------------
+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)
+function RegKeyGetSubKeys(const Key: HKEY; List: PKOLStrList) : Boolean;
+var
+ i, MaxSubKeyLen, Size: DWORD;
+ Buf: PKOLChar;
+begin
+ Result:=false;
+ List.Clear;
+
+ if RegQueryInfoKey(Key, nil, nil, nil, nil, @MaxSubKeyLen, nil, nil, nil, nil,
+ nil, nil) = ERROR_SUCCESS then
+ begin
+ if MaxSubKeyLen > 0 then
+ begin
+ 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);
+ end;
+
+ FreeMem(Buf{,MaxSubKeyLen + 1});
+ end; // if MaxSubKeyLen
+ Result:=true;
+ end; // if RegQueryInfoKey
+
+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)
+function RegKeyGetValueNames(const Key: HKEY; List: PKOLStrList) : Boolean;
+var
+ i, MaxValueNameLen, Size: DWORD;
+ Buf: PKOLchar;
+begin
+ Result:=false;
+ List.Clear;
+
+ if RegQueryInfoKey(Key, nil, nil, nil, nil, nil, nil, nil, @MaxValueNameLen, nil,
+ nil, nil) = ERROR_SUCCESS then
+ begin
+ if MaxValueNameLen > 0 then
+ begin
+ Size:=MaxValueNameLen+1;
+ GetMem(Buf,Size * SizeOf(KOLChar) );
+ i:=0;
+ while RegEnumValue(Key,i,buf,Size,nil,nil,nil,nil) <> ERROR_NO_MORE_ITEMS do
+ begin
+ List.Add(KOLString(Buf));
+ Size:=MaxValueNameLen+1;
+ inc(i);
+ end;
+
+ FreeMem(Buf {,MaxValueNameLen + ... system always knows how long buffer is});
+ end; // if MaxValueNameLen
+ Result:=true;
+ end; // if RegQueryInfoKey
+
+end;
+{$ENDIF}
+
+function RegKeyGetValueTyp (const Key:HKEY; const ValueName: KOLString) : DWORD;
+begin
+Result:= Key ;
+if Key <> 0 then
+ RegQueryValueEx (Key,@ValueName[1],NIL,@Result,NIL,NIL)
+end;
+
+//////////////////////////////////////////////////////////////////////
+// D A T E A N D T I M E
+//////////////////////////////////////////////////////////////////////
+
+{ -- date and time utilities -- }
+
+{* This part of the unit contains date-time routines. It is not a simple compilation
+ of Delphi VCL date-time. E.g., TDateTime type is not based on 31-Dec-1899,
+ but it is based on 31-Dec-0000 instead, allowing easy manipulating of dates
+ at all Christian era, and all other historical era too. }
+
+{$UNDEF PAS_LOCAL}
+{$IFDEF F_P} {$DEFINE PAS_LOCAL} {$ENDIF}
+{$IFDEF PAS_ONLY} {$DEFINE PAS_LOCAL} {$ENDIF}
+
+procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: Word);
+{$IFDEF PAS_ONLY}
+begin
+ Result := Dividend div Divisor;
+ Remainder := Dividend mod Divisor;
+end;
+{$ELSE DELPHI}
+asm
+ PUSH EBX
+ MOV EBX,EDX
+ MOV EDX,EAX
+ SHR EDX,16
+ DIV BX
+ MOV EBX,Remainder
+ MOV [ECX],AX
+ MOV [EBX],DX
+ POP EBX
+end;
+{$ENDIF}
+
+function Now : TDateTime;
+var SystemTime : TSystemTime;
+begin
+ GetLocalTime( SystemTime );
+ SystemTime2DateTime( SystemTime, Result );
+end;
+
+function Date: TDateTime;
+begin
+ Result := Trunc( Now );
+end;
+
+procedure DecodeDateFully( DateTime: TDateTime; var Year, Month, Day, DayOfWeek: WORD );
+var ST: TSystemTime;
+begin
+ DateTime2SystemTime( DateTime, ST );
+ Year := ST.wYear;
+ Month := ST.wMonth;
+ Day := ST.wDay;
+ DayOfWeek := ST.wDayOfWeek;
+end;
+
+procedure DecodeDate( DateTime: TDateTime; var Year, Month, Day: WORD );
+var Dummy: Word;
+begin
+ DecodeDateFully( DateTime, Year, Month, Day, Dummy );
+end;
+
+function EncodeDate( Year, Month, Day: WORD; var DateTime: TDateTime ): Boolean;
+var ST: TSystemTime;
+begin
+ //FillChar( ST, Sizeof( ST ), #0 );
+ ZeroMemory( @ST, Sizeof(ST) );
+ ST.wYear := Year;
+ ST.wMonth := Month;
+ ST.wDay := Day;
+ Result := SystemTime2DateTime( ST, DateTime );
+end;
+
+procedure IncDays( var SystemTime : TSystemTime; DaysNum : Integer );
+var DateTime : TDateTime;
+begin
+ SystemTime2DateTime( SystemTime, DateTime );
+ DateTime := DateTime + DaysNum;
+ DateTime2SystemTime( DateTime, SystemTime );
+end;
+
+procedure IncMonths( var SystemTime : TSystemTime; MonthsNum : Integer );
+var M : Integer;
+ DateTime : TDateTime;
+begin
+ M := SystemTime.wMonth + MonthsNum - 1;
+ Inc( SystemTime.wYear, M div 12 );
+ SystemTime.wMonth := M mod 12 + 1;
+
+ // Normalize wDayOfWeek field:
+ SystemTime2DateTime( SystemTime, DateTime );
+ DateTime2SystemTime( DateTime, SystemTime );
+end;
+
+function IsLeapYear(Year: Integer): Boolean;
+begin
+ Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
+end;
+
+function SystemTime2DateTime(const SystemTime : TSystemTime; var DateTime : TDateTime ) : Boolean;
+{$IFDEF DATE0_1601}
+type
+ TTimeRec = record
+ CASE Integer OF
+ 0: ( ft: TFileTime );
+ 1: ( it: I64 );
+ END;
+var TR: TTimeRec;
+{$ELSE}
+var I : Integer;
+ _Day : Integer;
+ DayTable: PDayTable;
+{$ENDIF}
+begin
+ {$IFDEF DATE0_1601}
+//Result := FALSE;
+//if (SystemTime.wYear < 1601) or (SystemTime.wYear > 30827) then Exit; {>>>>>}
+ Result := SystemTimeToFileTime( SystemTime, TR.ft );
+ if Result then
+ DateTime := Int64( TR.it ) / (10000000.0 * 24 * 3600 ) + Date1601;
+ {$ELSE}
+ Result := False;
+ DateTime := 0.0;
+ DayTable := @MonthDays[IsLeapYear(SystemTime.wYear)];
+ with SystemTime do
+ if {(wYear >= 0) !always true! and} (wYear <= 9999) and
+ {(wMonth >= 1) and !otherwise can not convert time only!}
+ (wMonth <= 12) and
+ {(wDay >= 1) and !otherwise can not convert time only!}
+ (wDay <= DayTable^[wMonth])
+ {$IFDEF SAFEST_CODE}
+ and (wHour < 24) and (wMinute < 60)
+ and (wSecond < 60) and (wMilliSeconds < 1000)
+ {$ENDIF} then //
+ begin
+ _Day := wDay;
+ for I := 1 to wMonth - 1 do
+ Inc(_Day, DayTable^[I]);
+ I := wYear - 1;
+ //--------------- by Vadim Petrov ------++
+ if I<0 then i := 0; //
+ //--------------------------------------++
+ DateTime := (((wHour * 60 + wMinute) * 60 + wSecond) * 1000 + wMilliSeconds)
+ / MSecsPerDay;
+ DateTime := DateTime + I * 365 + I div 4 - I div 100 + I div 400 + _Day;
+ Result := True;
+ end;
+ {$ENDIF DATE0_0001}
+end;
+
+function DayOfWeek(Date: TDateTime): Integer;
+begin
+ Result := (Trunc( Date ) + 6) mod 7 + 1;
+end;
+
+{$IFDEF DATE0_1601}
+
+{$UNDEF ASM_LOCAL}
+{$IFDEF ASM_VERSION}
+{$IFDEF _D6orHigher} {$DEFINE ASM_LOCAL}
+{$ENDIF}
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_LOCAL}
+function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
+asm
+ PUSH EDI
+ XCHG EDI, EAX
+ FLD qword ptr [DateTime]
+ FSUB dword ptr [@@date1601]
+ FLD tbyte ptr [@@nsecsperday]
+ DB $DE, $C9 //FMULP ST(1)
+ JMP @@truncD7
+@@date1601: DB $50, $AC, $0E, $49
+@@nsecsperday: DB 0,0,0,0,$C0,$69,$2A,$C9,$26,$40
+@@truncD7: CALL System.@TRUNC
+ PUSH EDX
+ PUSH EAX
+ MOV EAX, ESP
+ PUSH EDI
+ PUSH EAX
+ CALL Windows.FileTimeToSystemTime
+ POP ECX
+ POP ECX
+ CMP EAX, 1
+ SBB EAX, EAX
+ INC EAX
+ POP EDI
+end;
+{$ELSE}
+function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
+type
+ TTimeRec = record
+ CASE Integer OF
+ 0: ( ft: TFileTime );
+ 1: ( it: I64 );
+ END;
+var TR: TTimeRec;
+ {$IFnDEF _D6orHigher}
+ DD, DH, DL: Double;
+ {$ENDIF}
+begin
+ {$IFDEF _D6orHigher}
+ TR.it := I64(
+ Trunc( (DateTime - Date1601) * (24.0 * 3600 * 10000000) ) );
+ {$ELSE}
+ DD := Trunc( (DateTime - Date1601) * (24.0 * 3600 * 10000000) );
+ DH := DD / (4.0 * 1024.0 * 1024.0 * 1024.0);
+ TR.it.Hi := Trunc( DH );
+ DL := DD - TR.it.Hi * (4.0 * 1024.0 * 1024.0);
+ TR.it.Lo := Trunc( DL );
+ {$ENDIF}
+ Result := FileTimeToSystemTime( TR.ft, SystemTime );
+end;
+{$ENDIF PAS_VERSION}
+{$ELSE DATE0_0001}
+
+{$UNDEF ASM_LOCAL}
+{$IFDEF ASM_VERSION}
+{$IFDEF DATE0_0001}
+ {$DEFINE ASM_LOCAL}
+{$ENDIF DATE0_0001}
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_LOCAL}
+var _MSecsPerDay: Double = MSecsPerDay;
+//function DateTime2SystemTime_Asm(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
+function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
+const
+ D1 = 365;
+ D4 = D1 * 4 + 1;
+ D100 = D4 * 25 - 1;
+ D400 = D100 * 4 + 1;
+asm
+ PUSH EBX
+ PUSH ESI
+ PUSH EDI
+ MOV ESI, SystemTime
+ FLD QWORD PTR [DateTime]
+ CALL System.@TRUNC
+ XCHG EDI, EAX // EDI = Days
+ PUSH EDI
+ FILD DWORD PTR [ESP]
+ POP ECX
+ FSUBR QWORD PTR [DateTime]
+ FMUL QWORD PTR [_MSecsPerDay]
+ CALL System.@ROUND
+ XCHG EBX, EAX // EBX = MSecs
+ XOR EAX, EAX
+ CMP EDI, EAX
+ JLE @@retFalse
+
+ DEC EDI
+ INC EAX // EAX = Y = 1
+ MOV ECX, D400
+@@while1:CMP EDI, ECX
+ JL @@1end
+ SUB EDI, ECX
+ ADD EAX, 400
+ JMP @@while1
+@@1end: PUSH EAX
+
+ MOV EAX, EDI
+ XOR EDX, EDX
+ MOV ECX, D100
+ DIV ECX // EAX = division = I, EDX = reminder = D
+ CMP EAX, 4
+ JNZ @@4
+ DEC EAX
+ ADD EDX, D100
+@@4:
+ XCHG EDX, [ESP] // EDX = Y, [ESP] = D
+ MOV ECX, EDX
+ XOR EDX, EDX
+ OR DL, 100
+ MUL EDX // EAX = I * 100
+ ADD ECX, EAX // ECX = Y + I * 100
+ XCHG [ESP], ECX // ECX = D, [ESP] = Y
+
+ XCHG EAX, ECX
+ XOR EDX, EDX
+ MOV ECX, D4
+ DIV ECX // EAX = [D/D4] = I, EDX = D mod D4 = D
+ SHL EAX, 2
+ ADD [ESP], EAX // Y := Y + I * 4;
+
+ XCHG EAX, EDX
+ XOR EDX, EDX
+ XOR ECX, ECX
+ MOV CX, D1
+ DIV ECX
+
+ CMP EAX, 4
+ JNZ @@4x
+ DEC EAX
+ ADD EDX, D1
+@@4x:
+ POP ECX
+ ADD EAX, ECX // inc( Y, I )
+
+ PUSH EDX // save D
+ MOV [ESI].TSystemTime.wYear, AX
+ CALL IsLeapYear
+ SHR EAX, 1
+ SBB EAX, EAX
+ AND EAX, 12
+ LEA ECX, [EAX+MonthDays]// ECX = DayTable
+ POP EAX // restore D
+ PUSH ECX
+@@whTrue:
+ MOVZX EDX, byte ptr [ECX]
+ CMP EAX, EDX
+ JL @@brk
+ SUB EAX, EDX
+ INC ECX
+ JMP @@whTrue
+@@brk:
+ POP EDX
+ SUB ECX, EDX
+ INC ECX
+ MOV [ESI].TSystemTime.wMonth, CX
+ INC EAX
+ MOV [ESI].TSystemTime.wDay, AX
+
+ PUSH dword ptr [DateTime+4]
+ PUSH dword ptr [DateTime]
+ CALL KOL.DayOfWeek
+ MOV [ESI].TSystemTime.wDayOfWeek, AX
+
+ XCHG EAX, EBX
+ XOR EDX, EDX
+ MOV ECX, 60000
+ DIV ECX // EAX = MinCount, EDX = MSecCount
+ PUSH EDX
+ XOR EDX, EDX
+ XOR ECX, ECX
+ MOV CL, 60
+ DIV ECX // EAX = hours, EDX = minutes
+ MOV [ESI].TSystemTime.wHour, AX
+ MOV [ESI].TSystemTime.wMinute, DX
+ POP EAX
+ XOR EDX, EDX
+ MOV CX, 1000
+ DIV ECX // EAX = seconds, EDX = milliseconds
+ MOV [ESI].TSystemTime.wSecond, AX
+ MOV [ESI].TSystemTime.wMilliseconds, DX
+ MOV AL, 1
+@@retFalse:
+ POP EDI
+ POP ESI
+ POP EBX
+end;
+{$ELSE PAS_VERSION}
+//function DateTime2SystemTime_Pas(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
+function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
+const
+ D1 = 365;
+ D4 = D1 * 4 + 1;
+ D100 = D4 * 25 - 1;
+ D400 = D100 * 4 + 1;
+var Days : Integer;
+ Y, M, D, I: Word;
+ MSec : Integer;
+ DayTable: PDayTable;
+ MinCount, MSecCount: Word;
+begin
+ Days := Trunc( DateTime );
+ MSec := Round((DateTime - Days) * MSecsPerDay);
+ Result := False;
+ if IsNAN( DateTime ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ with SystemTime do
+ if Days > 0 then
+ begin
+ Dec(Days);
+ Y := 1;
+ while Days >= D400 do
+ begin
+ Dec(Days, D400);
+ Inc(Y, 400);
+ end;
+ DivMod(Days, D100, I, D);
+ if I = 4 then
+ begin
+ Dec(I);
+ Inc(D, D100);
+ end;
+ Inc(Y, I * 100);
+ DivMod(D, D4, I, D);
+ Inc(Y, I * 4);
+ DivMod(D, D1, I, D);
+ if I = 4 then
+ begin
+ Dec(I);
+ Inc(D, D1);
+ end;
+ Inc(Y, I);
+ DayTable := @MonthDays[IsLeapYear(Y)];
+ M := 1;
+ while True do
+ begin
+ I := DayTable^[M];
+ if D < I then Break;
+ Dec(D, I);
+ Inc(M);
+ end;
+ wYear := Y;
+ wMonth := M;
+ wDay := D + 1;
+ wDayOfWeek := KOL.DayOfWeek( DateTime );
+ DivMod(MSec, 60000, MinCount, MSecCount);
+ DivMod(MinCount, 60, wHour, wMinute);
+ DivMod(MSecCount, 1000, wSecond, wMilliSeconds);
+ Result := True;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF DATE0_0001}
+
+{function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
+var ST_Pas, ST_Asm: TSystemTime;
+begin
+ if IsNAN( DateTime ) then
+ asm
+ nop
+ end;
+ Result := DateTime2SystemTime_Pas( DateTime, ST_Pas );
+ DateTime2SystemTime_Asm( DateTime, ST_Asm );
+ if Result and not CompareMem( @ ST_Asm, @ST_Pas, Sizeof( TSystemTime ) ) then
+ while TRUE do
+ begin
+ DateTime2SystemTime_Pas( DateTime, ST_Pas );
+ DateTime2SystemTime_Asm( DateTime, ST_Asm );
+ end;
+ Result := DateTime2SystemTime_Pas( DateTime, SystemTime );
+end;}
+
+function DateTime_DiffSysLoc: TDateTime;
+var ST, LT: TSystemTime;
+ FT, FT1: TFileTime;
+ D1, D2: TDateTime;
+begin
+ GetSystemTime( ST );
+ SystemTimeToFileTime( ST, FT );
+ FileTimeToLocalFileTime( FT, FT1 );
+ FileTimeToSystemTime( FT1, LT );
+ SystemTime2DateTime( ST, D1 );
+ SystemTime2DateTime( LT, D2 );
+ Result := D2 - D1;
+end;
+
+function DateTime_System2Local( DTSys: TDateTime ): TDateTime;
+begin
+ Result := DTSys + DateTime_DiffSysLoc;
+end;
+
+function DateTime_Local2System( DTLoc: TDateTime ): TDateTime;
+begin
+ Result := DTLoc - DateTime_DiffSysLoc;
+end;
+
+function FileTime2DateTime( const ft: TFileTime; var DT: TDateTime ): Boolean;
+var ft1: TFileTime;
+ st: TSystemTime;
+begin
+ Result := FileTimeToLocalFileTime( ft, ft1 ) and
+ FileTimeToSystemTime( ft1, st ) and
+ SystemTime2DateTime( st, dt );
+end;
+
+function DateTime2FileTime( DT: TDateTime; var ft: TFileTime ): Boolean;
+var st: TSystemTime;
+begin
+ Result := DateTime2SystemTime( DT, ST ) and
+ SystemTimeToFileTime( st, ft ) and
+ LocalFileTimeToFileTime( ft, ft );
+end;
+
+function SystemDate2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;
+ const DfltDateFormat : TDateFormat;
+ const DateFormat : PKOLChar ) : KOLString;
+var Buf : PKOLChar;
+ Sz : Integer;
+ Flags : DWORD;
+begin
+ Sz := 100;
+ Buf := nil;
+ Result := '';
+ Flags := 0;
+ if DateFormat = nil then
+ if DfltDateFormat = dfShortDate then
+ Flags := DATE_SHORTDATE
+ else Flags := DATE_LONGDATE;
+ while True do
+ begin
+ if Buf <> nil then
+ FreeMem( Buf );
+ GetMem( Buf, Sz * Sizeof( KOLChar ) );
+ if Buf = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if GetDateFormat( LocaleID, Flags, @SystemTime, DateFormat, Buf, Sz ) = 0 then
+ begin
+ if GetLastError = ERROR_INSUFFICIENT_BUFFER then
+ Sz := Sz * 2
+ else break;
+ end else
+ begin
+ Result := Buf;
+ break;
+ end;
+ end;
+ if Buf <> nil then
+ FreeMem( Buf );
+end;
+
+function SystemTime2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;
+ const Flags : TTimeFormatFlags;
+ const TimeFormat : PKOLChar ) : KOLString;
+var Buf : PKOLChar;
+ Sz : Integer;
+ Flg : DWORD;
+begin
+ Sz := 100;
+ Buf := nil;
+ Result := '';
+ Flg := 0;
+ if tffNoMinutes in Flags then
+ Flg := TIME_NOMINUTESORSECONDS
+ else if tffNoSeconds in Flags then
+ Flg := TIME_NOSECONDS;
+ if tffNoMarker in Flags then
+ Flg := Flg or TIME_NOTIMEMARKER;
+ if tffForce24 in Flags then
+ Flg := Flg or TIME_FORCE24HOURFORMAT;
+ while True do
+ begin
+ if Buf <> nil then
+ FreeMem( Buf );
+ GetMem( Buf, Sz * Sizeof( KOLChar ) );
+ if Buf = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if GetTimeFormat( LocaleID, Flg, @SystemTime, TimeFormat, Buf, Sz )
+ = 0 then
+ begin
+ if GetLastError = ERROR_INSUFFICIENT_BUFFER then
+ Sz := Sz * 2
+ else break;
+ end else
+ begin
+ Result := Buf;
+ break;
+ end;
+ end;
+ if Buf <> nil then
+ FreeMem( Buf );
+end;
+
+function Date2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString;
+var ST: TSystemTime;
+ lpFmt: PKOLChar;
+begin
+ DateTime2SystemTime( D, ST );
+ lpFmt := nil;
+ if Fmt <> '' then lpFmt := PKOLChar( Fmt );
+ Result := SystemDate2Str( ST, LOCALE_USER_DEFAULT, dfShortDate, lpFmt );
+end;
+
+function Time2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString;
+var ST: TSystemTime;
+ lpFmt: PKOLChar;
+begin
+ if D < 1 then D := D + 700000;
+ DateTime2SystemTime( D, ST );
+ lpFmt := nil;
+ if Fmt <> '' then lpFmt := PKOLChar( Fmt );
+ Result := SystemTime2Str( ST, LOCALE_USER_DEFAULT, [], lpFmt );
+end;
+
+function DateTime2StrShort( D: TDateTime ): KOLString;
+var ST: TSystemTime;
+begin
+ //--------- by Vadim Petrov --------++
+ if D < 1 then D := D + 1; //
+ //----------------------------------++
+ DateTime2SystemTime( D, ST );
+ Result := SystemDate2Str( ST, LOCALE_USER_DEFAULT {GetUserDefaultLCID}, dfShortDate, nil ) + ' ' +
+ SystemTime2Str( ST, LOCALE_USER_DEFAULT {GetUserDefaultLCID}, [], nil );
+end;
+
+function Str2DateTimeFmt( const sFmtStr, sS: KOLString ): TDateTime;
+var h12, hAM: Boolean;
+ FmtStr, S: PKOLChar;
+
+ function GetNum( var S: PKOLChar; NChars: Integer ): Integer;
+ begin
+ Result := 0;
+ while (S^ <> #0) and (NChars <> 0) do
+ begin
+ Dec( NChars );
+ if (S^ >= '0') and (S^ <= '9') then
+ begin
+ Result := Result * 10 + Ord(S^) - Ord('0');
+ Inc( S );
+ end else break;
+ end;
+ end;
+
+ function GetYear( var S: PKOLChar; NChars: Integer ): Integer;
+ var STNow: TSystemTime;
+ OldDate: Boolean;
+ begin
+ Result := GetNum( S, NChars );
+ GetSystemTime( STNow );
+ OldDate := (Result >= 50) and (Result < 100);
+ Result := Result + STNow.wYear - STNow.wYear mod 100;
+ if OldDate then Dec( Result, 100 );
+ end;
+
+ function GetMonth( const fmt: KOLString; var S: PKOLChar ): Integer;
+ var SD: TSystemTime;
+ M: Integer;
+ MonthStr: KOLString;
+ begin
+ GetSystemTime( SD );
+ SD.wDay := 1;
+ for M := 1 to 12 do
+ begin
+ SD.wMonth := M;
+ MonthStr := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt {+ '/dd/yyyy/'} ) );
+ //MonthStr := Parse( C, '/' ); //++ -- by GMax
+ if AnsiCompareStrNoCase( MonthStr, Copy( S, 1, Length( MonthStr ) ) ) = 0 then
+ begin
+ Inc( S, Length( MonthStr ) );
+ Result := M; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ Result := 1;
+ end;
+
+ procedure SkipDayOfWeek( const fmt: KOLString; var S: PKOLChar );
+ var SD: TSystemTime;
+ Dt: TDateTime;
+ D: Integer;
+ C, DayWeekStr: KOLString;
+ begin
+ GetSystemTime( SD );
+ SystemTime2DateTime( SD, Dt );
+ Dt := Dt - SD.wDayOfWeek;
+ for D := 0 to 6 do
+ begin
+ DateTime2SystemTime( Dt, SD );
+ C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/MM/yyyy/' ) );
+ DayWeekStr := Parse( C, '/' );
+ if AnsiCompareStrNoCase( DayWeekStr, Copy( S, 1, Length( DayWeekStr ) ) ) = 0 then
+ begin
+ Inc( S, Length( DayWeekStr ) );
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Dt := Dt + 1.0;
+ end;
+ end;
+
+ procedure GetTimeMark( const fmt: KOLString; var S: PKOLChar );
+ var SD: TSystemTime;
+ AM: Boolean;
+ C, TimeMarkStr: KOLString;
+ begin
+ GetSystemTime( SD );
+ SD.wHour := 0;
+ for AM := FALSE to TRUE do
+ begin
+ C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/HH/mm' ) );
+ TimeMarkStr := Parse( C, '/' );
+ if AnsiCompareStrNoCase( TimeMarkStr, Copy( S, 1, Length( TimeMarkStr ) ) ) = 0 then
+ begin
+ Inc( S, Length( TimeMarkStr ) );
+ hAM := AM;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ SD.wHour := 13;
+ end;
+ Result := 1;
+ end;
+
+ function FmtIs1( S: PKOLChar ): Boolean;
+ begin
+ if StrIsStartingFrom( FmtStr, S ) then
+ begin
+ Inc( FmtStr, {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}( S ) );
+ Result := TRUE;
+ end else Result := FALSE;
+ end;
+
+ function FmtIs( S1, S2: PKOLChar ): Boolean;
+ begin
+ Result := FmtIs1( S1 ) or FmtIs1( S2 );
+ end;
+
+var ST: TSystemTime;
+begin
+ FmtStr := PKOLChar( sFmtStr);
+ S := PKOLChar( sS );
+ //FillChar( ST, Sizeof( ST ), #0 );
+ ZeroMemory( @ST, Sizeof( ST ) );
+ h12 := FALSE;
+ hAM := FALSE;
+ while (FmtStr^ <> #0) and (S^ <> #0) do
+ begin
+ if ((FmtStr^ >= 'a') and (FmtStr^ <= 'z') or
+ (FmtStr^ >= 'A') and (FmtStr^ <= 'Z')) and
+ (S^ >= '0') and (S^ <= '9') then
+ begin
+ if FmtIs1( 'yyyy' ) then ST.wYear := GetNum( S, 4 )
+ else if FmtIs1( 'yy' ) then ST.wYear := GetYear( S, 2 )
+ else if FmtIs1( 'y' ) then ST.wYear := GetYear( S, -1 )
+ else if FmtIs( 'dd', 'd' ) then ST.wDay := GetNum( S, 2 )
+ else if FmtIs( 'MM', 'M' ) then ST.wMonth := GetNum( S, 2 )
+ else if FmtIs( 'HH', 'H' ) then ST.wHour := GetNum( S, 2 )
+ else if FmtIs( 'hh', 'h' ) then begin ST.wHour := GetNum( S, 2 ); h12 := TRUE end
+ else if FmtIs( 'mm', 'm' ) then ST.wMinute := GetNum( S, 2 )
+ else if FmtIs( 'ss', 's' ) then ST.wSecond := GetNum( S, 2 )
+ else break; // + ECM
+ end
+ else
+ if (FmtStr^ = 'M') or (FmtStr^ = 'd') or (FmtStr^ = 'g') then
+ begin
+ if FmtIs1( 'MMMM' ) then ST.wMonth := GetMonth( 'MMMM', S )
+ else if FmtIs1( 'MMM' ) then ST.wMonth := GetMonth( 'MMM', S )
+ else if FmtIs1( 'dddd' ) then SkipDayOfWeek( 'dddd', S )
+ else if FmtIs1( 'ddd' ) then SkipDayOfWeek( 'ddd', S )
+ else if FmtIs1( 'tt' ) then GetTimeMark( 'tt', S )
+ else if FmtIs1( 't' ) then GetTimeMark( 't', S )
+ else break; // + ECM
+ end
+ else
+ begin
+ if FmtStr^ = S^ then
+ Inc( FmtStr );
+ Inc( S );
+ end;
+ end;
+
+ if h12 then
+ if hAM then
+ Inc( ST.wHour, 12 );
+
+ SystemTime2DateTime( ST, Result );
+end;
+
+function Str2TimeFmt(const sFmtStr, sS: KOLString): TDateTime;
+begin
+ Result := Frac(Str2DateTimeFmt( 'y/M/d ' + sFmtStr, '2000/1/1 ' + sS ));
+end;
+
+var FmtBuf: PKOLChar;
+ DateSeparator : KOLChar = #0; // + ECM
+
+function Str2DateTimeShort( const S: KOLString ): TDateTime;
+var FmtStr, FmtStr2: KOLString;
+
+ function EnumDateFmt( lpstrFmt: PKOLChar ): Boolean; stdcall;
+ begin
+ GetMem( FmtBuf, ({$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}
+ ( lpstrFmt ) + 1) * Sizeof( KOLChar ) );
+ {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
+ ( FmtBuf, lpstrFmt );
+ Result := FALSE;
+ end;
+
+begin
+ FmtStr := 'dd.MM.yyyy';
+ FmtBuf := nil;
+ EnumDateFormats( @ EnumDateFmt, LOCALE_USER_DEFAULT, DATE_SHORTDATE );
+ if FmtBuf <> nil then
+ begin
+ FmtStr := FmtBuf;
+ FreeMem( FmtBuf );
+ end;
+
+ FmtStr2 := 'H:mm:ss';
+ FmtBuf := nil;
+ EnumTimeFormats( @ EnumDateFmt, LOCALE_USER_DEFAULT, 0 );
+ if FmtBuf <> nil then
+ begin
+ FmtStr2 := FmtBuf;
+ FreeMem( FmtBuf );
+ end;
+
+ Result := Str2DateTimeFmt( FmtStr + ' ' + FmtStr2, S );
+end;
+
+function Str2TimeShort(const S: KOLString): TDateTime;
+begin
+ Result := Frac( Str2DateTimeShort( Date2StrFmt( '', Now ) + ' ' + S ) );
+end;
+
+// + ECM
+function Str2DateTimeShortEx( const S: KOLString ): TDateTime;
+var
+ Buff: Array[0..1] of KOLChar;
+begin
+ if DateSeparator = #0 then
+ begin
+ if GetLocaleInfo(GetThreadLocale,LOCALE_SDATE,Buff,2) > 0 then
+ DateSeparator := Buff[0];
+ end;
+ if Pos(DateSeparator,S) = 0 then
+ //St := '0.0.0 '+S;
+ Result := Str2TimeShort(S)
+ else
+ Result := Str2DateTimeShort(S);
+end;
+
+///////////////////////////////////////////////////////////////////////
+// T H R E A D S
+///////////////////////////////////////////////////////////////////////
+
+{ -- Thread -- }
+
+function ThreadFunc(Thread: PThread): integer; stdcall;
+begin
+ Result := Thread.Execute;
+end;
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewThread: PThread;
+begin
+ new( Result, ThreadCreate );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TThread';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+function NewThread: PThread;
+begin
+ {$IFNDEF FPC105ORBELOW}
+ IsMultiThread := True;
+ {$ENDIF}
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TThread';
+ {$ENDIF}
+ Result.FSuspended := True;
+ {$IFDEF PSEUDO_THREADS}
+ {$ELSE}
+ Result.FHandle := CreateThread( nil, // no security
+ 0, // the same stack size
+ @ThreadFunc, // thread entry point
+ Result, // parameter to pass to ThreadFunc
+ CREATE_SUSPENDED, // always SUSPENDED
+ Result.FThreadID ); // receive thread ID
+ {$ENDIF}
+end;
+{$ENDIF USE_CONSTRUCTORS}
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewThreadEx( const Proc: TOnThreadExecute ): PThread;
+begin
+ new( Result, ThreadCreateEx( Proc ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TThreadEx';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_!VERSION}
+function NewThreadEx( const Proc: TOnThreadExecute ): PThread;
+asm
+ CALL NewThread
+ POP EBP
+ POP ECX
+ POP EDX
+ MOV [EAX].TThread.fOnExecute.TMethod.Code, EDX
+ POP EDX
+ MOV [EAX].TThread.fOnExecute.TMethod.Data, EDX
+ PUSH ECX
+ PUSH EAX
+ CALL TThread.Resume
+ POP EAX
+ RET
+end;
+{$ELSE PAS_VERSION} //Pascal
+function NewThreadEx( const Proc: TOnThreadExecute ): PThread;
+begin
+ Result := NewThread;
+ Result.OnExecute := Proc;
+ Result.Resume;
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+function NewThreadAutoFree( const Proc: TOnThreadExecute ): PThread;
+begin
+ Result := NewThread;
+ Result.OnExecute := Proc;
+ Result.F_AutoFree := TRUE;
+ {$IFDEF SAFE_CODE}
+ if Assigned( Proc ) then
+ {$ENDIF}
+ Result.Resume;
+end;
+
+{ TThread }
+
+function WndProcCMExec( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
+ : Boolean;
+var Thread: PThread;
+begin
+ Result := FALSE;
+ if Msg.message = CM_EXECPROC then
+ begin
+ Thread := PThread( Msg.lParam );
+ if Msg.wParam <> 0 then
+ Thread.FMethodEx( Thread, Pointer( Msg.wParam ) )
+ else Thread.FMethod( );
+ Rslt := 0;
+ end;
+end;
+
+{$IFDEF PSEUDO_THREADS}
+function timeBeginPeriod(uPeriod: UINT): UINT; stdcall;
+external 'winmm.dll' name 'timeBeginPeriod';
+function timeEndPeriod(uPeriod: UINT): UINT; stdcall;
+external 'winmm.dll' name 'timeEndPeriod';
+{$ENDIF}
+
+procedure TThread.Init;
+begin
+ {$IFDEF CALL_INHERITED}
+ inherited;
+ {$ENDIF}
+ if Applet <> nil then
+ Applet.AttachProc( WndProcCMExec );
+ {$IFDEF PSEUDO_THREADS}
+ if (MainThread = nil) and not CreatingMainThread then
+ begin // creating main thread
+ CreatingMainThread := TRUE;
+ new( MainThread, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ MainThread.fObjKind := 'MainThread';
+ {$ENDIF}
+ CreatingMainThread := FALSE;
+ end;
+ if CreatingMainThread then
+ begin
+ MainThread := @ Self;
+ {MainThread.}AllThreads := NewList;
+ {MainThread.}CurrentThread := MainThread;
+ TimeBeginPeriod( 10 );
+ end;
+ if not CreatingMainThread and (MainThread <> @ Self) then
+ begin // creating other threads
+ GetMem( StackBottom, PseudoThreadStackSize );
+ CurStackPos := Pointer( DWORD( StackBottom ) + PseudoThreadStackSize );
+ Stack_Empty := TRUE;
+ end;
+ MainThread.AllThreads.Add( @ Self );
+ {$ENDIF}
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TThread.Destroy;
+begin
+ RefInc;
+ if not FTerminated then
+ begin
+ Terminate;
+ WaitFor;
+ end;
+ if (FHandle <> 0) then
+ CloseHandle(FHandle);
+ {$IFDEF PSEUDO_THREADS}
+ if StackBottom <> nil then
+ FreeMem( StackBottom );
+ if MainThread = @ Self then
+ begin
+ TimeEndPeriod( 10 );
+ AllThreads.Free;
+ end else
+ if MainThread <> nil then
+ begin
+ MainThread.AllThreads.Remove( @ Self );
+ if MainThread.AllThreads.Count <= 1 then
+ Free_And_Nil( MainThread );
+ end;
+ {$ENDIF}
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+function TThread.Execute: integer;
+{$IFDEF TERMAUTOFREE_THREAD}
+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)
+ if F_AutoFree then
+ begin
+ {$IFDEF TERMAUTOFREE_THREAD}
+ H := FHandle;
+ {$ENDIF}
+ CloseHandle( FHandle );
+ FHandle := 0;
+ Free;
+ {$IFDEF TERMAUTOFREE_THREAD}
+ TerminateThread( H, 0 );
+ {$ENDIF}
+ end;
+end;
+
+function TThread.GetPriorityCls: Integer;
+begin
+ {$IFDEF PSEUDO_THREADS}
+ Result := FPrtyCls;
+ {$ELSE}
+ Result := GetPriorityClass(FHandle);
+ {$ENDIF}
+end;
+
+function TThread.GetThrdPriority: Integer;
+begin
+ {$IFDEF PSEUDO_THREADS}
+ Result := FPriority;
+ {$ELSE}
+ Result := GetThreadPriority(FHandle);
+ {$ENDIF}
+end;
+
+procedure TThread.Resume;
+begin
+ {$IFDEF PSEUDO_THREADS}
+ if MainThread.CurrentThread = @ Self then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>}
+ MainThread.SwitchToThread( @ Self );
+ {$ELSE}
+ FSuspended := False;
+ if (ResumeThread(FHandle) > 1) then
+ FSuspended := True
+ else if Assigned(FOnResume) then
+ FOnResume(@Self);
+ {$ENDIF}
+end;
+
+procedure TThread.SetPriorityCls(Value: Integer);
+begin
+ {$IFDEF DEBUG_ANY}
+ if not SetPriorityClass(GetCurrentProcess, Value) then
+ begin
+ ShowMessage( SysErrorMessage( GetLastError ) );
+ end;
+ {$ELSE}
+ {$IFDEF PSEUDO_THREADS}
+ FPrtyCls := Value;
+ {$ELSE}
+ SetPriorityClass(GetCurrentProcess, Value);
+ {$ENDIF}
+ {$ENDIF DEBUG_ANY}
+end;
+
+procedure TThread.SetThrdPriority(Value: Integer);
+begin
+ FPriority := Value;
+ {$IFDEF PSEUDO_THREADS}
+ {$ELSE}
+ SetThreadPriority(FHandle, Value);
+ {$ENDIF}
+end;
+
+procedure TThread.Suspend;
+begin
+ {$IFDEF PSEUDO_THREADS}
+ if MainThread <> @ Self then
+ FSuspended := TRUE;
+ if MainThread.CurrentThread = @ Self then
+ MainThread.NextThread;
+ {$ELSE}
+ FSuspended := TRUE;
+ if Assigned(FOnSuspend) then
+ Synchronize( FOnSuspend );
+ SuspendThread(FHandle);
+ {$ENDIF}
+end;
+
+{$IFDEF PSEUDO_THREADS}
+procedure FinishThread;
+begin
+ MainThread.CurrentThread.fTerminated := TRUE;
+ MainThread.CurrentThread.Stack_Empty := TRUE;
+ MainThread.NextThread;
+end;
+
+procedure TThread.SwitchToThread(T: PThread);
+begin
+ {$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;
+ asm
+ mov edx, [T]
+ // 1. Suspending current thread
+ mov ecx, [MainThread]
+ mov eax, [ecx].CurrentThread
+ push ebx
+ push ebp
+ push esi
+ push edi
+ mov [eax].CurStackPos, esp
+ mov [eax].Stack_Empty, 0
+ // 2. Switching to another thread
+
+ mov [ecx].CurrentThread, edx
+
+ cmp [edx].Stack_Empty, 0
+ jz @@1
+ // the first call
+ mov [edx].Stack_Empty, 0
+ cmp [edx].FSuspended, 0
+ jz @@0
+ mov [edx].FSuspended, 0
+
+ mov esp, [edx].CurStackPos
+ mov ecx, [edx].fOnResume.TMethod.Code
+ jecxz @@0
+ mov eax, [edx].fOnResume.TMethod.Data
+ call ecx // calling OnResume for resuming thread
+ @@0:
+ mov eax, [edx].fOnExecute.TMethod.Data
+ mov ecx, [edx].fOnExecute.TMethod.Code
+ push offset [FinishThread] // if thread will be finished it will jump there
+ jmp ecx
+ @@1:
+ // other calls - resuming
+ mov esp, [edx].CurStackPos
+ pop edi
+ pop esi
+ pop ebp
+ pop ebx
+ cmp [edx].FSuspended, 0
+ jz @@2
+ mov [edx].FSuspended, 0
+
+ mov ecx, [edx].fOnResume.TMethod.Code
+ jecxz @@2
+ mov eax, [edx].fOnResume.TMethod.Data
+ call ecx // calling OnResume for resuming thread
+ @@2:
+ end;
+ // At this point, thread is resumed
+end;
+
+procedure TThread.NextThread;
+var i: Integer;
+ T: PThread;
+ C: DWORD;
+begin
+ i := MainThread.AllThreads.IndexOf( MainThread.CurrentThread );
+ if i >= 0 then
+ begin
+ C := GetTickCount;
+ while TRUE do
+ begin
+ inc( i );
+ if i >= MainThread.AllThreads.Count then i := 0;
+ T := MainThread.AllThreads.Items[ i ];
+ if (T.DoNotWakeUntil > C) and (T <> MainThread) then continue;
+ if (T = MainThread) and (MainThread.CurrentThread = T) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if not T.Terminated and not ((T <> MainThread) and (T.Suspended)) then
+ begin
+ break;
+ end;
+ end;
+ MainThread.SwitchToThread( MainThread.AllThreads.Items[ i ] );
+ end;
+end;
+
+procedure Sleep( n: DWORD );
+begin
+ if Assigned( MainThread ) then
+ begin
+ MainThread.CurrentThread.DoNotWakeUntil := GetTickCount + n;
+ MainThread.NextThread;
+ end else
+ if n > 0 then Windows.Sleep( n );
+end;
+
+function WaitForMultipleObjects( nCount: DWORD;
+ lpHandles: PHandle; fWaitAll: BOOL; dwMilliseconds: DWORD ): DWORD; stdcall;
+var i: Integer;
+ w: DWORD;
+ Ph: PHandle;
+ Limit: DWORD;
+begin
+ if dwMilliseconds = INFINITE then
+ Limit := INFINITE
+ else Limit := GetTickCount + dwMilliseconds;
+ while TRUE do
+ begin
+ Ph := lpHandles;
+ w := 0;
+ for i := 0 to nCount-1 do
+ begin
+ if Windows.WaitForSingleObject( Ph^, 0 ) = WAIT_OBJECT_0 then
+ begin
+ inc( w );
+ if not fWaitAll then
+ begin
+ Result := WAIT_OBJECT_0 + i; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ inc( Ph );
+ end;
+ if w = nCount then
+ begin
+ Result := WAIT_OBJECT_0; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if (Limit <> INFINITE) and (GetTickCount > Limit) then
+ begin
+ Result := WAIT_TIMEOUT; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if Assigned( MainThread ) then
+ MainThread.NextThread;
+ {$IFDEF WAIT_SLEEP}
+ Sleep( 10 );
+ {$ENDIF}
+ end;
+end;
+
+function WaitForSingleObject( hHandle: THandle; dwMilliseconds: DWORD ): DWORD; stdcall;
+begin
+ Result := WaitForMultipleObjects( 1, @ hHandle, TRUE, dwMilliseconds );
+end;
+{$ENDIF PSEUDO_THREADS}
+
+procedure TThread.Synchronize(Method: TThreadMethod);
+begin
+ {$IFDEF PSEUDO_THREADS}
+ Method;
+ {$ELSE}
+ FMethod := Method;
+ if Applet <> nil then
+ SendMessage( Applet.fHandle, CM_EXECPROC, 0, Integer( @Self ) );
+ {$ENDIF}
+end;
+
+procedure TThread.SynchronizeEx( Method: TThreadMethodEx; Param: Pointer );
+begin
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( Param <> nil, 'Parameter must not be NIL' );
+ {$ENDIF KOL_ASSERTIONS}
+ {$IFDEF PSEUDO_THREADS}
+ Method( TMethod( Method ).Data, Param );
+ {$ELSE}
+ FMethodEx := Method;
+ SendMessage( Applet.fHandle, CM_EXECPROC, Integer( Param ), Integer( @Self ) );
+ {$ENDIF}
+end;
+
+procedure TThread.Terminate;
+begin
+ {$IFDEF PSEUDO_THREADS}
+ FTerminated := TRUE;
+ if Assigned( MainThread ) then
+ if MainThread.CurrentThread = @ Self then
+ MainThread.NextThread;
+ {$ELSE}
+ TerminateThread(FHandle,0);
+ FTerminated := True;
+ {$ENDIF}
+end;
+
+function TThread.WaitFor: Integer;
+begin
+ RefInc;
+ Result := -1;
+ {$IFDEF PSEUDO_THREADS}
+ while not Terminated do
+ Resume;
+ if Terminated then
+ Result := FResult;
+ {$ELSE}
+ if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ WaitForSingleObject(FHandle, INFINITE);
+ GetExitCodeThread(FHandle, DWORD(Result));
+ {$ENDIF}
+ RefDec;
+end;
+
+function TThread.WaitForTime(T: DWORD): Integer;
+{$IFDEF PSEUDO_THREADS}
+ var LimitTime: DWORD;
+{$ENDIF}
+begin
+ {$IFDEF PSEUDO_THREADS}
+ LimitTime := GetTickCount + T;
+ RefInc;
+ while not Terminated and (GetTickCount < LimitTime) do
+ Resume;
+ Result := -1;
+ if Terminated then
+ Result := FResult;
+ RefDec;
+ {$ELSE}
+ Result := WAIT_OBJECT_0;
+ RefInc;
+ if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := WaitForSingleObject(FHandle, T);
+ if Result = WAIT_OBJECT_0 then
+ GetExitCodeThread(FHandle, T);
+ RefDec;
+ {$ENDIF}
+end;
+
+{$IFDEF _D2}
+ {$DEFINE _D2orFPC}
+{$ENDIF}
+{$IFDEF _FPC}
+ {$IFNDEF _D2orFPC}
+ {$DEFINE _D2orFPC}
+ {$ENDIF}
+{$ENDIF}
+
+function TThread.GetPriorityBoost: Boolean;
+type TGetPriorityBoost = function(hThread: THandle;
+ var DisablePriorityBoost: Bool): BOOL; stdcall;
+var B: Bool;
+ GPB: TGetPriorityBoost;
+ M: THandle;
+begin
+ Result := TRUE;
+ if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if (WinVer >= WvNT) then // by TK: only evaluate if this is true, regardless of evaluation settings
+ begin
+ M := GetModuleHandle( 'kernel32' );
+ GPB := GetProcAddress( M, 'GetThreadPriorityBoost' );
+ {$IFDEF SAFE_CODE}
+ if Assigned( GPB ) then
+ {$ENDIF}
+ if GPB( fHandle, B ) then
+ Result := B;
+ end;
+end;
+
+procedure TThread.SetPriorityBoost(const Value: Boolean);
+type TSetPriorityBoost = function(hThread: THandle;
+ DisablePriorityBoost: Bool): Bool; stdcall;
+var M: THandle;
+ SPB: TSetPriorityBoost;
+begin
+ if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ 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;
+
+{ TStream }
+
+{* This part of the unit contains implementation of streams for KOL. Please note,
+ that both stream types (file stream and memory stream) are incapsulated
+ by a single object type TStream. To avoid including unnedeed code,
+ use constructing functions NewReadFileStream and NewWriteFileStream
+ to work with file streams, which do not require both types of operation. }
+
+{* To create new type of stream, define your own methods, and in your
+ constructing function, pass it to _NewStream function (through
+ TStreamMethods record). In a field Custom, You can store a reference to
+ your own data of any type (but do not forget to define correct releasing
+ of such data in your fClose procedure). }
+
+function TStream.GetPosition: TStrmSize;
+begin
+ Result := Seek( 0, spCurrent );
+end;
+
+procedure TStream.SetPosition(const Value: TStrmSize);
+begin
+ Seek( Value, spBegin );
+end;
+
+{$IFDEF ASM_STREAM}
+function TStream.GetSize: TStrmSize;
+asm
+ CALL [EAX].fMethods.fGetSiz
+end;
+{$ELSE PAS_VERSION} //Pascal
+function TStream.GetSize: TStrmSize;
+begin
+ Result := fMethods.fGetSiz( @Self );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_STREAM}
+procedure TStream.SetSize(const NewSize: TStrmSize);
+asm
+ CALL [EAX].fMethods.fSetSiz
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure TStream.SetSize(const NewSize: TStrmSize);
+begin
+ fMethods.fSetSiz( @Self, NewSize );
+end;
+{$ENDIF PAS_VERSION}
+
+function TStream.GetFileStreamHandle: THandle;
+begin
+ Result := fData.fHandle;
+end;
+
+{$IFDEF ASM_STREAM}
+function TStream.Read(var Buffer; const Count: TStrmSize): TStrmSize;
+asm
+ CALL [EAX].fMethods.fRead
+end;
+{$ELSE PAS_VERSION} //Pascal
+function TStream.Read(var Buffer; const Count: TStrmSize): TStrmSize;
+begin
+ Result := fMethods.fRead( @Self, Buffer, Count );
+end;
+{$ENDIF PAS_VERSION}
+
+function TStream.GetCapacity: TStrmSize;
+begin
+ Result := fData.fCapacity;
+end;
+
+procedure TStream.SetCapacity(const Value: TStrmSize);
+var OldSize: DWORD;
+ V: TStrmSize;
+begin
+ V := Value;
+ {$IFDEF OLD_STREAM_CAPACITY}
+ if fData.fCapacity >= Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ OldSize := Size;
+ Size := V;
+ Size := OldSize;
+ {$ELSE}
+ if Value < fData.fSize then V := fData.fSize;
+ if Value > fData.fCapacity then
+ begin
+ OldSize := Size;
+ Size := V;
+ Size := OldSize;
+ end else
+ if fMemory <> nil then
+ begin
+ {$IFDEF _D4orHigher}
+ fMemory := ReallocMemory( fMemory, V );
+ {$ELSE}
+ ReallocMem( fMemory, V );
+ {$ENDIF}
+ fData.fCapacity := V;
+ end;
+ {$ENDIF}
+end;
+
+function TStream.Busy: Boolean;
+begin
+ Result := ( fData.fThread <> nil );
+end;
+
+function TStream.DoAsyncRead( Sender: PThread ): Integer;
+begin
+ Read( Pointer( fParam1 )^, fParam2 );
+ fData.fThread := nil;
+ Result := 0;
+end;
+
+procedure TStream.ReadAsync(var Buffer; Count: DWord);
+begin
+ if Busy then Wait;
+ fData.fThread := NewThreadAutoFree( nil );
+ fData.fThread.OnExecute := DoAsyncRead;
+ fParam1 := DWORD( @ Buffer );
+ fParam2 := Count;
+ fData.fThread.Resume;
+end;
+
+function TStream.DoAsyncSeek( Sender: PThread ): Integer;
+begin
+ Seek( fParam1, TMoveMethod( fParam2 ) );
+ fData.fThread := nil;
+ Result := 0;
+end;
+
+procedure TStream.SeekAsync(MoveTo: TStrmMove; MoveMethod: TMoveMethod);
+begin
+ if Busy then Wait;
+ fData.fThread := NewThreadAutoFree( nil );
+ fData.fThread.OnExecute := DoAsyncSeek;
+ fParam1 := MoveTo;
+ fParam2 := Ord( MoveMethod );
+ fData.fThread.Resume;
+end;
+
+function TStream.DoAsyncWrite( Sender: PThread ): Integer;
+begin
+ Write( Pointer( fParam1 )^, fParam2 );
+ fData.fThread := nil;
+ Result := 0;
+end;
+
+procedure TStream.WriteAsync(var Buffer; Count: DWord);
+begin
+ if Busy then Wait;
+ fData.fThread := NewThreadAutoFree( nil );
+ fData.fThread.OnExecute := DoAsyncWrite;
+ fParam1 := DWORD( @ Buffer );
+ fParam2 := Count;
+ fData.fThread.Resume;
+end;
+
+procedure TStream.Wait;
+begin
+ if ( fData.fThread = nil ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Assigned( fMethods.fWait ) then
+ fMethods.fWait( @Self )
+ else fData.fThread.WaitFor;
+end;
+
+{$IFDEF ASM_STREAM}
+function TStream.Write(var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize;
+asm
+ CALL [EAX].fMethods.fWrite
+end;
+{$ELSE PAS_VERSION} //Pascal
+function TStream.Write(var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize;
+begin
+ Result := fMethods.fWrite( @Self, Buffer, Count );
+end;
+{$ENDIF PAS_VERSION}
+
+function TStream.WriteVal(Value, Count: DWORD): DWORD;
+begin
+ Result := Write( Value, Count );
+end;
+
+function TStream.WriteStr(S: AnsiString): DWORD;
+begin
+ if S <> '' then
+ Result := fMethods.fWrite( @Self, S[1], Length( S ) )
+ else Result := 0;
+end;
+
+function TStream.ReadStrZ: AnsiString;
+var C: AnsiChar;
+begin
+ Result := '';
+ REPEAT
+ C := #0;
+ Read( C, 1 );
+ if C <> #0 then Result := Result + C;
+ UNTIL C = #0;
+end;
+
+{$IFDEF _D3orHigher}
+function TStream.ReadWStrZ: KOLWideString;
+var C: WideChar;
+begin
+ Result := '';
+ REPEAT
+ C := #0;
+ Read( C, 2 );
+ if C <> #0 then
+ Result := Result +
+ {$IFDEF _D3}
+ KOLWideString( C )
+ {$ELSE}
+ C
+ {$ENDIF};
+ UNTIL C = #0;
+end;
+{$ENDIF _D3orHigher}
+
+function TStream.ReadStr: AnsiString;
+var C: AnsiChar;
+begin
+ Result := '';
+ REPEAT
+ C := #0;
+ Read( C, 1 );
+ if C <> #0 then
+ begin
+ if C = #13 then
+ begin
+ C := #0;
+ Read( C, 1 );
+ if C <> #10 then Position := Position - 1;
+ C := #13;
+ end else if C = #10 then
+ C := #13;
+ if C <> #13 then
+ Result := Result + C;
+ end;
+ UNTIL (C = #13) or (C = #0);
+end;
+
+function TStream.ReadStrLen(Len: Integer): AnsiString;
+var i: Integer;
+begin
+ SetLength( Result, Len );
+ i := Read( Result[1], Len );
+ SetLength( Result, i );
+end;
+
+function TStream.WriteStrZ(S: AnsiString): DWORD;
+var C: AnsiChar;
+begin
+ if S = '' then
+ begin
+ C := #0;
+ Result := Write( C, 1 );
+ end
+ else Result := Write( S[ 1 ], Length( S ) + 1 );
+end;
+
+{$IFDEF _D3orHigher}
+function TStream.WriteWStrZ(S: KOLWideString): DWORD;
+var C: WideChar;
+begin
+ if S = '' then
+ begin
+ C := #0;
+ Result := Write( C, 2 );
+ end
+ else Result := Write( S[ 1 ], (Length( S ) + 1) * 2 );
+end;
+{$ENDIF _D3orHigher}
+
+function TStream.WriteStrEx(S: AnsiString): DWord;
+var L: DWORD;
+begin
+ L := length(s);
+ result:=fmethods.fwrite(@self,L,Sizeof(DWORD));
+ if result = Sizeof(DWORD) then
+ Inc( result, fmethods.fwrite(@self,s[1],L) );
+end;
+
+function TStream.ReadStrExVar(var S: AnsiString): DWord;
+begin
+ fmethods.fread(@self,result,Sizeof(DWORD));
+ setlength(s,result);
+ if result<>0 then result:=fmethods.fread(@self,s[1],result);
+end;
+
+function TStream.ReadStrEx: AnsiString;
+begin
+ readstrexvar(result);
+end;
+
+function TStream.WriteStrPas( S: AnsiString ): DWORD;
+var L: Integer;
+begin
+ Result := 0;
+ L := Length( S );
+ if L > 255 then L := 255;
+ if Write( L, 1 ) < 1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := 1;
+ if L > 0 then
+ Result := Write( S[ 1 ], L ) + 1;
+end;
+
+function TStream.ReadStrPas: AnsiString;
+var L: Byte;
+begin
+ Result := '';
+ if Read( L, 1 ) < 1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ SetLength( Result, L );
+ L := Read( Result[ 1 ], L );
+ Result := Copy( Result, 1, L );
+end;
+
+{$IFDEF ASM_STREAM}
+function TStream.Seek({$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize;
+//function TStream.Seek(MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize;
+asm
+ CALL [EAX].fMethods.fSeek
+end;
+{$ELSE PAS_VERSION} //Pascal
+function TStream.Seek({$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize;
+begin
+ Result := fMethods.fSeek( @Self, MoveTo, MoveMethod );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TStream.Destroy;
+begin
+ fMethods.fClose( @Self );
+ fData.fThread.Free;
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TStream.SaveToFile(const Filename: KOLString; const Start, CountSave: TStrmSize);
+var F: PStream;
+ SavePos: DWORD;
+begin
+ F := NewWriteFileStream( Filename );
+ SavePos := Position;
+ Position := Start;
+ Stream2Stream( F, @ Self, CountSave );
+ Position := SavePos;
+ F.Free;
+end;
+
+function _NewStream( const StreamMethods: TStreamMethods ): PStream;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TStream';
+ {$ENDIF}
+ Move( StreamMethods, Result.fMethods, Sizeof( TStreamMethods ) );
+ Result.fPMethods := @Result.fMethods;
+ TMethod( Result.fOnChangePos ).Code := @DummyObjProc;
+end;
+
+function SeekFileStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+begin
+ Result := FileSeek( Strm.fData.fHandle, MoveTo, MoveFrom );
+ {$IFDEF FILESTREAM_POSITION}
+ Strm.fData.fPosition := Result;
+ {$ENDIF}
+end;
+
+function GetSizeFileStream( Strm: PStream ): TStrmSize;
+{$IFDEF STREAM_LARGE64}
+var SizeHigh: DWORD;
+{$ENDIF}
+begin
+ {$IFDEF STREAM_LARGE64}
+ Result := GetFileSize( Strm.fData.fHandle, @ SizeHigh );
+ Result := Result or SizeHigh shl 32;
+ {$ELSE}
+ Result := GetFileSize( Strm.fData.fHandle, nil );
+ if Result = DWORD( -1 ) then Result := 0;
+ {$ENDIF}
+end;
+
+procedure DummySetSize( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Value: TStrmSize );
+begin
+end;
+
+procedure DummyStreamProc(Strm: PStream);
+begin
+end;
+
+function DummyReadWrite( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+asm
+ XOR EAX, EAX
+ {$IFDEF STREAM_LARGE64}
+ XOR EDX, EDX
+ {$ENDIF}
+end;
+
+function DummySeek( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod ): TStrmSize;
+asm
+ XOR EAX, EAX
+ {$IFDEF STREAM_LARGE64}
+ XOR EDX, EDX
+ {$ENDIF}
+end;
+
+function ReadFileStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+begin
+ Result := FileRead( Strm.fData.fHandle, Buffer, Count );
+ {$IFDEF FILESTREAM_POSITION}
+ inc( Strm.fData.fPosition, Result );
+ {$ENDIF}
+end;
+
+function ReadFileStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+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
+ Strm.OnChangePos( Strm );
+end;
+
+function WriteFileStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+begin
+ Result := FileWrite( Strm.fData.fHandle, Buffer, Count );
+ {$IFDEF FILESTREAM_POSITION}
+ inc( Strm.fData.fPosition, Result );
+ {$ENDIF}
+end;
+
+function WriteFileStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+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
+ Strm.OnChangePos( Strm );
+end;
+
+{$IFDEF ASM_STREAM}
+function WriteFileStreamEOF( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+asm
+ PUSH EBX
+ PUSH [EAX].TStream.fData.fHandle
+ CALL WriteFileStream
+ XCHG EBX, EAX
+ CALL SetEndOfFile
+ XCHG EAX, EBX
+ POP EBX
+end;
+{$ELSE PAS_VERSION} //Pascal
+function WriteFileStreamEOF( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+begin
+ Result := WriteFileStream( Strm, Buffer, Count );
+ {$IFDEF FILESTREAM_POSITION}
+ inc( Strm.fData.fPosition, Result );
+ {$ENDIF}
+ SetEndOfFile( Strm.fData.fHandle );
+end;
+{$ENDIF PAS_VERSION}
+
+function WriteFileStreamEOFWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+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
+ Strm.OnChangePos( Strm );
+end;
+
+procedure CloseFileStream( Strm: PStream );
+begin
+ if Strm.fData.fHandle <> INVALID_HANDLE_VALUE then
+ FileClose( Strm.fData.fHandle );
+ Strm.fData.fHandle := INVALID_HANDLE_VALUE;
+end;
+
+{$IFDEF ASM_STREAM}
+function SeekMemStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF}
+ MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+asm
+ PUSH EBX
+ MOV EBX, EDX
+ AND ECX, $FF
+ LOOP @@not_from_cur
+ ADD EBX, [EAX].TStream.fData.fPosition
+@@not_from_cur:
+ LOOP @@not_from_end
+ ADD EBX, [EAX].TStream.fData.fSize
+@@not_from_end:
+ CMP EBX, [EAX].TStream.fData.fSize
+ JLE @@space_ok
+ PUSH EAX
+ MOV EDX, EBX
+ CALL TStream.SetSize
+ POP EAX
+@@space_ok:
+ XCHG EAX, EBX
+ MOV [EBX].TStream.fData.fPosition, EAX
+ POP EBX
+end;
+{$ELSE PAS_VERSION} //Pascal
+function SeekMemStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF}
+ MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+var NewPos: DWORD;
+begin
+ case MoveFrom of
+ spBegin: NewPos := MoveTo;
+ spCurrent: NewPos := Strm.fData.fPosition + DWORD( MoveTo );
+ else //spEnd:
+ NewPos := Strm.fData.fSize + DWORD( MoveTo );
+ end;
+ if NewPos > Strm.fData.fSize then
+ Strm.SetSize( NewPos );
+ Strm.fData.fPosition := NewPos;
+ Result := NewPos;
+end;
+{$ENDIF PAS_VERSION}
+
+function SeekMemStreamWithEvent( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+var OldPos: DWORD;
+begin
+ OldPos := Strm.Position;
+ Result := SeekMemStream( Strm, MoveTo, MoveFrom );
+ if (OldPos <> Strm.Position)
+ {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then
+ Strm.OnChangePos( Strm );
+end;
+
+function GetSizeMemStream( Strm: PStream ): TStrmSize;
+begin
+ Result := Strm.fData.fSize;
+end;
+
+{$IFDEF ASM_STREAM}
+procedure SetSizeMemStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize );
+asm
+ push ebx
+ push edx
+ xchg ebx, eax
+ cmp [ebx].TStream.fData.fCapacity, edx
+ jae @@mem_ok
+ {$IFDEF OLD_MEMSTREAMS_SETSIZE}
+ or edx, [CapacityMask]
+ inc edx
+ {$ENDIF}
+ mov [ebx].TStream.fData.fCapacity, edx
+ mov ecx, [ebx].TStream.fMemory
+ jecxz @@getmem
+ lea eax, [ebx].TStream.fMemory
+ call System.@ReallocMem
+ jmp @@setmem
+
+@@getmem:
+ or ecx, edx
+ jz @@mem_ok
+ xchg eax, ecx
+ call System.@GetMem
+@@setmem:
+ mov [ebx].TStream.fMemory, eax
+
+@@mem_ok:
+ pop ecx // NewSize
+ inc ecx
+ loop @@set_new_sz
+ cmp [ebx].TStream.fData.fSize, ecx
+ jz @@set_new_sz
+
+ mov [ebx].TStream.fData.fCapacity, ecx
+ xchg ecx, [ebx].TStream.fMemory
+ jecxz @@mem_freed
+ xchg eax, ecx
+ call System.@FreeMem
+@@mem_freed:
+ xor ecx, ecx
+
+@@set_new_sz:
+ mov [ebx].TStream.fData.fSize, ecx
+ cmp [ebx].TStream.fData.fPosition, ecx
+ jb @@exit
+ mov [ebx].TStream.fData.fPosition, ecx
+
+@@exit:
+ pop ebx
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure SetSizeMemStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize );
+var S: PStream;
+ NewCapacity: DWORD;
+begin
+ S := Strm;
+ if S.fData.fCapacity < NewSize then
+ begin
+ {$IFDEF OLD_MEMSTREAMS_SETSIZE}
+ NewCapacity := (NewSize or CapacityMask) + 1;
+ {$ELSE}
+ NewCapacity := NewSize;
+ {$ENDIF}
+ if S.fMemory = nil then
+ begin
+ if NewSize <> 0 then
+ GetMem( S.fMemory, NewCapacity );
+ end else ReallocMem( S.fMemory, NewCapacity );
+ S.fData.fCapacity := NewCapacity;
+ end else
+ if (NewSize = 0) and (S.Size > 0) then
+ begin
+ if S.fMemory <> nil then
+ begin
+ FreeMem( S.fMemory );
+ S.fMemory := nil;
+ S.fData.fCapacity := 0;
+ end;
+ end;
+ S.fData.fSize := NewSize;
+ if S.fData.fPosition > S.fData.fSize then
+ S.fData.fPosition := S.fData.fSize;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_STREAM}
+function ReadMemStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+asm
+ PUSH EBX
+ XCHG EBX, EAX
+ MOV EAX, [EBX].TStream.fData.fPosition
+ ADD EAX, ECX
+ CMP EAX, [EBX].TStream.fData.fSize
+ JLE @@count_ok
+ MOV ECX, [EBX].TStream.fData.fSize
+ SUB ECX, [EBX].TStream.fData.fPosition
+@@count_ok:
+ PUSH ECX
+ MOV EAX, [EBX].TStream.fMemory
+ ADD EAX, [EBX].TStream.fData.fPosition
+ CALL System.Move
+ POP EAX
+ ADD [EBX].TStream.fData.fPosition, EAX
+ POP EBX
+end;
+{$ELSE PAS_VERSION} //Pascal
+function ReadMemStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+var S: PStream;
+ C: TStrmSize;
+begin
+ S := Strm;
+ C := Count;
+ if C + S.fData.fPosition > S.fData.fSize then
+ C := S.fData.fSize - S.fData.fPosition;
+ Result := C;
+ Move( Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Buffer, Result );
+ Inc( S.fData.fPosition, Result );
+end;
+{$ENDIF PAS_VERSION}
+
+function ReadMemStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+begin
+ Result := ReadMemStream( Strm, Buffer, Count );
+ if (Result > 0)
+ {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then
+ Strm.OnChangePos( Strm );
+end;
+
+{$IFDEF ASM_STREAM}
+function WriteMemStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+asm
+ PUSH EBX
+ XCHG EBX, EAX
+ MOV EAX, [EBX].TStream.fData.fPosition
+ ADD EAX, ECX
+ CMP EAX, [EBX].TStream.fData.fSize
+ PUSH EDX
+ PUSH ECX
+ JLE @@count_ok
+ XCHG EDX, EAX
+ MOV EAX, EBX
+ CALL TStream.SetSize
+@@count_ok:
+ POP ECX
+ POP EAX
+ MOV EDX, [EBX].TStream.fMemory
+ ADD EDX, [EBX].TStream.fData.fPosition
+ PUSH ECX
+ CALL System.Move
+ POP EAX
+ ADD [EBX].TStream.fData.fPosition, EAX
+ POP EBX
+end;
+{$ELSE PAS_VERSION} //Pascal
+function WriteMemStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+var S: PStream;
+begin
+ S := Strm;
+ if Count + S.fData.fPosition > S.fData.fSize then
+ S.SetSize( S.fData.fPosition + Count );
+ Result := Count;
+ Move( Buffer, Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Result );
+ Inc( S.fData.fPosition, Result );
+end;
+{$ENDIF PAS_VERSION}
+
+function WriteMemStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+begin
+ Result := WriteMemStream( Strm, Buffer, Count );
+ if (Result > 0)
+ {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then
+ Strm.OnChangePos( Strm );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure CloseMemStream( Strm: PStream );
+var S: PStream;
+begin
+ S := Strm;
+ if S.fMemory <> nil then
+ begin
+ FreeMem( S.fMemory );
+ S.fMemory := nil;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure DummyCloseStream( Strm: PStream );
+begin
+ // nothing here
+end;
+
+// by Roman Vorobets:
+procedure SetSizeFileStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize );
+var P: DWORD;
+begin
+ P:=Strm.Position;
+ Strm.Position:=NewSize;
+ SetEndOfFile(Strm.Handle);
+ if P < NewSize then
+ Strm.Position:=P;
+end;
+
+function ReadMemBlkStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+var P, bStart, bLen, C: DWORD;
+ bAddr: PByte;
+ i: Integer;
+begin
+ P := Strm.Position;
+ i := 0;
+ bStart := 0;
+ bLen := 0;
+ bAddr := nil;
+ while i < Strm.fData.fBlocks.Count do
+ begin
+ bAddr := Strm.fData.fBlocks.fItems[i];
+ bLen := Integer( Strm.fData.fBlocks.fItems[i+1] );
+ if bStart + bLen > P then
+ break;
+ inc( i, 2 );
+ inc( bStart, bLen );
+ end;
+ if bStart + bLen < P then
+ begin
+ Result := 0; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ inc( bAddr, P - bStart );
+ C := Count;
+ if C > bLen - (P - bStart) then
+ C := bLen - (P - bStart);
+ if C > 0 then
+ Move( bAddr^, Buffer, C );
+ Result := C;
+ inc( Strm.fData.fPosition, C );
+end;
+
+function SeekMemBlkStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+var P: Integer;
+begin
+ P := MoveTo;
+ CASE MoveFrom OF
+ spCurrent: P := P + Integer( Strm.fData.fPosition );
+ spEnd: P := P + Integer( Strm.fData.fSize );
+ END;
+ if P < 0 then P := 0;
+ if P > Integer( Strm.fData.fSize ) then
+ P := Strm.fData.fSize;
+ Strm.fData.fPosition := P;
+ Result := P;
+end;
+
+function WriteMemBlkStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+var LastBlkAddr: PByte;
+ LastBlkUsed, C: Integer;
+ NewBlkSz: Integer;
+begin
+ C := Strm.fData.fBlocks.Count;
+ LastBlkUsed := Strm.fData.fBlkSize;
+ LastBlkAddr := nil;
+ if C > 1 then
+ begin
+ LastBlkAddr := Strm.fData.fBlocks.Items[C-2];
+ LastBlkUsed := Integer( Strm.fData.fBlocks.Items[C-1] );
+ end;
+ if Strm.fData.fBlkSize - LastBlkUsed < Integer( Count ) then
+ begin
+ NewBlkSz := Strm.fData.fBlkSize;
+ if NewBlkSz < Integer( Count ) then
+ NewBlkSz := Count;
+ GetMem( LastBlkAddr, NewBlkSz );
+ LastBlkUsed := 0;
+ Strm.fData.fBlocks.Add( LastBlkAddr );
+ Strm.fData.fBlocks.Add( nil );
+ inc( C, 2 );
+ end;
+ inc( LastBlkAddr, LastBlkUsed );
+ Strm.fData.fJustWrittenBlkAddress := LastBlkAddr;
+ Move( Buffer, LastBlkAddr^, Count );
+ inc( LastBlkUsed, Count );
+ Strm.fData.fBlocks.fItems[ C-1 ] := Pointer( LastBlkUsed );
+ inc( Strm.fData.fSize, Count );
+ Strm.fData.fPosition := Strm.fData.fSize;
+ Result := Count;
+end;
+
+procedure ResizeMemBlkStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize );
+var i, del: Integer;
+ LastBlkAddr: PByte;
+ LastBlkUsed: Integer;
+begin
+ while Strm.fData.fSize > NewSize do
+ begin
+ i := Strm.fData.fBlocks.Count-2;
+ LastBlkAddr := Strm.fData.fBlocks.fItems[i];
+ LastBlkUsed := Integer( Strm.fData.fBlocks.fItems[i+1] );
+ del := Strm.fData.fSize - NewSize;
+ if del >= LastBlkUsed then
+ begin
+ FreeMem( LastBlkAddr );
+ Strm.fData.fBlocks.DeleteRange( i, 2 );
+ dec( Strm.fData.fSize, LastBlkUsed );
+ end else
+ begin
+ Strm.fData.fBlocks.fItems[ i+1 ] := Pointer( LastBlkUsed - del );
+ dec( Strm.fData.fSize, del );
+ end;
+ end;
+ if Strm.fData.fSize > Strm.fData.fPosition then
+ Strm.fData.fPosition := Strm.fData.fSize;
+end;
+
+procedure FreeMemBlkStream( Strm: PStream );
+var i: Integer;
+begin
+ i := 0;
+ while i < Strm.fData.fBlocks.Count do
+ 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; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+var NewPos: TStrmSize;
+begin
+ NewPos := MoveTo;
+ CASE MoveFrom OF
+ spCurrent: NewPos := TStrmMove( Strm.fData.fPosition ) + MoveTo;
+ spEnd : NewPos := TStrmMove( Strm.Size ) + MoveTo;
+ END;
+ if Strm.fData.fStream1.Size > NewPos then
+ begin
+ Strm.fData.fStream1.Position := NewPos;
+ Strm.fData.fStream2.Position := 0;
+ end else
+ begin
+ Strm.fData.fStream1.Position := Strm.fData.fStream1.Size;
+ Strm.fData.fStream2.Position := NewPos - Strm.fData.fStream1.Size;
+ end;
+ Strm.fData.fPosition := Strm.fData.fStream1.Position + Strm.fData.fStream2.Position;
+ Result := Strm.fData.fPosition;
+end;
+
+function GetSizeConcatStream( Strm: PStream ): TStrmSize;
+begin
+ Result := Strm.fData.fStream1.Size + Strm.fData.fStream2.Size;
+end;
+
+procedure SetSizeConcatStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize );
+var New_Sz, Sz1: TStrmSize;
+begin
+ New_Sz := NewSize;
+ Sz1 := Strm.fData.fStream1.Size;
+ if New_Sz < Sz1 then
+ New_Sz := Sz1;
+ Strm.fData.fStream2.Size := New_Sz - Sz1;
+end;
+
+function ReadConcatStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+var C, Sz1, ToRead: TStrmSize;
+ ToAddr: PByte;
+begin
+ C := Count;
+ Sz1 := Strm.fData.fStream1.Size;
+ ToAddr := @ Buffer;
+ Result := 0;
+ if Strm.Position < Sz1 then
+ begin
+ ToRead := C;
+ if Strm.Position + C > Sz1 then
+ ToRead := Sz1 - Strm.Position;
+ Result := Strm.fData.fStream1.Read( ToAddr^, ToRead );
+ Strm.fData.fPosition := Strm.fData.fStream1.Position;
+ dec( C, Result );
+ inc( ToAddr, Result );
+ if Result < ToRead then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Strm.fData.fStream2.Position := 0;
+ end;
+ if C <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := Result + Strm.fData.fStream2.Read( ToAddr^, C );
+ Strm.fData.fPosition := Strm.fData.fStream1.Size +
+ Strm.fData.fStream2.Position;
+end;
+
+function WriteConcatStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+var C, Sz1, ToWrite: TStrmSize;
+ FromAddr: PByte;
+begin
+ C := Count;
+ Sz1 := Strm.fData.fStream1.Size;
+ FromAddr := @ Buffer;
+ Result := 0;
+ if Strm.Position < Sz1 then
+ begin
+ ToWrite := C;
+ if Strm.Position + C > Sz1 then
+ ToWrite := Sz1 - Strm.Position;
+ Result := Strm.fData.fStream1.Write( FromAddr^, ToWrite );
+ Strm.fData.fPosition := Strm.fData.fStream1.Position;
+ dec( C, Result );
+ inc( FromAddr, Result );
+ if Result < ToWrite then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Strm.fData.fStream2.Position := 0;
+ end;
+ if C <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := Result + Strm.fData.fStream2.Write( FromAddr^, C );
+ Strm.fData.fPosition := Strm.fData.fStream1.Size +
+ Strm.fData.fStream2.Position;
+end;
+
+procedure CloseConcatStream( Strm: PStream );
+begin
+ Strm.fData.fStream1.fMethods.fClose( Strm.fData.fStream1 );
+ Strm.fData.fStream2.fMethods.fClose( Strm.fData.fStream2 );
+end;
+
+function SeekSubStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize;
+var NewPos, OldPos: TStrmMove;
+begin
+ OldPos := Strm.fData.fBaseStream.Position - Strm.fData.fFromPos;
+ {$IFDEF STREAM_LARGE64}
+ if OldPos < 0 then OldPos := 0;
+ {$ENDIF}
+ CASE MoveFrom OF
+ spCurrent: NewPos := OldPos + MoveTo;
+ spEnd : NewPos := TStrmMove( Strm.Size ) + MoveTo;
+ else NewPos := MoveTo;
+ END;
+ {$IFDEF STREAM_LARGE64}
+ if NewPos < 0 then NewPos := 0;
+ {$ENDIF}
+ Strm.fData.fBaseStream.Position := Strm.fData.fFromPos + TStrmSize( NewPos );
+ Result := Strm.fData.fBaseStream.Position - Strm.fData.fFromPos;
+ if Result > Strm.fData.fSize then
+ Strm.fData.fSize := Result;
+end;
+
+function GetSizeSubStream( Strm: PStream ): TStrmSize;
+begin
+ Result := Strm.fData.fSize;
+end;
+
+procedure SetSizeSubStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize );
+begin
+ {$IFDEF STREAM_LARGE64}
+ if NewSize >= 0 then
+ {$ENDIF}
+ Strm.fData.fSize := NewSize;
+end;
+
+function ReadSubStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+var C: TStrmSize;
+begin
+ C := Count;
+ if Strm.Position + C > Strm.Size then
+ C := Strm.Size - Strm.Position;
+ Result := Strm.fData.fBaseStream.Read( Buffer, C );
+end;
+
+function WriteSubStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+begin
+ Result := Strm.fData.fBaseStream.Write( Buffer, Count );
+end;
+
+procedure CloseSubStream( Strm: PStream );
+begin
+ Strm.fData.fBaseStream.fMethods.fClose( Strm.fData.fBaseStream );
+end;
+
+
+function NewFileStream( const FileName: KOLString; Options: DWORD ): PStream;
+begin
+ Result := _NewStream( BaseFileMethods );
+ Result.fMethods.fRead := ReadFileStreamProc;
+ Result.fMethods.fWrite := WriteFileStream; // not WriteStreamEOF, Алексей Шувалов
+ Result.fMethods.fSetSiz := SetSizeFileStream;
+ Result.fData.fHandle := FileCreate( FileName, Options );
+end;
+
+function NewFileStreamWithEvent( const FileName: KOLString; Options: DWORD ): PStream;
+begin
+ Result := _NewStream( BaseFileMethods );
+ Result.fMethods.fRead := ReadFileStreamWithEvent;
+ Result.fMethods.fWrite := WriteFileStreamWithEvent; // not WriteStreamEOF, Алексей Шувалов
+ Result.fMethods.fSetSiz := SetSizeFileStream;
+ Result.fData.fHandle := FileCreate( FileName, Options );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewReadFileStream( const FileName: KOLString ): PStream;
+begin
+ Result := _NewStream( BaseFileMethods );
+ Result.fMethods.fRead := ReadFileStreamProc;
+ Result.fData.fHandle := FileCreate( FileName,
+ ofOpenRead or ofShareDenyWrite or ofOpenExisting );
+end;
+{$ENDIF PAS_VERSION}
+
+function NewReadFileStreamWithEvent( const FileName: KOLString ): PStream;
+begin
+ Result := _NewStream( BaseFileMethods );
+ Result.fMethods.fRead := ReadFileStreamWithEvent;
+ Result.fData.fHandle := FileCreate( FileName,
+ ofOpenRead or ofShareDenyWrite or ofOpenExisting );
+end;
+
+function NewExFileStream( F: HFile ): PStream;
+begin
+ Result := _NewStream( BaseFileMethods );
+ Result.fMethods.fRead := ReadFileStreamProc;
+ Result.fMethods.fWrite := WriteFileStream;
+ Result.fData.fHandle := F;
+ Result.fMethods.fClose := DummyCloseStream;
+end;
+
+{$IFDEF _D3orHigher}
+function NewReadFileStreamW( const FileName: KOLWideString ): PStream;
+begin
+ Result := _NewStream( BaseFileMethods );
+ Result.fMethods.fRead := ReadFileStreamProc;
+ Result.fData.fHandle := WFileCreate( FileName,
+ ofOpenRead or ofShareDenyWrite or ofOpenExisting );
+end;
+{$ENDIF _D3orHigher}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewWriteFileStream( const FileName: KOLString ): PStream;
+begin
+ Result := _NewStream( BaseFileMethods );
+ Result.fMethods.fWrite := WriteFileStreamEOF;
+ Result.fMethods.fSetSiz := SetSizeFileStream;
+ Result.fData.fHandle := FileCreate( FileName,
+ ofOpenWrite or ofCreateAlways or ofShareDenyWrite );
+end;
+{$ENDIF PAS_VERSION}
+
+function NewWriteFileStreamWithEvent( const FileName: KOLString ): PStream;
+begin
+ Result := _NewStream( BaseFileMethods );
+ Result.fMethods.fWrite := WriteFileStreamEOFWithEvent;
+ Result.fMethods.fSetSiz := SetSizeFileStream;
+ Result.fData.fHandle := FileCreate( FileName,
+ ofOpenWrite or ofCreateAlways or ofShareDenyWrite );
+end;
+
+{$IFDEF _D3orHigher}
+function NewWriteFileStreamW( const FileName: KOLWideString ): PStream;
+begin
+ Result := _NewStream( BaseFileMethods );
+ Result.fMethods.fWrite := WriteFileStreamEOF;
+ Result.fMethods.fSetSiz := SetSizeFileStream;
+ Result.fData.fHandle := WFileCreate( FileName,
+ ofOpenWrite or ofCreateAlways or ofShareDenyWrite );
+end;
+{$ENDIF _D3orHigher}
+
+{$IFDEF ASM_noVERSION}
+function NewReadWriteFileStream( const FileName: AnsiString ): PStream;
+asm
+ PUSH EBX
+ XCHG EBX, EAX
+ MOV EAX, offset[BaseFileMethods]
+ CALL _NewStream
+ MOV EDX, [ReadFileStreamProc]
+ MOV [EAX].TStream.fMethods.fRead, EDX
+ MOV [EAX].TStream.fMethods.fWrite, offset[WriteFileStream]
+ MOV [EAX].TStream.fMethods.fSetSiz, offset[SetSizeFileStream]
+ XCHG EBX, EAX
+
+ PUSH EAX
+ CALL FileExists
+ MOV EDX, ofOpenReadWrite or ofCreateAlways or ofShareDenyWrite
+ ADD DH, AL // $200 (ofCreateAlways) -> $300 (ofCreateExisting)
+ POP EAX
+
+ CALL FileCreate
+ MOV [EBX].TStream.fData.fHandle, EAX
+ XCHG EAX, EBX
+ POP EBX
+end;
+{$ELSE PAS_VERSION} //Pascal
+function NewReadWriteFileStream( const FileName: KOLString ): PStream;
+var Creation: DWORD;
+begin
+ Result := _NewStream( BaseFileMethods );
+ Result.fMethods.fRead := ReadFileStreamProc;
+ Result.fMethods.fWrite := WriteFileStream;
+ Result.fMethods.fSetSiz := SetSizeFileStream;
+ Creation := ofCreateAlways;
+ if FileExists( FileName ) then Creation := ofOpenExisting;
+ Result.fData.fHandle := FileCreate( FileName,
+ ofOpenReadWrite or Creation or ofShareDenyWrite );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF _D3orHigher}
+function NewReadWriteFileStreamW( const FileName: KOLWideString ): PStream;
+var Creation: DWORD;
+begin
+ Result := _NewStream( BaseFileMethods );
+ Result.fMethods.fRead := ReadFileStreamProc;
+ Result.fMethods.fWrite := WriteFileStream;
+ Result.fMethods.fSetSiz := SetSizeFileStream;
+ Creation := ofCreateAlways;
+ if WFileExists( FileName ) then Creation := ofOpenExisting;
+ Result.fData.fHandle := WFileCreate( FileName,
+ ofOpenReadWrite or Creation or ofShareDenyWrite );
+end;
+{$ENDIF _D3orHigher}
+
+function NewMemoryStream: PStream;
+begin
+ Result := _NewStream( MemoryMethods );
+end;
+
+function NewMemoryStreamWithEvent: PStream;
+begin
+ Result := _NewStream( MemoryMethods );
+ Result.fMethods.fRead := ReadMemStreamWithEvent;
+ Result.fMethods.fWrite := WriteMemStreamWithEvent;
+end;
+
+{$IFDEF ASM_STREAM}
+function WriteExMemoryStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+asm
+ PUSH EBX
+ XCHG EBX, EAX
+ MOV EAX, [EBX].TStream.fData.fSize
+ SUB EAX, [EBX].TStream.fData.fPosition
+ CMP EAX, ECX
+ JGE @@1
+ XCHG ECX, EAX
+@@1:
+ PUSH EDX
+ PUSH ECX
+ JLE @@count_ok
+ XCHG EDX, EAX
+ MOV EAX, EBX
+ CALL TStream.SetSize
+@@count_ok:
+ POP ECX
+ POP EAX
+ MOV EDX, [EBX].TStream.fMemory
+ ADD EDX, [EBX].TStream.fData.fPosition
+ PUSH ECX
+ CALL System.Move
+ POP EAX
+ ADD [EBX].TStream.fData.fPosition, EAX
+ POP EBX
+end;
+{$ELSE PAS_VERSION}
+function WriteExMemoryStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+var S: PStream;
+ C: TStrmSize;
+begin
+ S := Strm;
+ C := Count;
+ if C + S.fData.fPosition > S.fData.fSize then
+ C := S.fData.fSize - S.fData.fPosition;
+ Result := C;
+ Move( Buffer, Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Result );
+ Inc( S.fData.fPosition, Result );
+end;
+{$ENDIF PAS_VERSION}
+
+procedure DummyClose_ExMemStream( Strm: PStream );
+begin
+ // nothing to do - ignore call (memory is not released by any way)
+end;
+
+function NewExMemoryStream( ExistingMem: Pointer; Size: DWORD ): PStream;
+begin
+ Result := NewMemoryStream;
+ Result.fMemory := ExistingMem;
+ Result.fData.fCapacity := Size;
+ Result.fData.fSize := Size;
+ Result.fMethods.fWrite := WriteExMemoryStream;
+ Result.fMethods.fSetSiz := DummySetSize;
+ Result.fMethods.fClose := DummyClose_ExMemStream;
+end;
+
+function NewMemBlkStream( BlkSize: Integer ): PStream;
+begin
+ Result := NewMemoryStream;
+ Result.fData.fBlkSize := BlkSize;
+ Result.fData.fBlocks := NewList;
+ Result.fMethods.fWrite := WriteMemBlkStream;
+ Result.fMethods.fSetSiz := DummySetSize;
+ Result.fMethods.fClose := DummyClose_ExMemStream;
+ Result.fMethods.fRead := ReadMemBlkStream;
+ Result.fMethods.fSeek := SeekMemBlkStream;
+ Result.fMethods.fSetSiz := ResizeMemBlkStream;
+ Result.Add2AutoFreeEx( TObjectMethod( MakeMethod( Result, @FreeMemBlkStream ) ) );
+end;
+
+function NewMemBlkStream_WriteOnly( BlkSize: Integer ): PStream;
+begin
+ Result := NewMemoryStream;
+ Result.fData.fBlkSize := BlkSize;
+ Result.fData.fBlocks := NewList;
+ Result.fMethods.fWrite := WriteMemBlkStream;
+ Result.fMethods.fSetSiz := DummySetSize;
+ Result.fMethods.fClose := DummyClose_ExMemStream;
+ Result.fMethods.fRead := DummyReadWrite;
+ Result.fMethods.fSeek := DummySeek;
+ Result.fMethods.fSetSiz := ResizeMemBlkStream;
+ Result.Add2AutoFreeEx( TObjectMethod( MakeMethod( Result, @FreeMemBlkStream ) ) );
+end;
+
+function NewConcatStream( Stream1, Stream2: PStream ): PStream;
+begin
+ Result := _NewStream( ConcatStreamMethods );
+ Result.fData.fStream1 := Stream1;
+ Result.fData.fStream2 := Stream2;
+ Result.Add2AutoFree( Stream1 );
+ Result.Add2AutoFree( Stream2 );
+end;
+
+function NewSubStream( BaseStream: PStream; const FromPos, Size: TStrmSize ): PStream;
+begin
+ Result := _NewStream( SubStreamMethods );
+ Result.fData.fBaseStream := BaseStream;
+ Result.fData.fFromPos := FromPos;
+ Result.fData.fSize := Size;
+ Result.Position := 0;
+ Result.Add2AutoFree( BaseStream );
+end;
+
+function Stream2Stream( Dst, Src: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+var Buf: Pointer;
+ C: TStrmSize;
+begin
+ C := Count;
+ if Src.fMemory <> nil then
+ begin
+ if Src.fData.fPosition + C > Src.fData.fSize then
+ C := Src.fData.fSize - Src.fData.fPosition;
+ Result := Dst.Write( Pointer(DWORD(Src.fMemory)+Src.fData.fPosition)^,
+ C );
+ Inc( Src.fData.fPosition, Result );
+ end else
+ if Dst.fMemory <> nil then
+ begin
+ if Dst.fData.fPosition + C > Dst.fData.fSize then
+ Dst.SetSize( Dst.fData.fPosition + C );
+ Result := Src.Read( Pointer( DWORD( Dst.fMemory ) + Dst.fData.fPosition )^,
+ C );
+ Inc( Dst.fData.fPosition, Result );
+ end else
+ begin
+ GetMem( Buf, C );
+ C := Src.Read( Buf^, C );
+ Result := Dst.Write( Buf^, C );
+ FreeMem( Buf );
+ end;
+end;
+
+function Stream2StreamEx( Dst, Src: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize;
+begin
+ Result := Stream2StreamExBufSz( Dst, Src, Count, 65536 );
+end;
+
+function Stream2StreamExBufSz( Dst, Src: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize; BufSz: DWORD ): TStrmSize;
+var
+ buf:pointer;
+ rd, wr:dword;
+ C: TStrmSize;
+begin
+ C := Count;
+ if C=0 then result:=0
+ else begin
+ result:=0;
+ BufSz := Min( BufSz, C );
+ if BufSz = 0 then BufSz := C;
+ getmem(buf,BufSz);
+ repeat
+ if C<BufSz then rd:=c else rd:=BufSz;
+ rd:=src.read(buf^,rd);
+ wr := dst.write(buf^,rd);
+ inc(result,wr);
+ dec(C, rd);
+ until (rd<>BufSz) or (C=0);
+ freemem(buf);
+ end;
+end;
+
+{$IFDEF ASM_UNICODE}
+ {$IFNDEF STREAM_LARGE64}
+ {$DEFINE ASM_Resource2Stream}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF ASM_Resource2Stream}
+function Resource2Stream( DestStrm : PStream; Inst : HInst;
+ ResName : PAnsiChar; ResType : PAnsiChar ): Integer;
+asm
+ PUSH EBX
+ PUSH ESI
+ MOV EBX, EDX // EBX = Inst
+ PUSH EAX // DestStrm
+ PUSH ResType
+ PUSH ECX
+ PUSH EDX
+ CALL FindResource
+ TEST EAX, EAX
+ JZ @@exit0
+
+ PUSH EAX
+ PUSH EBX
+ PUSH EAX
+ PUSH EBX
+ CALL SizeofResource
+ XCHG EBX, EAX
+ CALL LoadResource
+ TEST EAX, EAX
+ JZ @@exit0
+ XCHG ESI, EAX
+
+ PUSH ESI
+ CALL GlobalLock
+ TEST EAX, EAX
+ JNZ @@P_ok
+
+ CALL GetLastError
+ CMP EAX, ERROR_INVALID_HANDLE
+ JNZ @@exit_00
+ MOV EAX, ESI
+
+@@P_ok:
+ XCHG EDX, EAX
+ POP EAX // DestStrm
+ PUSH EDX
+ MOV ECX, EBX
+ CALL TStream.Write
+
+ //EAX = Result (length of written data)
+ XCHG EBX, EAX
+ POP EAX
+ CMP ESI, EAX
+ JE @@not_unlock
+
+ PUSH ESI
+ CALL GlobalUnlock
+@@not_unlock:
+ XCHG EAX, EBX
+ JMP @@exit
+
+@@exit_00:
+ XOR EAX, EAX
+@@exit0:
+ POP ECX
+@@exit:
+ POP ESI
+ POP EBX
+end;
+{$ELSE PAS_VERSION} //Pascal
+function Resource2Stream( DestStrm : PStream; Inst : HInst;
+ ResName : PKOLChar; ResType : PKOLChar ): Integer;
+var R : HRSRC;
+ G : HGlobal;
+ P : PAnsiChar;
+ Sz : DWORD;
+ E : Integer;
+begin
+ Result := 0;
+ R := FindResource( Inst, ResName, ResType );
+ if R <> 0 then
+ begin
+ Sz := SizeofResource( Inst, R );
+ G := LoadResource( Inst, R );
+ if G <> 0 then
+ begin
+ P := GlobalLock( G );
+ if P = nil then
+ begin
+ E := GetLastError;
+ if E = ERROR_INVALID_HANDLE then
+ P := Pointer( G )
+ else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := DestStrm.Write( P^, Sz );
+ if P <> Pointer( G ) then
+ GlobalUnlock( G );
+ //FreeResource( G ); -- not necessary for resource loaded by LoadResource
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+///////////////////////////////////////////////////////////////////////////
+// I N I - F I L E S
+///////////////////////////////////////////////////////////////////////////
+
+{ TIniFile }
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TIniFile.Destroy;
+begin
+ fFileName := '';
+ fSection := '';
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TIniFile.ClearAll;
+begin
+ WritePrivateProfileString( nil, nil, nil,
+ PKOLChar( fFileName ) );
+end;
+
+procedure TIniFile.ClearKey(const Key: KOLString);
+begin
+ WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ), nil,
+ PKOLChar( fFileName ) );
+end;
+
+procedure TIniFile.ClearSection;
+begin
+ WritePrivateProfileString( PKOLChar( fSection ), nil, nil,
+ PKOLChar( fFileName ) );
+end;
+
+function TIniFile.ValueBoolean(const Key: KOLString; Value: Boolean): Boolean;
+var sec: PKOLChar;
+begin
+ sec := PKOLChar( fSection );
+ if fSection = '' then
+ sec := nil;
+ if fMode = ifmRead then
+ Result := GetPrivateProfileInt( sec, PKOLChar( Key ),
+ Integer( Value ), PKOLChar( fFileName ) ) <> 0
+ else
+ begin
+ WritePrivateProfileString( sec, PKOLChar( Key ),
+ PKOLChar( KOLString( Int2Str( Integer( Value ) ) ) ),
+ PKOLChar( fFileName ) );
+ Result := Value;
+ end;
+end;
+
+function TIniFile.ValueData(const Key: KOLString; Value: Pointer;
+ Count: Integer): Boolean;
+begin
+ if fMode = ifmRead then
+ Result := GetPrivateProfileStruct( PKOLChar( fSection ), PKOLChar( Key ),
+ Value, Count, PKOLChar( fFileName ) )
+ else Result := WritePrivateProfileStruct( PKOLChar( fSection ), PKOLChar( Key ),
+ Value, Count, PKOLChar( fFileName ) );
+end;
+
+function TIniFile.ValueInteger(const Key: KOLString; Value: Integer): Integer;
+begin
+ if fMode = ifmRead then
+ Result := GetPrivateProfileInt( PKOLChar( fSection ), PKOLChar( Key ),
+ Integer( Value ), PKOLChar( fFileName ) )
+ else
+ begin
+ Result := Value;
+ WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ),
+ PKOLChar( KOLString( Int2Str( Value ) ) ), PKOLChar( fFileName ) );
+ end;
+end;
+
+function TIniFile.ValueString(const Key, Value: KOLString): KOLString;
+var
+ Buffer: array[0..4095] of KOLChar;
+begin
+ if fMode = ifmRead then
+ begin
+ Buffer[ 0 ] := #0;
+ if GetPrivateProfileString(PKOLChar(fSection),
+ PKOLChar(Key), PKOLChar(Value), Buffer, SizeOf(Buffer) div Sizeof(KOLChar),
+ PKOLChar(fFileName)) <> 0 then
+ Result := Buffer
+ else Result := ''; //: FPC выдает ошибку при отсутствии Key в INI-файле // MTsv DN
+ end else
+ begin
+ Result := Value;
+ WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ),
+ PKOLChar( Value ), PKOLChar( fFileName ) );
+ end;
+end;
+
+function TIniFile.ValueDouble(const Key: KOLString; const Value: Double): Double;
+begin
+ Result := Str2Double( ValueString( Key, Double2Str( Value ) ) );
+end;
+
+function OpenIniFile( const FileName: KOLString ): PIniFile;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TIniFile';
+ {$ENDIF}
+ Result.fFileName := FileName;
+end;
+
+/////////////////////////////////////////////////// GetSectionNames, SectionData
+// - by Vyacheslav A. Gavrik :
+
+const
+ IniBufferSize = 32767;
+ IniBufferStrSize = IniBufferSize+4; /// для махинаций :)
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+procedure TIniFile.GetSectionNames(Names:PKOLStrList);
+var
+ i:integer;
+ Pc:PKOLChar;
+ PcEnd:PKOLChar;
+ Buffer:Pointer;
+begin
+ GetMem(Buffer,IniBufferSize * Sizeof( KOLChar ));
+ Pc:=Buffer;
+ i := GetPrivateProfileSectionNames(Buffer, IniBufferSize, PKOLChar(fFileName));
+ PcEnd:=Pc+i;
+ repeat
+ Names.Add(Pc);
+ Pc:=PC+Length(PC)+1;
+ until PC>=PcEnd;
+ FreeMem(Buffer);
+end;
+
+procedure TIniFile.SectionData(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;
+ FreeMem(Buffer);
+end;
+{$ENDIF PAS_VERSION}
+
+/////////////////////////////////////////////////////////////////////////
+// M E N U
+/////////////////////////////////////////////////////////////////////////
+
+{ -- Menu implementation -- }
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator;
+begin
+ Result.fVirt := fVirt;
+ Result.Key := Key;
+end;
+{$ENDIF PAS_VERSION}
+
+function GetAcceleratorText( const Accelerator: TMenuAccelerator ): KOLString;
+var
+ KeyName: array[0..255] of KOLChar;
+
+ procedure AddKeyName( Code: Integer );
+ begin
+ Code := MapVirtualKey(Code, 0);
+ if Code = 0 then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if GetKeyNameText(Code shl 16, KeyName, 256) > 0 then begin
+ if Result <> '' then
+ Result := Result + '+';
+ Result := Result + KOLString(KeyName);
+ end;
+ end;
+
+begin
+ Result := '';
+ with Accelerator do begin
+ if fVirt and FCONTROL <> 0 then
+ AddKeyName(VK_CONTROL);
+ if fVirt and FSHIFT <> 0 then
+ AddKeyName(VK_SHIFT);
+ if fVirt and FALT <> 0 then
+ AddKeyName(VK_ALT);
+ if fVirt and $20 <> 0 then
+ AddKeyName(VK_LWIN);
+ if fVirt and $40 <> 0 then
+ AddKeyName(VK_RWIN);
+
+ AddKeyName(Key);
+ end;
+end;
+
+const
+ MIDATA_CHECKITEM = $40000000;
+ MIDATA_RADIOITEM = $80000000;
+
+
+{$IFNDEF NEW_MENU_ACCELL}
+function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+var M, M1: PMenu;
+ Idx: Integer;
+ Id: Integer;
+begin
+ Result := False;
+ if Msg.message = WM_COMMAND then
+ begin
+ if (Msg.lParam = 0) and (HIWORD( Msg.wParam ) <= 1) then
+ begin
+ M := PMenu( Sender.fMenuObj );
+ while (M = nil) and (Sender.Parent <> nil) do
+ begin
+ Sender := Sender.Parent;
+ M := PMenu( Sender.fMenuObj );
+ end;
+ while M <> nil do
+ begin
+ Id := LoWord( Msg.wParam );
+ M1 := M.Items[ Id ];
+ if M1 <> nil then
+ begin
+ Result := True;
+ Rslt := 0;
+ Idx := M.IndexOf( M1 );
+ M.fByAccel := HiWord( Msg.wParam ) <> 0;
+ if M1.FRadioGroup <> 0 then
+ M1.RadioCheckItem
+ else if M1.FIsCheckItem then
+ M1.Checked := not M1.Checked;
+ if Assigned(M1.FOnMenuItem) then
+ M1.FOnMenuItem( M, Idx )
+ else if Assigned( M.FOnMenuItem ) then
+ M.FOnMenuItem( M, Idx );
+ break;
+ end;
+ M := M.fNextMenu;
+ end;
+ end;
+ end;
+end;
+
+{$ELSE}
+
+function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+
+ function ProcessMenuItem(M: PMenu; Id: Integer): Boolean;
+ var
+ M1: PMenu;
+ Idx: Integer;
+ begin
+ M1 := M.Items[ Id ];
+ Result := (M1 <> nil);
+ if Result then
+ begin
+ Idx := M.IndexOf( M1 );
+ M.fByAccel := HiWord( Msg.wParam ) <> 0;
+ if M1.FRadioGroup <> 0 then
+ M1.RadioCheckItem
+ else if M1.FIsCheckItem then
+ M1.Checked := not M1.Checked;
+ if Assigned(M1.FOnMenuItem) then
+ begin
+ {$IFDEF USE_MENU_CURCTL}
+ M.fCurCtl := Sender; // fixed
+ {$ENDIF}
+ M1.FOnMenuItem( M, Idx )
+ end else if Assigned( M.FOnMenuItem ) then
+ M.FOnMenuItem( M, Idx );
+ end;
+ end;
+
+var
+ M: PMenu;
+ Id: Integer;
+begin
+ Result := False;
+ if Msg.message = WM_COMMAND then
+ if (Msg.lParam = 0) and (HIWORD( Msg.wParam ) <= 1) then begin
+ Id := LoWord(Msg.wParam);
+ M := PMenu(Sender.fAutoPopupMenu);
+ if (M <> nil) and ProcessMenuItem(M, Id) then begin
+ Result := True;
+ Rslt := 0;
+ end else
+ begin
+ M := PMenu(Sender.fMenuObj);
+ while M <> nil do begin
+ if ProcessMenuItem(M, Id) then begin
+ Result := True;
+ Rslt := 0;
+ Break;
+ end;
+ M := M.fNextMenu;
+ end;
+ end;
+ end;
+end;
+{$ENDIF}
+
+{$ENDIF WIN_GDI}
+
+{$IFDEF GDI}
+function NewMenu( AParent : PControl; MaxCmdReserve : DWORD;
+ const Template : array of PKOLChar; aOnMenuItem: TOnMenuItem ): PMenu;
+var M: PMenu;
+ {$IFDEF INITIALFORMSIZE_FIXMENU}
+ R: TRect;
+ {$ENDIF}
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TMenu';
+ {$ENDIF}
+ Result.FVisible := TRUE;
+ Result.FPopupFlags := TPM_LEFTALIGN or TPM_LEFTBUTTON;
+ Result.FMenuItems := NewList;
+ Result.FOnMenuItem := aOnMenuItem;
+ if (High(Template)>=0) and (Template[0] <> nil) then
+ begin
+ if (AParent <> nil) and (AParent.fMenuObj = nil) and
+ {$IFDEF USE_FLAGS} not (G3_IsControl in AParent.fFlagsG3)
+ {$ELSE} not AParent.fIsControl {$ENDIF} then
+ Result.FHandle := CreateMenu
+ else Result.FHandle := CreatePopupMenu;
+ Result.FillMenuItems( Result.FHandle, 0, Template );
+ end;
+ if ( AParent <> nil ) then
+ begin
+ Result.FControl := AParent;
+ if AParent.fMenuObj <> nil then
+ begin
+ // add popup menu to the end of menu chain
+ M := PMenu( AParent.fMenuObj );
+ while M.fNextMenu <> nil do
+ M := M.fNextMenu;
+ M.fNextMenu := Result;
+ end else
+ begin
+ if {$IFDEF USE_FLAGS} not(G3_IsControl in AParent.fFlagsG3)
+ {$ELSE} not AParent.fIsControl {$ENDIF} then
+ begin
+ {$IFDEF INITIALFORMSIZE_FIXMENU}
+ R := AParent.ClientRect;
+ {$ENDIF}
+ AParent.Menu := Result.FHandle;
+ {$IFDEF INITIALFORMSIZE_FIXMENU}
+ AParent.SetClientSize( R.Right, R.Bottom );
+ {$ENDIF}
+ end;
+ AParent.fMenuObj := Result;
+ AParent.AttachProc( WndProcMenu );
+ {$IFDEF USE_AUTOFREE4CONTROLS}
+ AParent.Add2AutoFree( Result );
+ {$ENDIF}
+ end;
+ end;
+end;
+{$ENDIF GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+//--- some code from samples - may be useful to see "how to"
+FUNCTION AddSeparatorToMenu( Menu : PGtkMenu ) : PgtkMenuItem ;
+BEGIN
+ Result := PGtkMenuitem( gtk_menu_item_new ) ;
+ gtk_menu_append( GTK_WIDGET( Menu ), PGtkWidget( Result ) ) ;
+ gtk_widget_show( PGtkWidget ( Result ) ) ;
+END;
+
+FUNCTION AddItemToMenu( Menu : PGtkMenu;
+ ShortCuts : PGtkAccelGroup;
+ const Caption : AnsiString;
+ const ShortCut : AnsiString;
+ CallBack : TGtkSignalFunc;
+ CallBackdata : Pointer ) : PGtkMenuItem;
+VAR
+ Key, Modifiers : DWORD;
+ //LocalAccelGroup : PGtkAccelGroup; -- not used since gtk_menu_ensure_uline_accel_group not defined anywhere...
+ TheLabel : PGtkLabel;
+BEGIN
+ Result := PGtkMenuItem ( gtk_menu_item_new_with_label( '' ) ) ;
+ TheLabel := GTK_LABEL(GTK_BIN( Result )^.child ) ;
+ Key:= gtk_label_parse_uline( TheLabel , Pchar ( Caption ) ) ;
+ //----------------
+ {If Key<>0 then // gtk_menu_ensure_uline_accel_group -- not defined anywhere...
+ begin
+ LocalAccelGroup := gtk_menu_ensure_uline_accel_group( Menu );
+ gtk_widget_add_accelerator( PGtkWidget ( Result ), 'activateitem',
+ LocalAccelGroup , Key ,
+ 0 , TGtkAccelFlags ( 0 ) ) ;
+ end;}
+ //-----------------
+ gtk_menu_append( GTK_WIDGET( Menu ), PGtkWidget( Result ) ) ;
+ //-----------------
+ IF ( ShortCut<>'' ) AND ( ShortCuts<> Nil ) THEN
+ BEGIN
+ gtk_accelerator_parse ( pchar( ShortCut ) , @key , @modifiers ) ;
+ gtk_widget_add_accelerator ( PGtkWidget ( Result ) , ' activateitem' ,
+ ShortCuts, Key, modifiers, GTK_ACCEL_VISIBLE );
+ END;
+ //------------------
+ IF Assigned( CallBack ) THEN
+ BEGIN
+ gtk_signal_connect( PGtkObject ( Result ) , 'activate' ,
+ CallBack , CallBackdata ) ;
+ gtk_widget_show( PgtkWidget ( Result ) ) ;
+ END;
+END;
+
+FUNCTION AddMenuToMenuBar( MenuBar : PGtkMenuBar;
+ ShortCuts : PGtkAccelGroup;
+ Caption : AnsiString;
+ CallBack : TGtkSignalFunc;
+ CallBackdata : Pointer;
+ AlignRight : Boolean;
+ Var MenuItem : PgtkMenuItem ) : PGtkMenu;
+VAR Key : DWORD;
+ TheLabel : PGtkLabel;
+BEGIN
+ MenuItem := PGtkMenuItem( gtk_menu_item_new_with_label( '' ) ) ;
+ IF AlignRight THEN
+ gtk_menu_item_right_justify( MenuItem );
+ TheLabel := GTK_LABEL( GTK_BIN( MenuItem )^ .child ) ;
+ Key := gtk_label_parse_uline( TheLabel, Pchar ( Caption ) ) ;
+ IF Key<>0 THEN
+ gtk_widget_add_accelerator( PGtkWidget( MenuItem ), 'activateitem',
+ Shortcuts, Key, GDK_MOD1_MASK, GTK_ACCEL_LOCKED );
+ Result := PGtkMenu( gtk_menu_new );
+ If Assigned( CallBack ) then
+ gtk_signal_connect( PGtkObject ( Result ), 'activate',
+ CallBack, CallBackdata ) ;
+ gtk_widget_show( PgtkWidget ( MenuItem ) ) ;
+ gtk_menu_item_set_submenu( MenuItem, PGtkWidget( Result ) ) ;
+ gtk_menu_bar_append( GTK_WIDGET( MenuBar ), PgtkWidget( MenuItem ) ) ;
+END;
+
+FUNCTION NewMenu( AParent : PControl; MaxCmdReserve : DWORD;
+ CONST Template : ARRAY of PKOLChar; aOnMenuItem: TOnMenuItem ): PMenu;
+ PROCEDURE CreateMenuItems( ParentMenu: PMenu; var i: Integer );
+ VAR Item, PrevItem: PMenu;
+ s: AnsiString;
+ j: Integer;
+ BEGIN
+ PrevItem := nil;
+ WHILE i <= High( Template )-1 DO
+ BEGIN
+ inc( i );
+ s := Template[ i ];
+ IF s = '' THEN BREAK; // end of template
+
+ IF s = ')' THEN
+ inc( i ); break; // end of submenu
+
+ new( Item, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Item.fObjKind := 'MenuItem';
+ {$ENDIF}
+ Item.FCaption := s;
+ Item.FVisible := TRUE;
+ Item.FParentMenu := ParentMenu;
+ if ParentMenu.FItems = nil then
+ ParentMenu.FItems := NewList;
+ ParentMenu.FItems.Add( Item );
+
+ IF (s <> '') AND ((s[ 1 ] = '+') or (s[ 1 ] = '-')) THEN
+ BEGIN
+ Item.fIsCheckItem := TRUE;
+ Item.fChecked := S[ 1 ] = '+';
+ s := CopyEnd( s, 2 );
+ IF (s <> '') and (s[ 1 ] = '!') THEN
+ BEGIN
+ IF PrevItem <> nil THEN
+ BEGIN
+ if PrevItem.fRadioGroup <> 0 THEN
+ Item.fRadioGroup := PrevItem.fRadioGroup;
+ END
+ ELSE inc( Item.fRadioGroup );
+ s := CopyEnd( s, 2 );
+ END;
+ END;
+
+ IF s = '-' THEN
+ Item.fIsSeparator := TRUE
+ ELSE
+ BEGIN
+ FOR j := Length( s )-1 DOWNTO 1 DO // extract mnemonic
+ BEGIN
+ IF (s[ j ] = '&') and (s[ j+1 ] <> '&') then // mnemonic
+ BEGIN
+ Item.fMnemonics := Item.fMnemonics + s[ j+1 ];
+ Delete( s, j, 1 );//? <U>m</U> ?
+ END;
+ END;
+ END;
+
+ //---------------------------- now call gtk for create item's widget
+ IF Item.FIsSeparator THEN
+ Item.fGtkMenuItem := gtk_menu_item_new
+ ELSE Item.fGtkMenuItem := gtk_menu_item_new_with_label( PAnsiChar( s ) );
+ IF ParentMenu.fGtkMenuBar <> nil THEN
+ gtk_menu_bar_append( ParentMenu.fGtkMenuBar, Item.fGtkMenuItem )
+ ELSE gtk_menu_shell_append(
+ GTK_MENU_SHELL( ParentMenu.fGtkMenuShell ), Item.fGtkMenuItem );
+
+ IF s = '(' THEN
+ BEGIN
+ inc( i );
+ IF PrevItem <> nil THEN
+ BEGIN
+ PrevItem.fGtkMenuShell := gtk_menu_new;
+ gtk_menu_item_set_submenu(
+ GTK_MENU_ITEM( PrevItem.fGtkMenuItem ),
+ PrevItem.fGtkMenuShell );
+ CreateMenuItems( PrevItem, i );
+ END;
+ END;
+
+ PrevItem := Item;
+ END;
+ END;
+VAR i: Integer;
+BEGIN
+ new( Result, Create );
+ i := -1;
+ IF AParent.fMenuObj = nil THEN
+ BEGIN // создается главное меню с линейкой меню (наверху формы? любого контрола?)
+ AParent.fMenuObj := Result;
+ Result.fGtkMenuBar := gtk_menu_bar_new;
+ //AParent.fMenuBar := Result.fGtkMenuBar;
+ gtk_container_add( GTK_CONTAINER( AParent.fClient ), Result.fGtkMenuBar );
+ gtk_widget_show( Result.fGtkMenuBar );
+ END else
+ BEGIN
+ PMenu( AParent.fMenuObj ).fNextMenu := Result;
+ Result.fGtkMenuShell := gtk_menu_new;
+ END;
+ CreateMenuItems( Result, i );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+function NewMenuEx( AParent : PControl; FirstCmd : Integer;
+ const Template : array of PKOLChar; aOnMenuItems: array of TOnMenuItem ): PMenu;
+begin
+ Result := NewMenu( AParent, FirstCmd, Template, nil );
+ {$IFDEF GDI}
+ Result.AssignEvents( 0, aOnMenuItems );
+ {$ENDIF GDI}
+end;
+
+{$IFDEF WIN_GDI}
+{ TMenu }
+
+const
+ Breaks: array[ TMenuBreak ] of DWORD = ( 0, MFT_MENUBREAK, MFT_MENUBARBREAK );
+
+{ + by AK - Andrzej Kubaszek }
+function MenuStructSize: Integer;
+begin
+ Result := 44;
+ if not( WinVer in [wv31, wv95, wvNT] ) then
+ Result := {48=} Sizeof( TMenuItemInfo );
+end;
+{$ENDIF WIN_GDI}
+
+{$IFDEF GDI}
+destructor TMenu.Destroy;
+var Next, Prnt: PMenu;
+begin
+ {$IFDEF DEBUG_MENU_DESTROY}
+ LogFileOutput( GetStartDir + 'TMenu.Destroy.txt',
+ Int2Hex( DWORD( @ Self ), 6 ) + ' ' + Int2Str( RefCount ) );
+ {$ENDIF}
+ if Count > 0 then
+ begin
+ FMenuItems.ReleaseObjects;
+ FMenuItems := NewList;
+ end;
+ if FParentMenu <> nil then
+ begin
+ Prnt := FParentMenu;
+ Next := Prnt.RemoveSubMenu( FId );
+ FParentMenu := nil;
+ Prnt.FMenuItems.Remove( @ Self );
+ if Next = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if (FControl <> nil) and (FControl.fMenu = FHandle) and (FHandle <> 0) then
+ begin
+ if {$IFDEF USE_FLAGS} not (G2_Destroying in FControl.fFlagsG2)
+ {$ELSE} not FControl.fDestroying {$ENDIF} then //!!!fix by Galkov
+ begin
+ Windows.SetMenu( FControl.fHandle, 0 );
+ // this removes main menu from window, but does not destroy it
+ end;
+ FControl.fMenu := 0;
+ Next := PMenu( FControl.fMenuObj );
+ while Next <> nil do
+ begin
+ if Next.fNextMenu = @Self then
+ begin
+ Next.fNextMenu := fNextMenu;
+ break;
+ end;
+ Next := Next.fNextMenu;
+ end;
+ end;
+ Next := fNextMenu;
+ if FBitmap <> 0 then
+ Bitmap := 0;
+ if FHandle <> 0 then
+ begin
+ //if not
+ DestroyMenu( FHandle )
+ // then LogFileOutput( GetStartDir + 'err.log.txt', SysErrorMessage( GetLastError ) )
+ ;
+ end;
+ FCaption := '';
+ FMenuItems.Free;
+ Next.Free;
+ inherited;
+ // all later created (popup) menus (of the same control)
+ // are destroyed too
+end;
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+DESTRUCTOR TMenu.Destroy;
+//var Next, Prnt: PMenu;
+BEGIN
+ {$IFDEF DEBUG_MENU_DESTROY}
+ LogFileOutput( GetStartDir + 'TMenu.Destroy.txt',
+ Int2Hex( DWORD( @ Self ), 6 ) + ' ' + Int2Str( RefCount ) );
+ {$ENDIF}
+ //if Count > 0 then
+ IF ( fMenuItems <> nil ) THEN
+ BEGIN
+ FMenuItems.ReleaseObjects;
+ FMenuItems := NewList;
+ END;
+ FCaption := '';
+ fMnemonics := '';
+ FMenuItems.Free;
+ INHERITED;
+ // all later created (popup) menus (of the same control)
+ // are destroyed too
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+function TMenu.GetInfo( var MII: TMenuItemInfo ): Boolean;
+begin
+ MII.cbSize := MenuStructSize;
+ Result := GetMenuItemInfo( Parent.FHandle, FId, FALSE,
+ Windows.PMenuitemInfo( @ MII )^ );
+end;
+
+procedure TMenu.RedrawFormMenuBar;
+var C: PControl;
+begin
+ C := TopParent.FControl;
+ if not AppletTerminated then
+ if (C <> nil) and (Pointer( C.fMenuObj ) = Pointer( TopParent )) then
+ DrawMenuBar( C.FHandle );
+end;
+
+function TMenu.SetInfo( var MII: TMenuItemInfo ): Boolean;
+var H: THandle;
+begin
+ MII.cbSize := MenuStructSize;
+ H := FHandle;
+ if FParentMenu <> nil then
+ H := FParentMenu.FHandle;
+ {$IFNDEF UNICODE_CTRLS}
+ Result := SetMenuItemInfo( H, FId, FALSE, Windows.PMenuitemInfo( @ MII )^ );
+ {$ELSE}
+ Result := SetMenuItemInfoW( H, FId, FALSE, Windows.PMenuitemInfoW( @ MII )^ );
+ {$ENDIF}
+ if Result and ((FParentMenu = nil) or (FParentMenu.FParentMenu = nil)) then {YS}
+ RedrawFormMenuBar;
+end;
+
+function TMenu.SetTypeInfo( var MII: TMenuItemInfo ): Boolean;
+begin
+ if not FIsSeparator then
+ begin
+ if FBmpItem = 0 then
+ MII.dwTypeData := PKOLChar( FCaption )
+ else MII.dwTypeData := Pointer( FBmpItem );
+ MII.cch := Length( FCaption )*SizeOfKOLChar;
+ end;
+ Result := SetInfo( MII );
+end;
+
+function TMenu.GetTopParent: PMenu;
+begin
+ Result := @ Self;
+ while Result.FParentMenu <> nil do
+ Result := Result.FParentMenu;
+end;
+
+function TMenu.GetControl: PControl;
+begin
+ Result := TopParent.FControl;
+end;
+
+function TMenu.GetItems( Id: HMenu ): PMenu;
+ function SearchItems( ParentMenu: PMenu; var FromIdx: Integer ): PMenu;
+ var I: Integer;
+ begin
+ Result := ParentMenu;
+ if Id = HMenu( FromIdx ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if (Id >= 4096) and (DWORD( ParentMenu.FId ) = Id) then Exit; {>>>>>>>>>>>>}
+ if ParentMenu.FMenuItems = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ for I := 0 to ParentMenu.FMenuItems.FCount-1 do
+ begin
+ Inc( FromIdx );
+ Result := SearchItems( ParentMenu.FMenuItems.Items[ I ], FromIdx );
+ if Result <> nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := nil;
+ end;
+var I: Integer;
+begin
+ I := -1;
+ Result := SearchItems( @ Self, I );
+end;
+
+function TMenu.GetCount: Integer;
+var I: Integer;
+ SubM: PMenu;
+begin
+ Result := FMenuItems.FCount;
+ for I := 0 to Result-1 do
+ begin
+ SubM := FMenuItems.Items[ I ];
+ Result := Result + SubM.Count;
+ end;
+end;
+
+function TMenu.IndexOf( Item: PMenu ): Integer;
+ function SearchMenu( ParentMenu: PMenu; var FromIdx: Integer ): PMenu;
+ var I: Integer;
+ begin
+ Result := ParentMenu;
+ if Result = Item then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ for I := 0 to ParentMenu.FMenuItems.FCount-1 do
+ begin
+ Inc( FromIdx );
+ Result := SearchMenu( ParentMenu.FMenuItems.Items[ I ], FromIdx );
+ if Result <> nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := nil;
+ end;
+begin
+ Result := -1;
+ if SearchMenu( @ Self, Result ) = nil then
+ Result := -2;
+end;
+
+function TMenu.GetState( const Index: Integer ): Boolean;
+var MII: TMenuItemInfo;
+begin
+ if FVisible then
+ begin
+ MII.fMask := MIIM_STATE;
+ if GetInfo( MII ) then
+ FSavedState := MII.fState;
+ end;
+ Result := LongBool( FSavedState and Index );
+ if Index < 0 then
+ Result := not Result;
+end;
+
+procedure TMenu.SetState( const Index: Integer; Value: Boolean );
+var MII: TMenuItemInfo;
+begin
+ GetState( 0 );
+ if Value xor (Index < 0) then
+ FSavedState := FSavedState or DWORD( Index and $7FFFFFFF )
+ else FSavedState := FSavedState and not DWORD( Index );
+ if FVisible then
+ begin
+ MII.fMask := MIIM_STATE;
+ if GetInfo( MII ) then
+ begin
+ MII.fState := FSavedState;
+ SetInfo( MII );
+ end;
+ end;
+end;
+
+procedure TMenu.SetData( Value: Pointer );
+var MII: TMenuItemInfo;
+begin
+ MII.fMask := MIIM_DATA;
+ MII.dwItemData := DWORD( Value );
+ SetInfo( MII );
+ FData := Value;
+end;
+
+procedure TMenu.ClearBitmaps;
+begin
+ if FBitmap <> 0 then
+ DeleteObject( FBitmap );
+ if FBmpChecked <> 0 then
+ DeleteObject( FBmpChecked );
+ if FBmpItem <> 0 then
+ DeleteObject( FBmpItem );
+end;
+
+procedure TMenu.SetBitmap( Value: HBitmap );
+var MII: TMenuItemInfo;
+begin
+ if not FClearBitmaps then
+ begin
+ FClearBitmaps := TRUE;
+ Add2AutoFreeEx( ClearBitmaps );
+ end;
+ if Value = FBitmap then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if FBitmap <> 0 then
+ DeleteObject( FBitmap ); // seems not necessary.
+ FBitmap := Value;
+ MII.fMask := MIIM_CHECKMARKS;
+ MII.hbmpChecked := FBmpChecked;
+ MII.hbmpUnchecked := FBitmap;
+ SetInfo( MII );
+end;
+
+procedure TMenu.SetBmpChecked( Value: HBitmap );
+var MII: TMenuItemInfo;
+begin
+ if not FClearBitmaps then
+ begin
+ FClearBitmaps := TRUE;
+ Add2AutoFreeEx( ClearBitmaps );
+ end;
+ if Value = FBmpChecked then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if FBmpChecked <> 0 then
+ DeleteObject( FBmpChecked );
+ FBmpChecked := Value;
+ MII.fMask := MIIM_CHECKMARKS;
+ MII.hbmpChecked := FBmpChecked;
+ MII.hbmpUnchecked := FBitmap;
+ SetInfo( MII );
+end;
+
+procedure TMenu.SetBmpItem( Value: HBitmap );
+var MII: TMenuItemInfo;
+begin
+ if not FClearBitmaps then
+ begin
+ FClearBitmaps := TRUE;
+ Add2AutoFreeEx( ClearBitmaps );
+ end;
+ if Value = FBmpItem then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if FBmpItem <> 0 then
+ DeleteObject( FBmpItem );
+ FBmpItem := Value;
+ if WinVer >= wv98 then {AK}
+ begin {AK}
+ MII.fMask := $80 {MIIM_BITMAP} ; {AK}
+ MII.hbmpItem:=Value; {AK}
+ end else {AK}
+ begin//I haven't possibility to test it in Win95 {AK}
+ MII.fType := MFT_BITMAP;
+ MII.dwItemData := Value;
+ end; {AK}
+ SetInfo( MII );
+end;
+
+{$IFNDEF NEW_MENU_ACCELL}
+procedure TMenu.SetAccelerator(const Value: TMenuAccelerator);
+const MaxAccel = 1000;
+type TAccTab = array[0..10000] of TAccel;
+ PAccTab = ^TAccTab;
+var AccTab: PAccTab;
+ I, N : Integer;
+ M, SubM: PMenu;
+ C: PControl;
+ Main: Boolean;
+begin
+ if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FAccelerator := Value;
+ C := TopParent.FControl;
+ if C = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if C.fAccelTable <> 0 then
+ DestroyAcceleratorTable( C.fAccelTable );
+ C.fAccelTable := 0;
+ GetMem( AccTab, sizeof( TAccel ) * MaxAccel );
+ N := 0;
+ M := PMenu( C.fMenuObj );
+ Main := TRUE;
+ while M <> nil do
+ begin
+ if Main or M.Visible then
+ begin
+ for I := 0 to MaxInt-1 do
+ begin
+ SubM := M.Items[ I ];
+ if SubM = nil then break;
+ if SubM.FVisible then
+ if (SubM.FAccelerator.Key <> 0) or (SubM.FAccelerator.fVirt <> 0) then
+ begin
+ AccTab[ N ].fVirt := SubM.FAccelerator.fVirt;
+ AccTab[ N ].key := SubM.FAccelerator.Key;
+ AccTab[ N ].cmd := WORD( SubM.FId );
+ Inc( N );
+ if N > MaxAccel then break;
+ end;
+ end;
+ end;
+ if N > MaxAccel then break;
+ M := M.fNextMenu;
+ end;
+ if N > 0 then
+ begin
+ C.fAccelTable := CreateAcceleratorTable( AccTab[ 0 ], N );
+ {$IFDEF USE_AUTOFREE4CONTROLS}
+ C.Add2AutoFreeEx( C.DoDestroyAccelTable );
+ {$ENDIF}
+ C := C.ParentForm;
+ if C <> nil then
+ C.SupportMnemonics;
+ end;
+ FreeMem( AccTab );
+end;
+
+{$ELSE NEW_MENU_ACCELL}
+
+procedure TMenu.SetAccelerator(const Value: TMenuAccelerator);
+var C: PControl;
+ M: PMenu;
+begin
+ if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FAccelerator := Value;
+ C := FControl;
+ M := @Self;
+ while (C = nil) and (M <> nil) do begin
+ M := M.Parent;
+ if (M <> nil) then C := M.FControl;
+ end;
+ if C <> nil then C.SupportMnemonics;
+end;
+
+{$ENDIF NEW_MENU_ACCELL}
+
+procedure TMenu.SetMenuItemCaption( const Value: KOLString );
+var MII: TMenuItemInfo;
+begin
+ FCaption := Value;
+ if FParentMenu = nil then Exit; {+ecm} {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+{AK}if not (WinVer in [wv95,wvNT]) then
+{AK} MII.fMask := $40 {MIIM_STRING}
+{AK}else begin
+ MII.fMask := MIIM_TYPE;
+ MII.fType := MFT_STRING;
+{AK}end;
+ MII.cch := 0; // to fix turning radio mark to check mark in NT4
+ GetInfo( MII ); //-----------------------------------------------
+ MII.dwTypeData := PKOLChar( Value );
+ MII.cch := Length( Value )*SizeOfKOLChar;
+ SetInfo( MII );
+end;
+
+procedure TMenu.SetMenuBreak( Value: TMenuBreak );
+var MII: TMenuItemInfo;
+begin
+ if FId = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if FMenuBreak = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FMenuBreak := Value;
+ //FillChar( MII, Sizeof( MII ), #0 );
+ ZeroMemory( @MII, Sizeof( MII ) );
+ MII.fMask := MIIM_TYPE;
+ MII.dwTypeData := nil;
+ if GetInfo( MII ) then
+ begin
+ MII.fType := MII.fType and not( MFT_MENUBREAK or MFT_MENUBARBREAK ) or
+ Breaks[ Value ];
+ SetTypeInfo( MII );
+ end;
+end;
+
+procedure TMenu.SetMenuVisible( Value: Boolean );
+var I, J: Integer;
+ M: PMenu;
+ Before: Integer;
+ ByPosition: Boolean;
+ MII: TMenuItemInfo;
+begin
+ if Value then
+ if FParentMenu <> nil then
+ FParentMenu.Visible := TRUE;
+ if Value = FVisible then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FVisible := Value;
+ if (FControl <> nil) and (FControl.fMenuObj = @ Self) then
+ begin
+ FControl.GetWindowHandle;
+ if Value then
+ SetMenu( FControl.fHandle, FHandle )
+ else
+ SetMenu( FControl.fHandle, 0 );
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if FId = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if FParentMenu = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Value then
+ begin // show menu item inserting it again into appropriate position
+ Before := -1;
+ ByPosition := TRUE;
+ I := FParentMenu.FMenuItems.IndexOf( @ Self );
+ for J := I + 1 to FParentMenu.FMenuItems.FCount-1 do
+ begin
+ M := FParentMenu.FMenuItems.Items[ J ];
+ if M.FVisible then
+ begin
+ Before := M.FId;
+ ByPosition := FALSE;
+ break;
+ end;
+ end;
+ ZeroMemory( @MII, Sizeof( MII ) );
+ MII.cbSize := MenuStructSize;
+ MII.fMask := MII.fMask or
+ (MIIM_CHECKMARKS or MIIM_ID or MIIM_STATE or MIIM_TYPE);
+ MII.fType := Breaks[ FMenuBreak ];
+ MII.fState := FSavedState;
+ MII.wID := FId;
+ MII.dwItemData := DWORD( FData );
+ if not FIsSeparator then
+ begin
+ //MII.fType := MII.fType or MFT_STRING { = 0 };
+ MII.dwTypeData := PKOLChar( FCaption );
+ MII.cch := Length( FCaption )*SizeOfKOLChar;
+ end else
+ MII.fType := MII.fType or MFT_SEPARATOR;
+ if FRadioGroup <> 0 then
+ MII.fType := MII.fType or MFT_RADIOCHECK;
+ if FOwnerDraw then
+ MII.fType := MII.fType or MFT_OWNERDRAW;
+ if FBitmap <> 0 then
+ begin
+ MII.fMask := MII.fMask or MIIM_CHECKMARKS;
+ MII.hbmpUnchecked := FBitmap;
+ end;
+ if FHandle <> 0 then
+ begin
+ MII.fMask := MII.fMask or MIIM_SUBMENU;
+ MII.hSubMenu := FHandle;
+ end;
+ {$IFNDEF UNICODE_CTRLS}
+ InsertMenuItem( FParentMenu.FHandle, Before, ByPosition,
+ Windows.PMenuitemInfo( @ MII )^ );
+ {$ELSE}
+ InsertMenuItemW( FParentMenu.FHandle, Before, ByPosition,
+ Windows.PMenuitemInfoW( @ MII )^ );
+ {$ENDIF}
+ end else
+ begin // hide menu item removing it
+ GetState( 0 ); // store menu item state in FSavedState to allow
+ // changing its state while it is not attached to
+ // a menu
+ RemoveMenu( TopParent.FHandle, FId, MF_BYCOMMAND );
+ end;
+ if (FControl <> nil) or (FParentMenu <> nil) and (FParentMenu.FControl <> nil) then
+ RedrawFormMenuBar;
+end;
+
+procedure TMenu.RadioCheckItem;
+var I, J: Integer;
+ M, First, Last: PMenu;
+begin
+ if (FParentMenu <> nil) and (FRadioGroup <> 0) then
+ begin
+ I := FParentMenu.FMenuItems.IndexOf( @ Self );
+ if I >= 0 then
+ begin
+ First := @ Self;
+ Last := @ Self;
+ for J := I-1 downto 0 do
+ begin
+ M := FParentMenu.FMenuItems.Items[ J ];
+ if M.FRadioGroup <> FRadioGroup then break;
+ if M.FVisible then
+ First := M;
+ end;
+ for J := I+1 to FParentMenu.FMenuItems.FCount-1 do
+ begin
+ M := FParentMenu.FMenuItems.Items[ J ];
+ if M.FRadioGroup <> FRadioGroup then break;
+ if M.FVisible then
+ Last := M;
+ end;
+ if First <> Last then
+ begin
+ CheckMenuRadioItem( FParentMenu.FHandle, First.FId, Last.FId,
+ FId, MF_BYCOMMAND );
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end;
+ Checked := TRUE;
+end;
+
+function TMenu.FillMenuItems(AHandle: HMenu; StartIdx: Integer;
+ const Template: array of PKOLChar): Integer;
+var S, S1: PKOLChar;
+ I: Integer;
+ MII: TMenuItemInfo;
+ Item, PrevItem: PMenu;
+begin
+ PrevItem := nil;
+ I := StartIdx;
+ while I <= High( Template ) do
+ begin
+ S := Template[ I ];
+ if (S = nil) or (S^ = #0) then break;
+ {$IFDEF UNICODE_CTRLS}
+ if KOLString( S ) = {$IFDEF F_P}'' +{$ENDIF} ')' then
+ {$ELSE}
+ if PWORD(S)^ = WORD(')') then
+ {$ENDIF}
+ begin
+ Result := I + 1; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+
+ new( Item, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Item.fObjKind := 'MenuItem';
+ {$ENDIF}
+ Item.FVisible := TRUE;
+ Item.FParentMenu := @ Self;
+ Item.FMenuItems := NewList;
+ FMenuItems.Add( Item );
+
+ ZeroMemory( @MII, Sizeof( MII ) );
+ MII.cbSize := MenuStructSize;
+ MII.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;
+ {$IFDEF UNICODE_CTRLS}
+ if KOLString( S ) <> {$IFDEF F_P}'' +{$ENDIF} '-' then
+ {$ELSE}
+ if PWORD(S)^ <> WORD('-') then
+ {$ENDIF}
+ begin
+ if (S^ = {$IFDEF F_P}'' +{$ENDIF} '-') or
+ (S^ = {$IFDEF F_P}'' +{$ENDIF} '+') then
+ begin
+ Item.FIsCheckItem := TRUE;
+ MII.dwItemData := MIDATA_CHECKITEM;
+ if S^ <> {$IFDEF F_P}'' +{$ENDIF} '-' then
+ MII.fState := MII.fState or MFS_CHECKED;
+ Inc( S );
+ if S^ = {$IFDEF F_P}'' +{$ENDIF} '!' then
+ begin
+ MII.fType := MII.fType or MFT_RADIOCHECK;
+ MII.dwItemData := MII.dwItemData or MIDATA_RADIOITEM;
+ Inc( S );
+ if PrevItem <> nil then
+ begin
+ if PrevItem.FRadioGroup <> 0 then
+ Item.FRadioGroup := PrevItem.FRadioGroup;
+ end;
+ if Item.FRadioGroup = 0 then
+ Inc( Item.FRadioGroup );
+ if S^ = {$IFDEF F_P}'' +{$ENDIF} '!' then
+ begin
+ Inc( S );
+ Inc( Item.FRadioGroup );
+ end;
+ end;
+ end;
+ Item.FCaption := S;
+ end
+ else
+ begin
+ Item.FIsSeparator := TRUE;
+ MII.fType := MFT_SEPARATOR;
+ MII.fState := MFS_GRAYED;
+ //MII.wID := 0;
+ end;
+ Item.FId := FDynamicMenuID;
+ Inc( FDynamicMenuID );
+ MII.wID := Item.FId;
+ if I <> High( Template ) then //YS
+ begin //YS
+ S1 := Template[ I + 1 ];
+ {$IFDEF UNICODE_CTRLS}
+ if KOLString( S1 ) = {$IFDEF F_P}'' +{$ENDIF} '(' then
+ {$ELSE}
+ if (S1 <> nil) and (PWORD(S1)^ = WORD('(')) then
+ {$ENDIF}
+ Item.FHandle := CreatePopupMenu;
+ end; //YS
+ MII.hSubMenu := Item.FHandle;
+ MII.dwTypeData := PKOLChar( S );
+ MII.cch := {$IFDEF UNICODE_CTRLS} WStrLen( S ) {$ELSE} StrLen( S ) {$ENDIF};
+ InsertMenuItem( AHandle, DWORD(-1), True, PMenuitemInfo( @ MII )^ );
+ if Item.FHandle <> 0 then
+ I := Item.FillMenuItems( Item.FHandle, I + 2, Template )
+ else
+ Inc( I );
+ PrevItem := Item;
+ end;
+ Result := I;
+end;
+
+procedure TMenu.AssignEvents(StartIdx: Integer;
+ const Events: array of TOnMenuItem);
+var I: Integer;
+ M: PMenu;
+begin
+ for I := 0 to High(Events) do
+ begin
+ M := Items[ StartIdx ];
+ if M = nil then break;
+ M.FOnMenuItem := Events[ I ];
+ Inc( StartIdx );
+ end;
+end;
+
+function TMenu.Popup(X, Y: Integer): Integer;
+begin
+ {$IFDEF GDI}
+ if Assigned( fOnPopup ) then fOnPopup( @Self );
+ if not FNotPopup then
+ Result := Integer( TrackPopupMenu( FHandle, FPopupFlags, {*ecm}
+ X, Y, 0, FControl.Handle, nil ) ) {*ecm}
+ else Result := 0; {*ecm}
+ {$ENDIF GDI}
+end;
+
+function TMenu.PopupEx( X, Y: Integer ): Integer;
+{$IFDEF GDI}
+var OldBounds: TRect;
+ WasVisible: Boolean;
+{$ENDIF GDI}
+begin
+ {$IFDEF GDI}
+ WasVisible := TRUE;
+ if FControl <> nil then
+ begin
+ OldBounds := FControl.BoundsRect;
+ if {$IFDEF USE_FLAGS} not(G3_IsControl in FControl.fFlagsG3)
+ {$ELSE} not FControl.fIsControl {$ENDIF} then
+ begin
+ WasVisible := FControl.Visible;
+ if not WasVisible then
+ FControl.Top := ScreenHeight + 50;
+ FControl.Show;
+ end;
+ end;
+ // -- by Martin Larsen: -----------------------
+ FControl.ProcessMessage; // specific for Win9x!
+ Result := Popup( X, Y ); {*ecm}
+ if FControl <> nil then
+ begin
+ if FControl.Top = ScreenHeight + 50 then
+ begin
+ if not WasVisible then
+ FControl.Visible := FALSE;
+ FControl.BoundsRect := OldBounds;
+ end;
+ end;
+ {$ENDIF GDI}
+end;
+
+function TMenu.GetItemChecked( Item : Integer ) : Boolean;
+begin
+ Result := Items[ Item ].Checked;
+end;
+
+procedure TMenu.SetItemChecked( Item : Integer; Value : Boolean );
+begin
+ Items[ Item ].Checked := Value;
+end;
+
+function TMenu.GetMenuItemHandle( Idx : Integer ): DWORD;
+begin
+ Result := Items[ Idx ].FId;
+end;
+
+procedure TMenu.RadioCheck( Idx : Integer );
+begin
+ Items[ Idx ].RadioCheckItem;
+end;
+
+function TMenu.GetItemBitmap(Idx: Integer): HBitmap;
+begin
+ Result := Items[ Idx ].Bitmap;
+end;
+
+procedure TMenu.SetItemBitmap(Idx: Integer; const Value: HBitmap);
+begin
+ Items[ Idx ].Bitmap := Value;
+end;
+
+procedure TMenu.AssignBitmaps(StartIdx: Integer; Bitmaps: array of HBitmap);
+var I: Integer;
+begin
+ for I := 0 to High(Bitmaps) do
+ ItemBitmap[ I + StartIdx ] := Bitmaps[ I ];
+end;
+
+function TMenu.GetItemText(Idx: Integer): KOLString;
+begin
+ Result := Items[ Idx ].FCaption;
+end;
+
+procedure TMenu.SetItemText(Idx: Integer; const Value: KOLString);
+begin
+ Items[ Idx ].Caption := Value;
+end;
+
+function TMenu.GetItemEnabled(Idx: Integer): Boolean;
+begin
+ Result := Items[ Idx ].Enabled;
+end;
+
+procedure TMenu.SetItemEnabled(Idx: Integer; const Value: Boolean);
+begin
+ Items[ Idx ].Enabled := Value;
+end;
+
+function TMenu.GetItemVisible(Idx: Integer): Boolean;
+begin
+ Result := Items[ Idx ].Visible;
+end;
+
+procedure TMenu.SetItemVisible(Idx: Integer; const Value: Boolean);
+begin
+ Items[ Idx ].Visible := Value;
+end;
+
+function TMenu.ParentItem( Idx: Integer ): Integer;
+begin
+ Result := TopParent.IndexOf( Items[ Idx ].FParentMenu );
+end;
+
+function TMenu.GetItemAccelerator(Idx: Integer): TMenuAccelerator;
+begin
+ Result := Items[ Idx ].Accelerator;
+end;
+
+procedure TMenu.SetItemAccelerator(Idx: Integer; const Value: TMenuAccelerator);
+begin
+ Items[ Idx ].Accelerator := Value;
+end;
+
+function TMenu.GetItemSubMenu( Idx: Integer ): HMenu;
+begin
+ Result := Items[ Idx ].SubMenu;
+end;
+
+function WndProcHelp( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+forward;
+
+{$IFDEF GDI}
+procedure TMenu.SetHelpContext( Value: Integer );
+var Form, C: PControl;
+begin
+ if TopParent <> @ Self then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ // Help context can not be associated with individual menu items
+ FHelpContext := Value;
+ C := FControl;
+ if C = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Form := C.ParentForm;
+ Form.AttachProc( WndProcHelp );
+ SetMenuContextHelpID( FHandle, Value );
+end;
+{$ENDIF GDI}
+
+procedure TMenu.SetSubmenu( Value: HMenu );
+var MII: TMenuItemInfo;
+begin
+ MII.fMask := MIIM_SUBMENU;
+ MII.hSubMenu := Value;
+ SetInfo( MII );
+ FHandle := Value;
+end;
+
+function WndProcMeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var MIS: PMeasureItemStruct;
+ M, SM: PMenu;
+ H, I: Integer;
+begin
+ Result := FALSE;
+ if (Msg.message = WM_MEASUREITEM) and (Msg.wParam = 0) then
+ begin
+ MIS := Pointer( Msg.lParam );
+ if MIS.CtlType = ODT_MENU then
+ begin
+ M := Pointer( Sender.fMenuObj );
+ while M <> nil do
+ begin
+ SM := M.Items[ MIS.itemID ];
+ if SM <> nil then
+ begin
+ Sender.CallDefWndProc( Msg );
+ I := M.IndexOf( SM );
+ if Assigned( SM.OnMeasureItem ) then
+ M := SM;
+ if not Assigned( M.OnMeasureItem ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ H := M.OnMeasureItem( M, I );
+ if HiWord( H ) <> 0 then
+ MIS.itemWidth := HiWord( H );
+ if LoWord( H ) <> 0 then
+ MIS.itemHeight := LoWord( H );
+ Rslt := 1;
+ Result := TRUE;
+ break;
+ end;
+ M := M.fNextMenu;
+ end;
+ end;
+ end;
+end;
+
+procedure TMenu.SetOnMeasureItem( const Value: TOnMeasureItem );
+var C: PControl;
+begin
+ FOnMeasureItem := Value;
+ C := TopParent.FControl;
+ if C <> nil then
+ C.AttachProc( WndProcMeasureItem );
+end;
+
+function WndProcDrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+type PDrawAction = ^TDrawAction;
+ PDrawState = ^TDrawState;
+var DIS: PDrawItemStruct;
+ M, SM: PMenu;
+ I: Integer;
+begin
+ Result := FALSE;
+ if (Msg.message = WM_DRAWITEM) and (Msg.wParam = 0) then
+ begin
+ DIS := Pointer( Msg.lParam );
+ if DIS.CtlType = ODT_MENU then
+ begin
+ M := Pointer( Sender.fMenuObj );
+ while M <> nil do
+ begin
+ SM := M.Items[ DIS.itemID ];
+ if SM <> nil then
+ begin
+ I := M.IndexOf( SM );
+ if Assigned( SM.OnDrawItem ) then
+ M := SM;
+ if Assigned( M.OnDrawItem ) then
+ begin
+ if not M.OnDrawItem( M, DIS.hDC, DIS.rcItem, I,
+ PDrawAction( @ DIS.itemAction )^,
+ PDrawState( @ DIS.itemState )^ ) then Exit; {>>>>>>>>}
+ end else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Rslt := 1;
+ Result := TRUE;
+ break;
+ end;
+ M := M.fNextMenu;
+ end;
+ end;
+ end;
+end;
+
+procedure TMenu.SetOnDrawItem( const Value: TOnDrawItem );
+var C: PControl;
+begin
+ FOnDrawItem := Value;
+ C := TopParent.FControl;
+ if C <> nil then
+ C.AttachProc( WndProcDrawItem );
+end;
+
+procedure TMenu.SetOwnerDraw( Value: Boolean );
+const Masks: array[ Boolean ] of DWORD = ( 0, $FFFFFFFF );
+var MII: TMenuItemInfo;
+begin
+ FOwnerDraw := Value;
+ //FillChar( MII, Sizeof( MII ), #0 );
+ ZeroMemory( @MII, Sizeof( MII ) );
+ MII.fMask := MIIM_TYPE;
+ MII.dwTypeData := nil;
+ if GetInfo( MII ) then
+ begin
+ MII.fType := MII.fType and not MFT_OWNERDRAW or
+ (MFT_OWNERDRAW and Masks[ Value ]);
+ SetTypeInfo( MII );
+ end;
+end;
+
+function TMenu.Insert(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem;
+ Options: TMenuOptions): PMenu;
+const
+ MenuStateFlags: array[TMenuOption] of Integer = (MFS_DEFAULT, MFS_DISABLED, MFS_CHECKED, 0, 0,
+ MFS_DISABLED, 0, 0, 0, 0);
+ MenuTypeFlags: array[TMenuOption] of Integer = (0, 0, 0, 0, MFT_RADIOCHECK, MFT_SEPARATOR, MFT_BITMAP, 0,
+ MFT_MENUBREAK, MFT_MENUBARBREAK);
+var M: PMenu;
+ MII: TMenuItemInfo;
+begin
+ new( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TMenuItem';
+ {$ENDIF}
+ Result.FVisible := TRUE;
+ Result.FParentMenu := @ Self;
+ Result.FMenuItems := NewList;
+ Result.FIsSeparator := moSeparator in Options;
+ Result.FIsCheckItem := moCheckMark in Options; //+ by shilou, 12/2009
+ if FHandle = 0 then
+ SetSubMenu( CreatePopupMenu );
+ M := nil;
+ if (InsertBefore >= 0) and (InsertBefore < 4096) then
+ begin
+ M := Items[ InsertBefore ];
+ if M <> nil then
+ begin
+ InsertBefore := M.FId;
+ M.Parent.FMenuItems.Insert( M.Parent.FMenuItems.IndexOf( M ), Result );
+ end;
+ end;
+ if M = nil then
+ begin
+ InsertBefore := -1;
+ FMenuItems.Add( Result );
+ end;
+ Result.FOnMenuItem := Event;
+
+ //FillChar( MII, Sizeof( MII ), #0 );
+ ZeroMemory( @MII, Sizeof( MII ) );
+ MII.cbSize := MenuStructSize;
+ MII.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;
+
+ MII.fState := MakeFlags( Pointer( @Options ), MenuStateFlags);
+ MII.fType := MakeFlags( Pointer( @Options ), MenuTypeFlags);
+ Result.FId := FDynamicMenuID;
+ Inc( FDynamicMenuID );
+ MII.wID := Result.FId;
+ if moSubMenu in Options
+ then begin
+ Result.FHandle := CreatePopupMenu;
+ MII.hSubMenu := Result.FHandle;
+ end;
+ MII.dwTypeData := PKOLChar(ACaption);
+ {$IFNDEF UNICODE_CTRLS}
+ if not (moBitmap in Options) then MII.cch := StrLen( ACaption );
+ {$ELSE}
+ if not (moBitmap in Options) then MII.cch := WStrLen( ACaption );
+ {$ENDIF}
+ InsertMenuItem( FHandle, InsertBefore, InsertBefore = -1,
+ PMenuItemInfo( @ MII )^ );
+ if moBitmap in Options then
+ begin
+ Result.BitmapItem := DWORD( ACaption );
+ end
+ else
+ Result.FCaption := ACaption;
+ RedrawFormMenuBar;
+end;
+
+function TMenu.AddItem(ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer;
+begin
+ Result := InsertItem( -1, ACaption, Event, Options );
+end;
+
+function TMenu.InsertItem( InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem;
+ Options: TMenuOptions): Integer;
+begin
+ Result := InsertItemEx( InsertBefore, ACaption, Event, Options, FALSE );
+end;
+
+function TMenu.InsertItemEx(InsertBefore: Integer; ACaption: PKOLChar;
+ Event: TOnMenuItem; Options: TMenuOptions; ByPosition: Boolean): Integer;
+var M: PMenu;
+begin
+ M := Insert( InsertBefore, ACaption, Event, Options );
+ Result := M.FId;
+end;
+
+procedure TMenu.InsertSubMenu( SubMenuToInsert: PMenu; InsertBefore: Integer );
+var AFlags: DWORD;
+ M: PMenu;
+ MII: TMenuItemInfo;
+begin
+ if SubMenuToInsert.FParentMenu <> nil then
+ SubMenuToInsert := SubMenuToInsert.FParentMenu.RemoveSubMenu( SubMenuToInsert.FId );
+ if SubMenuToInsert = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+
+ AFlags := MF_BYPOSITION;
+ M := nil;
+ if (InsertBefore >= 0) and (InsertBefore < 4096) then
+ begin
+ M := Items[ InsertBefore ];
+ if M = nil then
+ InsertBefore := -1
+ else
+ InsertBefore := M.FId;
+ end;
+ if M = nil then
+ begin
+ FMenuItems.Add( SubMenuToInsert );
+ SubMenuToInsert.FParentMenu := @ Self;
+ end
+ else
+ begin
+ M.FParentMenu.FMenuItems.Insert( M.FParentMenu.FMenuItems.IndexOf( M ), SubMenuToInsert );
+ SubMenuToInsert.FParentMenu := M.FParentMenu;
+ end;
+
+ if InsertBefore > 0 then
+ AFlags := MF_BYCOMMAND;
+ if SubMenuToInsert.FBmpItem <> 0 then
+ InsertMenu( FHandle, InsertBefore, AFlags or MF_BITMAP or MF_POPUP,
+ SubMenuToInsert.FHandle, PKOLChar( SubMenuToInsert.FBmpItem ) )
+ else
+ InsertMenu( FHandle, InsertBefore, AFlags or MF_STRING or MF_POPUP,
+ SubMenuToInsert.FHandle, PKOLChar( SubMenuToInsert.Caption ) );
+ if SubMenuToInsert.FId = 0 then
+ begin
+ SubMenuToInsert.FId := FDynamicMenuID;
+ Inc( FDynamicMenuID );
+ MII.cbSize := MenuStructSize;
+ MII.fMask := MIIM_ID;
+ MII.wID := SubMenuToInsert.FId;
+ {$IFNDEF UNICODE_CTRLS}
+ SetMenuItemInfo( SubMenuToInsert.FParentMenu.FHandle,
+ SubMenuToInsert.FParentMenu.FMenuItems.IndexOf( SubMenuToInsert ),
+ TRUE, Windows.PMenuItemInfo( @ MII )^ );
+ {$ELSE}
+ SetMenuItemInfoW( SubMenuToInsert.FParentMenu.FHandle,
+ SubMenuToInsert.FParentMenu.FMenuItems.IndexOf( SubMenuToInsert ),
+ TRUE, Windows.PMenuItemInfoW( @ MII )^ );
+ {$ENDIF}
+ end;
+ RedrawFormMenuBar;
+end;
+
+function TMenu.RemoveSubMenu( ItemToRemove: Integer ): PMenu;
+{$IFDEF DEBUG_MENU}var OK: Boolean; {$ENDIF}
+var M: PMenu;
+begin
+ Result := Items[ ItemToRemove ];
+ if Result = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ M := Result.FParentMenu;
+ if M = nil then M := @Self;
+ {$IFDEF DEBUG_MENU} OK := {$ENDIF}
+ RemoveMenu( M.FHandle, Result.FId, MF_BYCOMMAND );
+ M.FMenuItems.Remove( Result );
+ {$IFDEF DEBUG_MENU}
+ if not OK then
+ ShowMessage( 'Error removing menu: ' + Int2Str( GetLastError ) + ' - ' +
+ SysErrorMessage( GetLastError ) );
+ {$ENDIF}
+ if Count = 0 then
+ begin
+ Result.Free;
+ Result := nil;
+ end;
+ RedrawFormMenuBar;
+end;
+
+function TMenu.GetItemHelpContext(Idx: Integer): Integer;
+begin
+ Result := Items[ Idx ].HelpContext;
+end;
+
+procedure TMenu.SetItemHelpContext(Idx: Integer; const Value: Integer);
+begin
+ Items[ Idx ].HelpContext := Value;
+end;
+
+procedure ClearText( Sender: PControl );
+begin
+ Sender.Caption := '';
+end;
+
+procedure ClearListbox( Sender: PControl );
+begin
+ Sender.Perform( LB_RESETCONTENT, 0, 0 );
+end;
+
+procedure ClearCombobox( Sender: PControl );
+begin
+ Sender.Perform( CB_RESETCONTENT, 0, 0 );
+end;
+
+procedure ClearListView( Sender: PControl );
+begin
+ Sender.Perform( LVM_DELETEALLITEMS, 0, 0 );
+end;
+
+procedure ClearToolbar( Sender: PControl );
+begin
+ while Sender.TBButtonCount > 0 do
+ Sender.TBDeleteButton( Sender.TBIndex2Item( 0 ) );
+ Sender.Perform( TB_SETBITMAPSIZE, 0, 0 );
+end;
+
+{$ENDIF WIN_GDI}
+{ -- Constructor of canvas -- }
+function NewCanvas( DC: HDC ): PCanvas;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TCanvas';
+ {$ENDIF}
+ {$IFDEF GDI}
+ Result.ModeCopy := cmSrcCopy;
+ if DC <> 0 then
+ begin
+ Result.SetHandle( DC );
+ {//} Result.fIsAlienDC := True;
+ // When the Canvas will be destroyed, the DC will not be deleted
+ end;
+ {$ENDIF GDI}
+end;
+
+{ -- Contructors of controls -- }
+
+{$IFDEF GDI}
+{$IFDEF COMMANDACTIONS_OBJ}
+function NewCommandActionsObj: PCommandActionsObj;
+begin
+ new( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TCommandActionsObj';
+ {$ENDIF}
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+function NewCommandActionsObj_Packed( fromPack: PAnsiChar ): PCommandActionsObj;
+var Dest: PWord;
+ N, i: Integer;
+begin
+ new( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TCommandActionsObj';
+ {$ENDIF}
+ if Integer( fromPack ) < 120 then
+ begin
+ Result.fIndexInActions := Integer( fromPack ); Exit; {>>>>>>>>>>>>>>>>>}
+ end;
+ Result.fIndexInActions := Byte( fromPack^ );
+ inc( fromPack );
+ Dest := Pointer( @Result.aClick );
+ N := 38;
+ while N > 0 do
+ begin
+ if Byte( fromPack^ ) < 200 then
+ begin
+ Dest^ := PWord( fromPack )^;
+ inc( Dest );
+ inc( fromPack, 2 );
+ dec( N );
+ end
+ else
+ if Byte( fromPack^ ) = 200 then
+ begin
+ inc( fromPack );
+ Dest^ := PWord( fromPack )^;
+ inc( Dest );
+ inc( fromPack, 2 );
+ dec( N );
+ end
+ else
+ begin
+ i := Byte( fromPack^ ) - 200;
+ while i > 0 do
+ begin
+ Dest^ := 0;
+ inc( Dest );
+ dec( i );
+ dec( N );
+ end;
+ inc( fromPack );
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF COMMANDACTIONS_OBJ}
+
+function DumpWindowed( c: PControl ): PControl;
+var P: PByte;
+ i, j: Integer;
+ s, ss: KOLString;
+begin
+ P := Pointer( c );
+ ss := '';
+ i := 0;
+ while i < Sizeof( TControl ) do
+ begin
+ s := Int2Hex( i, 3 ) + ':';
+ for j := 0 to 15 do
+ begin
+ s := s + ' ' + Int2Hex( P^, 2 );
+ inc( P );
+ inc( i );
+ if i >= Sizeof( TControl ) then break;
+ end;
+ ss := ss + s + #13#10;
+ end;
+ LogFileOutput( GetStartDir + 'DumpWindowed.txt', Int2Hex( Integer( c ), 8 ) +
+ #13#10 + ss );
+ Result := c;
+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 Integer( ACommandActions ) < 120 then
+ IdxActions := Integer( ACommandActions )
+ else
+ IdxActions := PByte( ACommandActions )^;
+ if AllActions_Objs[IdxActions] <> nil then
+ begin
+ Result.fCommandActions := AllActions_Objs[IdxActions];
+ Result.fCommandActions.RefInc;
+ end
+ else
+ begin
+ {$IFDEF PACK_COMMANDACTIONS}
+ Result.fCommandActions := NewCommandActionsObj_Packed( ACommandActions );
+ AllActions_Objs[IdxActions] := Result.fCommandActions;
+ Result.fCommandActions.aClear := ClearText;
+ {$ELSE}
+ new( Result.fCommandActions, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fCommandActions.fObjKind := 'TCommandActionsObj';
+ {$ENDIF}
+ AllActions_Objs[IdxActions] := Result.fCommandActions;
+ if ACommandActions <> nil then
+ Move( ACommandActions^, Result.fCommandActions.aClear,
+ Sizeof( TCommandActions ) )
+ else
+ Result.fCommandActions.aClear := ClearText;
+ {$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
+ {$IFDEF WIN_GDI}
+ //{-2.95}Result.PP.fWndProcResizeFlicks := AParent.PP.fWndProcResizeFlicks;
+ {$ENDIF WIN_GDI}
+ 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}; //
+ Result.fMargin := AParent.fMargin;
+ Result.fTextColor := AParent.fTextColor;
+ {$IFDEF SMALLEST_CODE}
+ {$ELSE}
+ {$IFDEF WIN_GDI} // for now Font is complicated a bit, implement it later
+ Result.fFont := Result.fFont.Assign( AParent.fFont );
+ if Result.fFont <> nil then
+ begin
+ {$IFDEF USE_AUTOFREE4CONTROLS}
+ Result.Add2AutoFree( Result.fFont );
+ {$ENDIF USE_AUTOFREE4CONTROLS}
+ Result.fFont.fParentGDITool := AParent.fFont;
+ Result.fFont.fOnGTChange := Result.FontChanged;
+ Result.FontChanged( Result.fFont );
+ end;
+ {$ENDIF WIN_GDI}
+ {$ENDIF SMALLEST_CODE}
+ Result.fColor := AParent.fColor;
+ {$IFDEF WIN_GDI}
+ Result.fBrush := Result.fBrush.Assign( AParent.fBrush );
+ if Result.fBrush <> nil then
+ begin
+ {$IFDEF USE_AUTOFREE4CONTROLS}
+ Result.Add2AutoFree( Result.fBrush );
+ {$ENDIF USE_AUTOFREE4CONTROLS}
+ Result.fBrush.fParentGDITool := AParent.fBrush;
+ Result.fBrush.fOnGTChange := Result.BrushChanged;
+ Result.BrushChanged( Result.fBrush );
+ end;
+ {$ENDIF WIN_GDI}
+ end;
+ {$IFDEF DUMP_WINDOWED}
+ DumpWindowed( Result );
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+VAR GTK_initialized: Boolean;
+ argc: Integer = 0;
+
+PROCEDURE FixedChildSetPos( Ctl, Chld: PControl; x, y: Integer );
+BEGIN
+ gtk_fixed_move( GTK_FIXED( Ctl.fClient ), Chld.fEventboxHandle, x, y );
+END;
+
+PROCEDURE LayoutChildSetPos( Ctl, Chld: PControl; x, y: Integer );
+BEGIN
+ gtk_layout_move( GTK_LAYOUT( Ctl.fClient ), Chld.fEventboxHandle, x, y );
+END;
+
+PROCEDURE FixedChildPut( Ctl, Chld: PControl; x, y: Integer );
+BEGIN
+ gtk_fixed_put( GTK_FIXED( Ctl.fClient ), Chld.fEventboxHandle, x, y );
+END;
+
+PROCEDURE LayoutChildPut( Ctl, Chld: PControl; x, y: Integer );
+BEGIN
+ gtk_layout_put( GTK_LAYOUT( Ctl.fClient ), Chld.fEventboxHandle, x, y );
+END;
+
+FUNCTION FixedClientArea( Ctl: PControl ): PGtkWidget;
+BEGIN
+ IF Ctl.fClient = nil THEN
+ BEGIN
+ Ctl.fClient := gtk_fixed_new;
+ gtk_container_set_border_width(GTK_CONTAINER(Ctl.fHandle), 0);
+ gtk_container_add( GTK_CONTAINER( Ctl.fHandle ), Ctl.fClient );
+ gtk_container_set_border_width(GTK_CONTAINER(Ctl.fClient), 0);
+ gtk_widget_show( Ctl.fClient );
+ Ctl.fChildPut := FixedChildPut;
+ Ctl.fChildSetPos := FixedChildSetPos;
+ END;
+ Result := Ctl.fClient;
+END;
+
+FUNCTION ClientAreaLayout( Ctl: PControl ): PGtkWidget;
+BEGIN
+ IF Ctl.fClient = nil THEN
+ BEGIN
+ Ctl.fClient := gtk_layout_new( {hadjustment} nil, {vadjustment} nil );
+ Ctl.fChildPut := LayoutChildPut;
+ Ctl.fChildSetPos := LayoutChildSetPos;
+ END;
+ Result := Ctl.fClient;
+END;
+
+FUNCTION _NewWindowed( AParent: PControl; ControlClassName: PAnsiChar;
+ widget: PGtkWidget; need_eventbox: Boolean ): PControl;
+//var GVal: TGValue;
+BEGIN
+ (*if not GTK_initialized then
+ begin
+ GTK_initialized := TRUE;
+ gtk_init( @ argc, {@ argv} nil );
+ end;*)
+ New( Result, CreateParented( AParent, widget, need_eventbox ) );
+ //Result.fWindowed := TRUE; // is set in TControl.Init
+ //???//Result.fControlClassName := ControlClassName;
+ IF AParent <> nil THEN
+ BEGIN
+ Result.fGotoControl := AParent.fGotoControl;
+ Result.fMargin := AParent.fMargin;
+ Result.fTextColor := AParent.fTextColor;
+ {$IFDEF SMALLEST_CODE}
+ {$ELSE}
+ {$IFDEF WIN_GDI} // for now Font is complicated a bit, implement it later
+ Result.fFont := Result.fFont.Assign( AParent.fFont );
+ IF Result.fFont <> nil THEN
+ begin
+ {$IFDEF USE_AUTOFREE4CONTROLS}
+ Result.Add2AutoFree( Result.fFont );
+ {$ENDIF USE_AUTOFREE4CONTROLS}
+ Result.fFont.fParentGDITool := AParent.fFont;
+ Result.fFont.fOnGTChange := Result.FontChanged;
+ Result.FontChanged( Result.fFont );
+ END;
+ {$ENDIF WIN_GDI}
+ {$ENDIF SMALLEST_CODE}
+ Result.fColor := AParent.fColor;
+ {$IFDEF WIN_GDI}
+ Result.fBrush := Result.fBrush.Assign( AParent.fBrush );
+ IF Result.fBrush <> nil THEN
+ BEGIN
+ {$IFDEF USE_AUTOFREE4CONTROLS}
+ Result.Add2AutoFree( Result.fBrush );
+ {$ENDIF USE_AUTOFREE4CONTROLS}
+ Result.fBrush.fParentGDITool := AParent.fBrush;
+ Result.fBrush.fOnGTChange := Result.BrushChanged;
+ Result.BrushChanged( Result.fBrush );
+ END;
+ {$ENDIF WIN_GDI}
+ END;
+ Result.fGetClientArea := FixedClientArea;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+//===================== Form ========================//
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewForm( AParent: PControl; const Caption: AnsiString ): PControl;
+begin
+ new( Result, CreateForm( AParent, Caption ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Form';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewForm( AParent: PControl; const Caption: KOLString ): PControl;
+begin
+ Result := _NewWindowed( AParent, 'Form', True,
+ {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS )
+ {$ELSE} nil {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Form';
+ {$ENDIF}
+ Result.fClsStyle := Result.fClsStyle or CS_DBLCLKS;
+ Result.AttachProc( WndProcForm );
+ Result.AttachProc( WndProcDoEraseBkgnd );
+ Result.Caption := Caption;
+ {$IFDEF USE_FLAGS} Result.fFlagsG3 := Result.fFlagsG3 + [G3_SizeGrip, G3_IsForm];
+ {$ELSE}
+ {$IFNDEF SMALLEST_CODE}
+ Result.fSizeGrip := TRUE;
+ {$ENDIF}
+ Result.fIsForm := TRUE;
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+const Edgestyles: array[ TEdgeStyle ] of DWORD = ( WS_DLGFRAME, SS_SUNKEN, 0, 0, 0);
+
+function NewAlienPanel( AParentWnd: HWnd; EdgeStyle: TEdgeStyle ): PControl;
+begin
+ Result := _NewWindowed( nil, 'KOL', TRUE,
+ {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS )
+ {$ELSE} nil {$ENDIF} );
+ Result.fClsStyle := Result.fClsStyle or CS_DBLCLKS;
+ Result.FParentWnd := AParentWnd;
+ Result.AttachProc( WndProcForm );
+ Result.AttachProc( WndProcDoEraseBkgnd );
+ {$IFDEF USE_FLAGS} Result.fFlagsG3 := Result.fFlagsG3 + [G3_IsForm, G3_IsControl];
+ {$ELSE} Result.fIsForm := TRUE;
+ Result.fIsControl := TRUE;
+ {$ENDIF}
+ Result.fStyle.Value := WS_VISIBLE or WS_CHILD or WS_TABSTOP or
+ WS_CLIPSIBLINGS or WS_CLIPCHILDREN or Edgestyles[ EdgeStyle ];
+ Result.fExStyle := Result.fExStyle //or WS_EX_CLIENTEDGE
+ or WS_EX_CONTROLPARENT;
+ Result.SetSize( 100, 64 );
+end;
+
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION getFormCaption(F: PControl): KOLString;
+BEGIN
+ F.fCaption := gtk_window_get_title( GTK_WINDOW( F.fHandle ) );
+ Result := F.fCaption;
+END;
+
+PROCEDURE setFormCaption(F: PControl; const Value: KOLString);
+BEGIN
+ F.fCaption := Value;
+ gtk_window_set_title( GTK_WINDOW( F.fCaptionHandle ), PAnsiChar( String( Value ) ) );
+END;
+
+PROCEDURE DestroyForm( Widget: PGtkWidget; Sender: PControl ); CDECL;
+VAR Quit: Boolean;
+BEGIN
+ Quit := Sender.IsMainWindow;
+ Sender.Free;
+ IF Quit THEN
+ gtk_main_quit();
+END;
+
+FUNCTION NewForm( AParent: PControl; const Caption: KOLString ): PControl;
+VAR widget: PGtkWidget;
+BEGIN
+ IF not GTK_initialized THEN
+ BEGIN
+ GTK_initialized := TRUE;
+ gtk_init( @ argc, {@ argv} nil );
+ END;
+ widget := gtk_window_new( GTK_WINDOW_TOPLEVEL );
+ Result := _NewWindowed( AParent, 'Form', widget, FALSE );
+ Result.fGetCaption := getFormCaption;
+ Result.fSetCaption := setFormCaption;
+ Result.Caption := Caption;
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG3, G3_IsForm );
+ {$ELSE} Result.fIsForm := TRUE; {$ENDIF}
+ gtk_signal_connect( Pointer( Result.fHandle ), 'destroy',
+ @ DestroyForm, Result );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+//===================== Applet button ========================//
+
+//22{$IFDEF ASM_VERSION}
+{$IFNDEF PAS_ONLY}
+ function WndProcAppAsm(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+ asm
+ CMP word ptr [EDX].TMsg.message, WM_SETFOCUS
+ JNZ @@chk_CLOSE
+ MOV ECX, [EAX].TControl.DF.FCurrentControl
+ JECXZ @@ret_false
+ XCHG EAX, ECX
+ PUSH EAX
+ CALL CallTControlCreateWindow
+ TEST AL, AL
+ POP EAX
+ JZ @@1
+ PUSH [EAX].TControl.fHandle
+ CALL SetFocus
+ @@1: MOV AL, 1
+ RET
+ @@chk_CLOSE:
+ CMP word ptr [EDX].TMsg.message, WM_SYSCOMMAND
+ JNZ @@ret_false
+ MOV EDX, dword ptr [EDX].TMsg.wParam
+ AND DX, $FFF0
+ CMP DX, SC_CLOSE
+ JNZ @@ret_false
+ PUSH ECX
+ MOV ECX, [EAX].TControl.fChildren
+ JECXZ @@ret_false1
+ XCHG EAX, ECX
+ MOV ECX, [EAX].TList.fCount
+ JECXZ @@ret_false1
+ MOV EAX, [EAX].TList.fItems
+ MOV ECX, dword ptr [EAX]
+ JECXZ @@ret_false1
+ XCHG EAX, ECX
+ PUSH EAX
+ CALL TControl.IsMainWindow
+ TEST EAX, EAX
+ POP EAX
+ JZ @@ret_false1
+ CALL TControl.Close
+ POP ECX
+ XOR EAX, EAX
+ MOV dword ptr [ECX], EAX
+ INC EAX
+ JMP @@exit
+ @@ret_false1:
+ POP ECX
+ @@ret_false:
+ XOR EAX, EAX
+ @@exit:
+ end;
+{$ENDIF not PAS_ONLY}
+//22{$ENDIF}
+
+function WndProcAppPas(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+begin
+ Result := False;
+ case Msg.message of
+ WM_SETFOCUS:
+ {$IFDEF NEW_MODAL}
+ if Self_.DF.fModalForm <> nil then
+ SetFocus( Self_.DF.fModalForm.fHandle )
+ else if ( Self_.DF.FCurrentControl <> nil ) and not
+ ( {$IFDEF USE_FLAGS} (G3_IsForm in Self_.DF.fCurrentControl.fFlagsG3)
+ {$ELSE} Self_.DF.fCurrentControl.fIsForm {$ENDIF}
+ xor
+ {$IFDEF USE_FLAGS} (G3_IsApplet in Self_.fFlagsG3)
+ {$ELSE} Self_.fIsApplet {$ENDIF} ) then
+ {$ELSE not_NEW_MODAL}
+ if Self_.DF.fCurrentControl <> nil then
+ {$ENDIF NEW_MODAL}
+ begin
+ if Self_.DF.FCurrentControl.CreateWindow then
+ SetFocus( Self_.DF.FCurrentControl.fHandle );
+ Result := True;
+ end;
+ WM_SYSCOMMAND:
+ CASE Msg.wParam and $FFF0 OF
+ SC_CLOSE:
+ if (Self_.fChildren <> nil) and (Self_.fChildren.fCount > 0) and
+ PControl( Self_.fChildren.fItems[ 0 ] ).IsMainWindow then
+ begin
+ PControl( Self_.fChildren.fItems[ 0 ] ).Close;
+ Rslt := 0;
+ Result := TRUE;
+ end;
+ END;
+ end;
+end;
+
+{$IFDEF USE_CONSTRUCTORS}
+{$DEFINE CREATEAPPBUTTON_USED}
+function NewApplet( const Caption: AnsiString ): PControl;
+begin
+ new( Result, CreateApplet( Caption ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Applet';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_TLIST}
+function NewApplet( const Caption: KOLString ): PControl;
+const AppClass: array[ 0..3 ] of KOLChar = ( 'A', 'p', 'p', #0 );
+asm
+ XOR ECX, ECX
+ INC ECX
+ MOV [AppButtonUsed], CL
+ PUSH EAX
+ MOV EDX, offset[AppClass]
+ XOR EAX, EAX
+ PUSH EAX
+ CALL _NewWindowed
+ {$IFDEF USE_FLAGS}
+ OR [EAX].TControl.fFlagsG3, (1 shl G3_IsApplet)
+ {$ELSE}
+ INC [EAX].TControl.FIsApplet
+ {$ENDIF}
+ MOV word ptr [EAX].TControl.fStyle + 2, $90CA //WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX or WS_CAPTION
+ MOV byte ptr [EAX].TControl.fExStyle + 2, WS_EX_APPWINDOW shr 16 // WS_EX_APPWINDOW = $40000
+ CALL @@newapp1
+
+ PUSH ESI // BODY of CreateAppButton here
+ PUSH 0
+ PUSH [EAX].TControl.fHandle
+ CALL GetSystemMenu
+ MOV ESI, offset[DeleteMenu]
+
+ XCHG ECX, EAX
+ MOV EAX, SC_MAXIMIZE
+ CDQ
+
+ PUSH EDX
+ PUSH EAX
+ PUSH ECX
+
+ PUSH EDX
+ {$IFDEF PARANOIA} DB $2C, $20 {$ELSE} SUB AL, $20 {$ENDIF} // SC_MOVE
+ PUSH EAX
+ PUSH ECX
+
+ PUSH EDX
+ {$IFDEF PARANOIA} DB $2C, $10 {$ELSE} SUB AL, $10 {$ENDIF} // SC_SIZE
+ PUSH EAX
+ PUSH ECX
+
+ PUSH 1 // MF_GRAYED or MF_BYCOMMAND
+ MOV AX, SC_RESTORE
+ PUSH EAX
+ PUSH ECX
+
+ CALL EnableMenuItem
+ CALL ESI
+ CALL ESI
+ CALL ESI
+ POP ESI
+@@ret_false:
+ XOR EAX, EAX
+ RET
+
+@@chk_CLOSE:
+ CMP word ptr [EDX].TMsg.message, WM_SYSCOMMAND
+ JNZ @@ret_false
+ MOV EDX, dword ptr [EDX].TMsg.wParam
+ AND DX, $FFF0
+ CMP DX, SC_CLOSE
+ JNZ @@ret_false
+ PUSH ECX
+ MOV ECX, [EAX].TControl.fChildren
+ JECXZ @@ret_false1
+ XCHG EAX, ECX
+ MOV ECX, [EAX].TList.fCount
+ JECXZ @@ret_false1
+ MOV EAX, [EAX].TList.fItems
+ MOV ECX, dword ptr [EAX]
+ JECXZ @@ret_false1
+ XCHG EAX, ECX
+ PUSH EAX
+ CALL TControl.IsMainWindow
+ TEST EAX, EAX
+ POP EAX
+ JZ @@ret_false1
+ CALL TControl.Close
+ POP ECX
+ XOR EAX, EAX
+ MOV dword ptr [ECX], EAX
+ INC EAX
+ RET
+ @@ret_false1:
+ POP ECX
+ JMP @@ret_false
+
+@@newapp1:
+ POP [EAX].TControl.PP.FCreateWndExt
+ PUSH EAX
+ CALL @@newapp2
+
+ // BODY of WndProcApp here:
+ CMP word ptr [EDX].TMsg.message, WM_SETFOCUS
+ JNZ @@chk_CLOSE
+ MOV ECX, [EAX].TControl.DF.fCurrentControl
+ JECXZ @@ret_false
+ XCHG EAX, ECX
+
+ PUSH EAX
+ CALL CallTControlCreateWindow
+ POP EAX
+ PUSH [EAX].TControl.fHandle
+
+ CALL SetFocus
+ MOV AL, 1
+ RET
+
+@@newapp2:
+ POP EDX
+ CALL TControl.AttachProc
+ POP EAX
+ POP EDX
+ PUSH EAX
+ CALL TControl.SetCaption
+ POP EAX
+end;
+{$ELSE PAS_VERSION} //Pascal
+
+procedure CreateAppButton( App: PControl );
+var M: HMenu;
+begin
+ M := GetSystemMenu( App.fHandle, False );
+ DeleteMenu( M, SC_MAXIMIZE, MF_BYCOMMAND );
+ DeleteMenu( M, SC_MOVE, MF_BYCOMMAND );
+ DeleteMenu( M, SC_SIZE, MF_BYCOMMAND );
+ EnableMenuItem( M, SC_RESTORE, MF_GRAYED or MF_BYCOMMAND );
+end;
+
+function NewApplet( const Caption: KOLString ): PControl;
+begin
+ AppButtonUsed := True;
+ Result := _NewWindowed( nil, 'App', True,
+ {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS )
+ {$ELSE} nil {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Applet';
+ {$ENDIF}
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG3, G3_IsApplet );
+ {$ELSE} Result.FIsApplet := TRUE; {$ENDIF}
+ Result.fStyle.Value := WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX or WS_CAPTION;
+ Result.fExStyle := WS_EX_APPWINDOW;
+ Result.PP.FCreateWndExt := CreateAppButton;
+ {$IFDEF ASM_VERSION}
+ Result.AttachProc( WndProcAppAsm );
+ {$ELSE}
+ Result.AttachProc( WndProcAppPas );
+ {$ENDIF}
+ Result.Caption := Caption;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF USE_CONSTRUCTORS}
+
+{$IFDEF CREATEAPPBUTTON_USED}
+procedure CreateAppButton( App: PControl );
+asm
+ {$IFDEF F_P}
+ MOV EAX, [App]
+ {$ENDIF F_P}
+ PUSH ESI
+ PUSH 0
+ PUSH [EAX].TControl.fHandle
+ CALL GetSystemMenu
+ MOV ESI, offset[DeleteMenu]
+
+ XCHG ECX, EAX
+ MOV EAX, SC_MAXIMIZE
+ CDQ
+
+ PUSH EDX
+ PUSH EAX
+ PUSH ECX
+
+ PUSH EDX
+ {$IFDEF PARANOIA} DB $2C, $20 {$ELSE} SUB AL, $20 {$ENDIF} // SC_MOVE
+ PUSH EAX
+ PUSH ECX
+
+ PUSH EDX
+ {$IFDEF PARANOIA} DB $2C, $10 {$ELSE} SUB AL, $10 {$ENDIF} // SC_SIZE
+ PUSH EAX
+ PUSH ECX
+
+ PUSH 1 // MF_GRAYED or MF_BYCOMMAND
+ MOV AX, SC_RESTORE
+ PUSH EAX
+ PUSH ECX
+
+ CALL EnableMenuItem
+ CALL ESI
+ CALL ESI
+ CALL ESI
+ POP ESI
+end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
+{$ENDIF CREATEAPPBUTTON_USED}
+
+var CtlIdCount: WORD = $8000;
+
+{$ENDIF WIN_GDI}
+
+{$IFDEF GDI}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function _NewControl( AParent: PControl; ControlClassName: PKOLChar;
+ Style: DWORD; Ctl3D: Boolean; Actions: TCommandActionsParam ): PControl;
+var Form: PControl;
+begin
+ Result := _NewWindowed( AParent, ControlClassName, Ctl3D, Actions );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl';
+ {$ENDIF}
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG3, G3_IsControl );
+ {$ELSE} Result.fIsControl := True; {$ENDIF}
+ Result.fStyle.Value := Style or WS_CLIPSIBLINGS or WS_CLIPCHILDREN;
+ Result.fVerticalAlign := vaTop;
+ Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ];
+ if Result.fCtl3D_child and 1 <> 0 then
+ begin
+ Result.fStyle.Value := Result.fStyle.Value and not WS_BORDER;
+ Result.fExStyle := Result.fExStyle or WS_EX_CLIENTEDGE;
+ end;
+ {$IFDEF USE_FLAGS}
+ {$ELSE}
+ Result.fVisible := (Style and WS_VISIBLE) <> 0;
+ Result.fTabstop := (Style and WS_TABSTOP) <> 0;
+ {$ENDIF}
+ if (AParent <> nil) then
+ begin
+ with Result.fBoundsRect do
+ begin
+ Left := AParent.fMargin + AParent.fClientLeft;
+ Top := AParent.fMargin + AParent.fClientTop;
+ Right := Left + 64;
+ Bottom := Top + 64;
+ end;
+ Form := AParent.ParentForm;
+ if Form <> nil then
+ begin
+ Inc( Form.fTabOrder );
+ Result.fTabOrder := Form.fTabOrder;
+ if F2_Tabstop in Result.fStyle.f2_Style then
+ begin
+ if Form.DF.FCurrentControl = nil then
+ Form.DF.FCurrentControl := Result;
+ end;
+ end;
+ Result.fCursor := AParent.fCursor;
+ end;
+ Result.fMenu := CtlIdCount;
+ Inc( CtlIdCount );
+ Result.AttachProc( WndProcCtrl );
+ {$IFDEF DEBUG_ALTSPC}
+ DumpWindowed(Result);
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION getLabelCaption( L: PControl ): KOLString;
+BEGIN
+ L.fCaption := gtk_label_get_text( Pointer( L.fCaptionHandle ) );
+ Result := L.fCaption;
+END;
+
+PROCEDURE setLabelCaption( L: PControl; const Value: KOLString );
+BEGIN
+ L.fCaption := Value;
+ gtk_label_set_text( Pointer( L.fCaptionHandle ), PAnsiChar( String( Value ) ) );
+END;
+
+FUNCTION _NewControl( AParent: PControl; ControlClassName: PAnsiChar;
+ Style: DWORD; Ctl3D: Boolean; widget: PGtkWidget; need_eventbox: Boolean ): PControl;
+VAR Rect: TRect;
+BEGIN
+ Result := _NewWindowed( AParent, ControlClassName, widget, need_eventbox );
+ Result.fIsControl := True;
+ Result.fVerticalAlign := vaTop;
+ Result.fVisible := (Style and WS_VISIBLE) <> 0;
+ Result.fTabstop := (Style and WS_TABSTOP) <> 0;
+ IF (AParent <> nil) THEN
+ BEGIN
+ WITH Rect DO
+ BEGIN
+ Left := AParent.fMargin + AParent.fClientLeft;
+ Top := AParent.fMargin + AParent.fClientTop;
+ END;
+ Inc( AParent.ParentForm.fTabOrder );
+ Result.fTabOrder := AParent.ParentForm.fTabOrder;
+ {$IFDEF GDI}
+ Result.fCursor := AParent.fCursor;
+ {$ENDIF GDI}
+ //gtk_container_add( GTK_CONTAINER( AParent.fHandle ), Result.fHandle );
+ END;
+ {with Rect do
+ begin
+ Right := Left + 64;
+ Bottom := Top + 64;
+ end;
+ Result.fBoundsRect := Result.BoundsRect;
+ Result.BoundsRect := Rect;}
+ Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ];
+ {$IFDEF GDI}
+ IF Result.fCtl3D THEN
+ BEGIN
+ Result.fStyle := Result.fStyle and not WS_BORDER;
+ Result.fExStyle := Result.fExStyle or WS_EX_CLIENTEDGE;
+ END;
+ IF (Style and WS_TABSTOP) <> 0 THEN
+ BEGIN
+ Form := Result.ParentForm;
+ IF Form <> nil THEN
+ IF Form.FCurrentControl = nil THEN
+ Form.FCurrentControl := Result;
+ END;
+ Result.fMenu := CtlIdCount;
+ Inc( CtlIdCount );
+ Result.AttachProc( WndProcCtrl );
+ {$ENDIF GDI}
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+
+//===================== Button ========================//
+
+function TControl.SetButtonIcon(aIcon: HIcon): PControl;
+var PrevImg: THandle;
+begin
+ Style := Style or BS_ICON;
+ DF.fButtonIcon := aIcon;
+ PrevImg := Perform( BM_SETIMAGE, IMAGE_ICON, aIcon );
+ if PrevImg <> 0 then
+ DeleteObject( PrevImg );
+ Result := @ Self;
+end;
+
+function TControl.SetButtonBitmap(aBmp: HBitmap): PControl;
+var PrevImg: THandle;
+begin
+ Style := Style or BS_BITMAP;
+ PrevImg := Perform( BM_SETIMAGE, IMAGE_BITMAP, aBmp );
+ if PrevImg <> 0 then
+ DeleteObject( PrevImg );
+ Result := @ Self;
+end;
+
+{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
+function WndProcBtnReturnClick( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := FALSE;
+ if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or
+ (Msg.message = WM_CHAR)) and (Msg.wParam = 13) then
+ Msg.wParam := 32;
+end;
+{$ENDIF}
+
+{$IFNDEF BUTTON_DBLCLICK}
+function WndProcBtnDblClkAsClk( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := FALSE;
+ if Msg.message = WM_LBUTTONDBLCLK then
+ Msg.message := WM_LBUTTONDOWN;
+end;
+{$ENDIF}
+
+function AutoMinimizeApplet(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+begin
+ if (msg.Message=WM_SYSCOMMAND) and ((msg.wParam and not 15)=SC_MINIMIZE) then begin
+ AppletMinimize;
+ Result := True;
+ end else
+ Result := False;
+end;
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
+begin
+ new( Result, CreateButton( AParent, Caption ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Button';
+ {$ENDIF}
+end;
+{$ELSE USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
+begin
+ Result := _NewControl( AParent, 'BUTTON',
+ WS_VISIBLE or WS_CHILD or BS_NOTIFY or
+ BS_PUSHLIKE or WS_TABSTOP, False,
+ {$IFDEF PACK_COMMANDACTIONS} ButtonActions_Packed
+ {$ELSE} @ButtonActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Button';
+ {$ENDIF}
+ Result.aAutoSzX := 14;
+ Result.aAutoSzY := 6;
+ {$IFDEF BUTTON_DBLCLICK}
+ Result.ClsStyle := Result.ClsStyle - CS_DBLCLKS;
+ {$ENDIF}
+ //Result.fCtl3D := TRUE;
+ with Result.fBoundsRect do
+ Bottom := Top + 22;
+ Result.fTextAlign := taCenter;
+ Result.Caption := Caption;
+ {$IFDEF USE_FLAGS}
+ Result.fFlagsG5 := Result.fFlagsG5 + [G5_IsButton, G5_IgnoreDefault];
+ {$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}
+{$IFDEF GRAPHCTL_XPSTYLES}
+ Attach_WM_THEMECHANGED( Result, XP_Themes_For_BitBtn );
+{$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+{$ENDIF WIN_GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+CONST
+ HorAlignments: ARRAY[ TTextAlign ] of Single = ( {taLeft} 0, {taRight} 1, {taCenter} 0.5 );
+ VerAlignments: ARRAY[ TVerticalAlign ] of Single = ( {vaTop} 0, {vaCenter} 0.5, {vaBottom} 1 );
+
+PROCEDURE ButtonSetTextAlign( Self_: PControl );
+BEGIN
+ gtk_button_set_alignment( GTK_BUTTON( Self_.fHandle ), HorAlignments[ Self_.fTextAlign ],
+ VerAlignments[ Self_.fVerticalAlign ] );
+END;
+
+FUNCTION NewButton( AParent: PControl; const Caption: KOLString ): PControl;
+BEGIN
+ Result := _NewControl( AParent, 'BUTTON',
+ WS_VISIBLE or WS_CHILD or BS_NOTIFY or
+ BS_PUSHLIKE or WS_TABSTOP, False,
+ gtk_button_new{_with_label}( {PChar( String( Caption ) )} ), FALSE );
+ //Result.Height := 22;
+ gtk_container_set_border_width( GTK_CONTAINER( Result.fHandle ), 0 );
+ Result.fCaptionHandle := gtk_label_new( PAnsiChar( String( Caption ) ) );
+ gtk_container_add( GTK_CONTAINER( Result.fHandle ), Result.fCaptionHandle );
+ //gtk_container_set_border_width( GTK_CONTAINER( Result.fCaptionHandle ), 0 );
+ gtk_widget_show( Result.fCaptionHandle );
+ Result.fGetCaption := getLabelCaption;
+ Result.fSetCaption := setLabelCaption;
+ //Result.fIgnoreDefault := TRUE;
+ //Result.fCtl3D := TRUE;
+ //with Result.fBoundsRect do
+ // Bottom := Top + 22;
+ Result.fTextAlign := taCenter;
+ Result.fCaption := Caption;
+ Result.fIsButton := TRUE;
+ Result.fSetTextAlign := ButtonSetTextAlign;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+//----------------- BitBtn -----------------------
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function WndProc_DrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
+ : Boolean;
+var DI: PDrawItemStruct;
+ Control: PControl;
+begin
+ Result := FALSE;
+ if Msg.message = WM_DRAWITEM then
+ begin
+ DI := Pointer( Msg.lParam );
+ {$IFDEF USE_PROP}
+ Control := Pointer( GetProp( DI.hwndItem, ID_SELF ) );
+ {$ELSE}
+ Control := Pointer( GetWindowLong( DI.hwndItem, GWL_USERDATA ) );
+ {$ENDIF}
+ if Control <> nil then
+ begin
+ Rslt := Control.Perform( CN_DRAWITEM, Msg.wParam, Msg.lParam );
+ Result := TRUE;
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function ExcludeAmpersands( Self_: PControl; const S: KOLString ): KOLString;
+var I: Integer;
+begin
+ Result := S;
+ if not Self_.DF.fBitBtnDrawMnemonic then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ for I := Length( Result ) downto 1 do
+ begin
+ if Result[ I ] = '&' then
+ Delete( Result, I, 1 );
+ end;
+end;
+
+procedure BitBtnExtDraw( Self_: PControl; DC: HDC; X, Y: Integer; const R: TRect;
+ const CapText, CapTxtOrig: KOLString; Color: TColor );
+var I, J, W, H: Integer;
+ Sz: TSize;
+ Pen, OldPen: HPen;
+begin
+ if not Self_.DF.fBitBtnDrawMnemonic then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ J := 0;
+ for I := 1 to Length( CapTxtOrig ) do
+ begin
+ if CapTxtOrig[ I ] <> '&' then
+ Inc( J )
+ else
+ begin
+ GetTextExtentPoint32( DC, PKOLChar( CapText ), J, Sz );
+ W := Sz.cx;
+ Windows.GetTextExtentPoint32( DC, '_', 1, Sz ); // A/W KOL_ANSI
+ H := Sz.cy - 1;
+ Windows.GetTextExtentPoint32( DC, @ CapTxtOrig[ I + 1 ], 1, Sz );
+ Windows.MoveToEx( DC, X + W, Y + H, nil );
+
+ Pen := CreatePen( PS_SOLID, 0, Color2RGB( Color ) );
+ OldPen := SelectObject( DC, Pen );
+
+ Windows.LineTo( DC, X + W + Sz.cx, Y + H );
+
+ SelectObject( DC, OldPen );
+ DeleteObject( Pen );
+ end;
+ end;
+end;
+
+procedure TControl.SetBitBtnDrawMnemonic(const Value: Boolean);
+begin
+ DF.fBitBtnDrawMnemonic := Value;
+ DF.FBitBtnGetCaption := ExcludeAmpersands;
+ DF.FBitBtnExtDraw := BitBtnExtDraw;
+ Invalidate;
+end;
+
+function TControl.GetBitBtnImgIdx: Integer;
+begin
+ Result := LoWord( DF.fGlyphCount );
+end;
+
+procedure TControl.SetBitBtnImgIdx(const Value: Integer);
+begin
+ if not( bboImageList in DF.fBitBtnOptions ) then Exit; {>>>>>>>>>>>>>>>>>>>>>}
+ DF.fGlyphCount := HiWord( DF.fGlyphCount ) or (Value and $FFFF);
+ Invalidate;
+end;
+
+function TControl.GetBitBtnImageList: THandle;
+begin
+ Result := 0;
+ if bboImageList in DF.fBitBtnOptions then
+ Result := DF.fGlyphBitmap;
+end;
+
+procedure TControl.SetBitBtnImageList(const Value: THandle);
+begin
+ DF.fGlyphBitmap := Value;
+ if Value <> 0 then
+ begin
+ include( DF.fBitBtnOptions, bboImageList );
+ ImageList_GetIconSize( Value, DF.fGlyphWidth, DF.fGlyphHeight );
+ end else
+ exclude( DF.fBitBtnOptions, bboImageList );
+ 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: Integer ): Boolean;
+const szBitmapInfo = sizeof(TBitmapInfo);
+asm
+ CMP word ptr [EDX].TMsg.message, WM_LBUTTONDBLCLK
+ JNZ @@noWM_LBUTTONDBLCLK
+ PUSH ECX
+ PUSH [EDX].TMsg.wParam
+ PUSH [EDX].TMsg.lParam
+ PUSH WM_LBUTTONDOWN
+ PUSH EAX
+ CALL TControl.Perform
+ POP ECX
+ MOV [ECX], EAX
+ MOV AL, 1
+ RET
+@@noWM_LBUTTONDBLCLK:
+ PUSH EBX
+ CMP [EDX].TMsg.message, CN_DRAWITEM
+ JNZ @@noCN_DRAWITEM
+ PUSH EDI
+ PUSH ESI
+ XCHG EDI, EAX // EDI = @Self
+ MOV dword ptr [ECX], 1
+ MOV ESI, [EDX].TMsg.lParam // ESI = DIS
+ XOR EBX, EBX // G = 0
+ MOV EAX, [ESI].TDrawItemStruct.itemState
+ TEST byte ptr [EDI].TControl.fBitBtnOptions, 8 //1 shl Ord(bboFixed)
+ JNZ @@fixed_in_options
+ {$IFDEF PARANOIA} DB $A8, ODS_SELECTED {$ELSE} TEST AL, ODS_SELECTED {$ENDIF}
+ JZ @@not1
+ JMP @@1
+@@fixed_in_options:
+ {$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:
+ {$IFDEF PARANOIA} DB $A8, ODS_DISABLED {$ELSE} TEST AL, ODS_DISABLED {$ENDIF}
+ JZ @@not2
+ MOV BL, 2
+@@not2: TEST EBX, EBX
+ JNZ @@not3
+ {$IFDEF PARANOIA} DB $A8, ODS_FOCUS {$ELSE} TEST AL, ODS_FOCUS {$ENDIF}
+ JZ @@not3
+ MOV BL, 3
+@@not3: {$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 <nil>
+ 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
+ {$IFDEF PARANOIA} DB $A8, 4 {$ELSE} TEST AL, BST_PUSHED {$ENDIF}
+ JNZ @@pushed
+ PUSH 1
+ PUSH [EBX].TControl.fHandle
+ CALL KillTimer
+ CALL ReleaseCapture
+ JMP @@noWM_TIMER
+@@fixed_proc:
+ TEST byte ptr [EBX].TControl.fBitBtnOptions, 8 // bboFixed
+ JZ @@not_fixed
+ {$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: Integer ): Boolean;
+var DIS: PDrawItemStruct;
+ IsDown, IsDefault, IsDisabled: Boolean;
+ Flags: Integer;
+ X, Y, W, H, ImgW, ImgH, OutW, OutH, I, G, Bk, Blend: Integer;
+ TxRect, FocusRect: TRect;
+ OldFont: HFont;
+ OldTextColor: TColor;
+ CapText, CapTxtOrig: KOLString;
+ TextSz: TSize;
+ DC: HDC;
+ OldBmp: HBitmap;
+ Handled: Boolean;
+begin
+ Result := False;
+ if (Msg.message = WM_LBUTTONDBLCLK) then
+ begin
+ Rslt := Self_.Perform( WM_LBUTTONDOWN, Msg.wParam, Msg.lParam );
+ Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if (Msg.message = CN_DRAWITEM) then
+ begin
+ Result := True;
+ Rslt := 1;
+ DIS := Pointer( Msg.lParam );
+ IsDown := (DIS.itemState and ODS_SELECTED <> 0) or
+ {$IFDEF USE_FLAGS} (G4_Checked in Self_.fFlagsG4)
+ {$ELSE} Self_.fChecked {$ENDIF};
+ IsDefault := DIS.itemState and ODS_FOCUS <> 0;
+ IsDisabled := DIS.itemState and ODS_DISABLED <> 0;
+ G := 0;
+ if IsDown then G := {$IFDEF BITBTN_DISABLEDGLYPH2} 1 {$ELSE} 2 {$ENDIF};
+ if IsDisabled then G := {$IFDEF BITBTN_DISABLEDGLYPH2} 2 {$ELSE} 1 {$ENDIF};
+ if (G = 0) and IsDefault then G := 3;
+ if ((G = 0) or (G = 3)) and Self_.MouseInControl then G := 4;
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnBitBtnDraw ) then
+ {$ENDIF}
+ begin
+ if ( Self_.fCanvas <> nil ) then
+ Self_.fCanvas.SetHandle( DIS.hDC );
+ Handled := Self_.EV.fOnBitBtnDraw( Self_, G );
+ if ( Self_.fCanvas <> nil ) then
+ Self_.fCanvas.SetHandle( 0 );
+ if Handled then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if not ( bboNoBorder in Self_.DF.fBitBtnOptions ) then
+ begin
+ if IsDefault and not( bboFocusRect in Self_.DF.fBitBtnOptions ) then
+ begin
+ Windows.FrameRect( DIS.hDC, DIS.rcItem, GetStockObject( {BLACK_BRUSH} DKGRAY_BRUSH ) );
+ InflateRect( DIS.rcItem, -1, -1 );
+ end;
+ if {$IFDEF USE_FLAGS} G3_Flat in Self_.fFlagsG3
+ {$ELSE} Self_.fFlat {$ENDIF} then
+ begin
+ if IsDown then
+ Flags := BDR_RAISEDINNER
+ else
+ Flags := 0; //EDGE_ETCHED;
+ DrawEdge( DIS.hDC, DIS.rcItem, Flags, BF_FLAT or BF_RECT );
+ //InflateRect( DIS.rcItem, -1, -1 );
+ end;
+ if {$IFDEF USE_FLAGS} not(G3_Flat in Self_.fFlagsG3)
+ {$ELSE} not Self_.fFlat {$ENDIF}
+ or {$IFDEF USE_FLAGS} (G3_MouseInCtl in Self_.fFlagsG3)
+ {$ELSE} Self_.fMouseInControl {$ENDIF} or IsDefault then
+ begin
+ if IsDown then
+ Flags := BDR_SUNKENOUTER or BDR_SUNKENINNER
+ else
+ Flags := BDR_RAISEDOUTER or BDR_RAISEDINNER;
+ DrawEdge( DIS.hDC, DIS.rcItem, Flags, BF_ADJUST or BF_RECT );
+ InflateRect( DIS.rcItem, -1, -1 );
+ end;
+ end;
+ TxRect := DIS.rcItem;
+ if Self_.DF.fGlyphBitmap <> 0 then
+ begin
+ ImgW := Self_.DF.fGlyphWidth;
+ ImgH := Self_.DF.fGlyphHeight;
+ if (ImgW > 0) and (ImgH > 0) then
+ begin
+ OutW := ImgW;
+ OutH := ImgH;
+ W := DIS.rcItem.Right - DIS.rcItem.Left;
+ H := DIS.rcItem.Bottom - DIS.rcItem.Top;
+ X := DIS.rcItem.Left;
+ Y := DIS.rcItem.Top;
+ if isDown and (Self_.DF.fGlyphLayout <> glyphOver) then
+ begin
+ Inc( X, Self_.TextShiftX );
+ Inc( Y, Self_.TextShiftY );
+ end;
+ case Self_.DF.fGlyphLayout of
+ glyphLeft:
+ begin
+ Y := Y + (H - OutH) div 2;
+ TxRect.Left := X + OutW;
+ end;
+ glyphTop:
+ begin
+ X := X + (W - OutW) div 2;
+ TxRect.Top := Y + OutH;
+ end;
+ glyphRight:
+ begin
+ X := DIS.rcItem.Right - OutW;
+ TxRect.Right := X;
+ Y := Y + (H - OutH) div 2;
+ end;
+ glyphBottom:
+ begin
+ Y := DIS.rcItem.Bottom - OutH;
+ TxRect.Bottom := Y;
+ X := X + (W - OutW) div 2;
+ end;
+ glyphOver:
+ begin
+ X := X + (W - OutW) div 2;
+ Y := Y + (H - OutH) div 2;
+ end;
+ end;
+ if X < DIS.rcItem.Left then
+ X := DIS.rcItem.Left;
+ if Y < DIS.rcItem.Top then
+ Y := DIS.rcItem.Top;
+ if X + OutW > DIS.rcItem.Right then
+ OutW := DIS.rcItem.Right - X;
+ if Y + OutH > DIS.rcItem.Bottom then
+ OutH := DIS.rcItem.Bottom - Y;
+
+ if bboImageList in Self_.DF.fBitBtnOptions then
+ begin
+ I := LoWord( Self_.DF.fGlyphCount );
+ if (HiWord( Self_.DF.fGlyphCount ) > G) then
+ I := I + G;
+ Flags := 0; // ILD_NORMAL
+ Blend := 0;
+ if {$IFDEF USE_FLAGS} not( G2_Transparent in Self_.fFlagsG2 )
+ {$ELSE} not Self_.fTransparent {$ENDIF} then
+ Bk := Color2RGB( Self_.fColor )
+ else
+ begin
+ Bk := Integer(CLR_NONE);
+ Flags := ILD_TRANSPARENT;
+ end;
+ if HiWord( Self_.DF.fGlyphCount ) = 1 then
+ begin
+ Blend := Integer(CLR_DEFAULT);
+ if IsDefault then
+ Flags := Flags or ILD_BLEND25;
+ end;
+ ImageList_DrawEx( Self_.DF.fGlyphBitmap, I, DIS.hDC, X, Y, 0, 0,
+ Bk, Blend, Flags );
+ end
+ else
+ begin
+ DC := CreateCompatibleDC( 0 );
+ OldBmp := SelectObject( DC, Self_.DF.fGlyphBitmap );
+
+ I := 0;
+ if Self_.DF.fGlyphCount > G then
+ I := I + G * ImgW;
+ StretchBlt( DIS.hDC, X, Y, OutW, OutH, DC, I, 0, ImgW, ImgH, SRCCOPY );
+
+ SelectObject( DC, OldBmp );
+ DeleteDC( DC );
+ end;
+ end;
+ end;
+ if not (bboNoCaption in Self_.DF.fBitBtnOptions) then
+ if (TxRect.Right > TxRect.Left) and (TxRect.Bottom > TxRect.Top) then
+ begin
+ CapText := Self_.Caption;
+ CapTxtOrig := CapText; /////////////////////////// added 19 Nov 2001
+ if Assigned( Self_.DF.FBitBtnGetCaption ) then
+ CapText := Self_.DF.FBitBtnGetCaption( Self_, CapText ); ////////////
+ Bk := 0;
+ Blend := 0;
+ Flags := ETO_CLIPPED;
+ if {$IFDEF USE_FLAGS} (G2_Transparent in Self_.fFlagsG2)
+ {$ELSE} Self_.fTransparent {$ENDIF}
+ or (Self_.DF.fGlyphLayout = glyphOver) then
+ Bk := SetBkMode( DIS.hDC, TRANSPARENT )
+ else
+ begin
+ Flags := Flags or ETO_OPAQUE;
+ Blend := SetBkColor( DIS.hDC, Color2RGB( Self_.fColor ) );
+ end; // Returned previous BkMode is either OPAQUE=1 or TRANSPARENT=2
+
+ OldFont := 0;
+ if ( Self_.fFont <> nil ) then
+ OldFont := SelectObject( DIS.hDC, Self_.fFont.Handle );
+ OldTextColor := SetTextColor( DIS.hDC, Color2RGB( Self_.fTextColor ) );
+
+ {$IFDEF UNICODE_CTRLS}Windows.GetTextExtentPoint32W
+ {$ELSE} Windows.GetTextExtentPoint32A
+ {$ENDIF}( DIS.hDC, PKOLChar( CapText ), Length( CapText ),
+ TextSz );
+ W := TxRect.Right - TxRect.Left;
+ H := TxRect.Bottom - TxRect.Top;
+ Y := TxRect.Top + (H - TextSz.cy) div 2;
+ case Self_.fTextAlign of
+ taLeft: X := TxRect.Left;
+ taCenter: X := TxRect.Left + (W - TextSz.cx) div 2;
+ else {taRight:} X := TxRect.Right - TextSz.cx;
+ end;
+ if isDown then
+ begin
+ Inc( X, Self_.TextShiftX );
+ Inc( Y, Self_.TextShiftY );
+ end;
+ if Y < 0 then
+ Y := 0;
+ if X < TxRect.Left then
+ X := TxRect.Left;
+
+ {$IFDEF UNICODE_CTRLS}
+ Windows.ExtTextOutW( DIS.hDC, X, Y, Flags, @TxRect,
+ PWideChar( CapText ), Length( CapText ), nil );
+ {$ELSE}
+ Windows.ExtTextOutA( DIS.hDC, X, Y, Flags, @TxRect,
+ PAnsiChar( CapText ), Length( CapText ), nil );
+ {$ENDIF}
+
+ if bboFocusRect in Self_.DF.fBitBtnOptions then
+ if IsDefault then
+ begin
+ FocusRect := TxRect;
+ //InflateRect( FocusRect, 1, 1 );
+ Windows.DrawFocusRect( DIS.hDC, FocusRect );
+ end;
+
+ //{$IFDEF NIL_EVENTS}
+ if Assigned( Self_.DF.FBitBtnExtDraw ) then // to provide underlying mnemonic characters
+ //{$ENDIF}
+ Self_.DF.FBitBtnExtDraw( Self_, DIS.hDC, X, Y, TxRect, CapText, CapTxtOrig,
+ OldTextColor ); /////////////////////////////////
+
+ SetTextColor( DIS.hDC, OldTextColor );
+ if OldFont <> 0 then
+ SelectObject( DIS.hDC, OldFont );
+
+ if Blend = 0 then
+ SetBkMode( DIS.hDC, Bk )
+ else
+ SetBkColor( DIS.hDC, Blend );
+ end;
+ end;
+ if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_KEYDOWN) and (Msg.wParam = 32) then
+ begin
+ if bboFixed in Self_.DF.fBitBtnOptions then
+ begin
+ {$IFDEF USE_FLAGS}
+ if G4_Checked in Self_.fFlagsG4 then
+ exclude( Self_.fFlagsG4, G4_Checked )
+ else include( Self_.fFlagsG4, G4_Checked );
+ {$ELSE} Self_.fChecked := not Self_.fChecked; {$ENDIF}
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnChangeCtl ) then
+ {$ENDIF}
+ Self_.EV.fOnChangeCtl( Self_ );
+ end;
+ if Self_.DF.fRepeatInterval > 0 then
+ begin
+ if Msg.message <> WM_KEYDOWN then
+ SetTimer( Self_.fHandle, 1, 400, nil );
+ Self_.Invalidate;
+ end;
+ end;
+
+ if Msg.message = WM_LBUTTONUP then
+ begin
+ if Self_.DF.fRepeatInterval > 0 then
+ KillTimer( Self_.fHandle, 1 );
+ end;
+
+ if Msg.message = WM_KILLFOCUS then // to repaint when focus lost
+ Self_.Invalidate;
+
+ if Msg.message = WM_TIMER then
+ begin
+ KillTimer( Self_.fHandle, 1 );
+ if bboFixed in Self_.DF.fBitBtnOptions then
+ begin
+ {$IFDEF USE_FLAGS}
+ if G4_Checked in Self_.fFlagsG4 then
+ exclude( Self_.fFlagsG4, G4_Checked )
+ else include( Self_.fFlagsG4, G4_Checked );
+ {$ELSE} Self_.fChecked := not Self_.fChecked; {$ENDIF}
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnChangeCtl ) then
+ {$ENDIF}
+ Self_.EV.fOnChangeCtl( Self_ );
+ end;
+ Self_.DoClick;
+ SetTimer( Self_.fHandle, 1, Self_.DF.fRepeatInterval, nil );
+ Self_.Invalidate;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewBitBtn( AParent: PControl; const Caption: AnsiString;
+ Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap;
+ GlyphCount: Integer ): PControl;
+begin
+ new( Result, CreateBitBtn( AParent, Caption, Options, Layout, GlyphBitmap, GlyphCount ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:BitBtn';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_noVERSION} // todo: first correct asm version, then remove <no>
+{$ELSE PAS_VERSION} //Pascal
+function NewBitBtn( AParent: PControl; const Caption: KOLString;
+ Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap;
+ GlyphCount: Integer ): PControl;
+var
+ B: TBitmapInfo;
+ W, H: Integer;
+ f: DWORD;
+begin
+ f := WS_VISIBLE or WS_CHILD or BS_OWNERDRAW or WS_TABSTOP or BS_NOTIFY;
+ Result := _NewControl( AParent, 'BUTTON', f, False,
+ {$IFDEF PACK_COMMANDACTIONS} ButtonActions_Packed
+ {$ELSE} @ButtonActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:BitBtn';
+ {$ENDIF}
+ {$IFDEF USE_FLAGS}
+ Result.fFlagsG5 := Result.fFlagsG5 +
+ [G5_IsButton, G5_IsBitBtn, G5_IgnoreDefault];
+ {$ELSE} Result.fIsButton := TRUE;
+ Result.fIsBitBtn := TRUE;
+ Result.fIgnoreDefault := TRUE;
+ {$ENDIF}
+ Result.aAutoSzX := 8;
+ Result.aAutoSzY := 8;
+ Result.DF.fBitBtnOptions := Options;
+ Result.DF.fGlyphLayout := Layout;
+ Result.DF.fGlyphBitmap := GlyphBitmap;
+ with Result.fBoundsRect do
+ begin
+ Bottom := Top + 22;
+ W := 0; H := 0;
+ if GlyphBitmap <> 0 then
+ begin
+ if bboImageList in Options then
+ ImageList_GetIconSize( GlyphBitmap, W, H )
+ else
+ begin
+ if GetObject( GlyphBitmap, Sizeof(B), @B ) > 0 then
+ begin
+ W := B.bmiHeader.biWidth;
+ H := B.bmiHeader.biHeight;
+ if GlyphCount = 0 then
+ GlyphCount := W div H;
+ if GlyphCount > 1 then
+ W := W div GlyphCount;
+ end;
+ end;
+ if W > 0 then
+ begin
+ if (Caption = '') or (Layout = glyphOver) then
+ begin
+ Right := Left + W;
+ Result.aAutoSzX := 0;
+ end
+ else
+ if Layout in [ glyphLeft, glyphRight ] then
+ begin
+ Right := Right + W;
+ Inc( Result.aAutoSzX, W );
+ end;
+ end;
+ if H > 0 then
+ begin
+ if Layout in [ glyphTop, glyphBottom ] then
+ begin
+ Bottom := Bottom + H;
+ Inc( Result.aAutoSzY, H );
+ end
+ else
+ begin
+ Bottom := Top + H;
+ Result.aAutoSzY := 0;
+ end;
+ end;
+ if not ( bboNoBorder in Options ) then
+ begin
+ if W > 0 then
+ begin
+ Inc( Right, 4 );
+ if Result.aAutoSzX > 0 then
+ Inc( Result.aAutoSzX, 4 );
+ end;
+ if H > 0 then
+ begin
+ Inc( Bottom, 4 );
+ if Result.aAutoSzY > 0 then
+ Inc( Result.aAutoSzY, 4 );
+ end;
+ end;
+ end;
+ Result.DF.fGlyphWidth := W;
+ Result.DF.fGlyphHeight := H;
+ end;
+ Result.DF.fGlyphCount := GlyphCount;
+ if AParent <> nil then
+ AParent.AttachProc( WndProc_DrawItem );
+ Result.AttachProc( WndProcBitBtn );
+ Result.fTextAlign := taCenter;
+ Result.Caption := Caption;
+ {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
+ Result.AttachProc( WndProcBtnReturnClick );
+ {$ENDIF}
+
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ Attach_WM_THEMECHANGED(Result, XP_Themes_For_BitBtn);
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== Check box ========================//
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewCheckbox( AParent: PControl; const Caption: AnsiString ): PControl;
+begin
+ new( Result, CreateCheckbox( AParent, Caption ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:CheckBox';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewCheckbox( AParent: PControl; const Caption: KOLString ): PControl;
+begin
+ Result := NewButton( AParent, Caption );
+ with Result.fBoundsRect do
+ begin
+ Right := Left + 72;
+ end;
+ Result.fStyle.Value := WS_VISIBLE or WS_CHILD or
+ BS_AUTOCHECKBOX or WS_TABSTOP or BS_NOTIFY;
+ Result.aAutoSzX := 24;
+
+{$IFDEF GRAPHCTL_XPSTYLES}
+ Attach_WM_THEMECHANGED(Result, XP_Themes_For_CheckBox );
+{$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+function NewCheckBox3State( AParent: PControl; const Caption: KOLString ): PControl;
+begin
+ Result := NewCheckbox( AParent, Caption );
+ Result.fStyle.Value := Result.fStyle.Value and not BS_AUTOCHECKBOX or BS_AUTO3STATE;
+end;
+
+//===================== Radiobox ========================//
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure ClickRadio( Sender:PObj );
+var Self_:PControl;
+ {$IFDEF USE_FLAGS}
+ i: Integer;
+ C: PControl;
+ NewState: Boolean;
+ {$ENDIF}
+begin
+ Self_ := PControl( Sender );
+ if Self_.FParent <> nil then
+ {$IFDEF USE_FLAGS}
+ begin
+ for i := 0 to Self_.FParent.ChildCount-1 do
+ begin
+ C := Self_.FParent.Children[i];
+ if G5_IsButton in C.fFlagsG5 then
+ if C.fStyle.f0_Style and BS_RADIOBUTTON <> 0 then
+ begin
+ NewState := C = Self_;
+ if NewState <> C.Checked then
+ C.Checked := NewState;
+ end;
+ end;
+ end;
+ {$ELSE}
+ CheckRadioButton( Self_.fParent.fHandle,
+ Self_.fParent.PropInt[ @RADIO_1ST ],
+ Self_.fParent.PropInt[ @RADIO_LAST ],
+ Self_.fMenu );
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewRadiobox( AParent: PControl; const Caption: AnsiString ): PControl;
+begin
+ new( Result, CreateRadiobox( AParent, Caption ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Radiobox';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewRadiobox( AParent: PControl; const Caption: KOLString ): PControl;
+begin
+ Result := NewCheckbox( AParent, Caption );
+ Result.fStyle.Value := WS_VISIBLE or WS_CHILD or
+ BS_RADIOBUTTON or WS_TABSTOP or WS_GROUP or BS_NOTIFY;
+ Result.PP.fControlClick := ClickRadio;
+ if AParent <> nil then
+ begin
+ {$IFDEF USE_FLAGS}
+ if not(G1_HasRadio in AParent.fFlagsG1) then
+ begin
+ include( AParent.fFlagsG1, G1_HasRadio );
+ Result.SetRadioChecked;
+ end;
+ {$ELSE}
+ AParent.PropInt[ @RADIO_LAST ] := Result.fMenu;
+ if AParent.PropInt[ @RADIO_1ST ] = 0 then
+ begin
+ AParent.PropInt[ @RADIO_1ST ] := Result.fMenu;
+ Result.SetRadioChecked;
+ end;
+ {$ENDIF}
+ end;
+{$IFDEF GRAPHCTL_XPSTYLES}
+ Attach_WM_THEMECHANGED(Result, XP_Themes_For_RadioBox);
+{$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== Label ========================//
+
+{$ENDIF WIN_GDI}
+{$IFNDEF USE_CONSTRUCTORS}
+{$ENDIF not USE_CONSTRUCTORS}
+{$IFDEF USE_CONSTRUCTORS}
+function NewLabel( AParent: PControl; const Caption: AnsiString ): PControl;
+begin
+ new( Result, CreateLabel( AParent, Caption ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Label';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF GDI}
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function NewLabel( AParent: PControl; const Caption: KOLString ): PControl;
+begin
+ Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or
+ SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,
+ False, {$IFDEF PACK_COMMANDACTIONS} LabelActions_Packed
+ {$ELSE} @LabelActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Label';
+ {$ENDIF}
+ Result.aAutoSzX := 1;
+ Result.aAutoSzY := 1;
+ {$IFDEF USE_FLAGS}
+ Result.fFlagsG1 := Result.fFlagsG1 + [G1_SizeRedraw, G1_IsStaticControl];
+ {$ELSE} Result.fSizeRedraw := True;
+ Inc( Result.fIsStaticControl );
+ {$ENDIF}
+ with Result.fBoundsRect do
+ Bottom := Top + 22; //Right := Left + 64 {done in _NewControl};
+ Result.Caption := Caption;
+{$IFDEF GRAPHCTL_XPSTYLES}
+ Attach_WM_THEMECHANGED(Result, XP_Themes_For_Label);
+{$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE LabelSetTextAlign( Self_: PControl );
+BEGIN
+ gtk_misc_set_alignment( GTK_MISC( Self_.fCaptionHandle ), HorAlignments[ Self_.fTextAlign ],
+ VerAlignments[ Self_.fVerticalAlign ] );
+END;
+
+FUNCTION NewLabel( AParent: PControl; const Caption: KOLString ): PControl;
+BEGIN
+ Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or
+ SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,
+ False, gtk_label_new( PAnsiChar( String( Caption ) ) ),
+ TRUE );
+ Result.fGetCaption := getLabelCaption;
+ Result.fSetCaption := setLabelCaption;
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG1, G1_IsStaticControl );
+ {$ELSE} Inc( Result.fIsStaticControl ); {$ENDIF}
+ Result.fSetTextAlign := LabelSetTextAlign;
+ Result.fTextAlign := taCenter;
+ Result.TextAlign := taLeft;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+{$ENDIF USE_CONSTRUCTORS}
+
+{$IFDEF WIN_GDI}
+//===================== word wrap Label ========================//
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewWordWrapLabel( AParent: PControl; const Caption: AnsiString ): PControl;
+begin
+ new( Result, CreateWordWrapLabel( AParent, Caption ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:WordWrapLabel';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewWordWrapLabel( AParent: PControl; const Caption: KOLString ): PControl;
+begin
+ Result := NewLabel( AParent, Caption );
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG1, G1_WordWrap );
+ {$ELSE} Result.fWordWrap := TRUE; {$ENDIF}
+ with Result.fBoundsRect do
+ begin
+ Bottom := Top + 44;
+ end;
+ Result.fStyle.Value := Result.fStyle.Value and not SS_LEFTNOWORDWRAP;
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== Label Effect ========================//
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewLabelEffect( AParent: PControl; const Caption: AnsiString; ShadowDeep: Integer ): PControl;
+begin
+ new( Result, CreateLabelEffect( AParent, Caption, ShadowDeep ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:LabelEffect';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewLabelEffect( AParent: PControl; const Caption: KOLString; ShadowDeep: Integer ): PControl;
+begin
+ Result := NewLabel( AParent, '' );
+ {$IFDEF USE_FLAGS} exclude( Result.fFlagsG1, G1_IsStaticControl );
+ {$ELSE} Dec( Result.fIsStaticControl ); { снова 0 ! } {$ENDIF}
+ Result.AttachProc( WndProcLabelEffect );
+ Result.Caption := Caption;
+ Result.AttachProc( WndProcDoEraseBkgnd );
+ Result.fTextAlign := taCenter;
+ Result.fTextColor := clWindowText;
+ Result.DF.fShadowDeep := ShadowDeep;
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG1, G1_IgnoreWndCaption );
+ {$ELSE} Result.fIgnoreWndCaption := True; {$ENDIF}
+ with Result.fBoundsRect do
+ begin
+ Bottom := Top + 40;
+ end;
+ Result.DF.fColor2 := clNone;
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== Paint box ========================//
+{$ENDIF WIN_GDI}
+{$IFDEF USE_CONSTRUCTORS}
+function NewPaintbox( AParent: PControl ): PControl;
+begin
+ new( Result, CreatePaintBox( AParent ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Paintbox';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF GDI}
+
+{$UNDEF ASM_LOCAL}
+{$IFNDEF GRAPHCTL_XPSTYLES}
+ {$IFDEF ASM_VERSION}
+ {$DEFINE ASM_LOCAL}
+ {$ENDIF PAS_VERSION}
+{$ENDIF GRAPHCTL_XPSTYLES}
+
+{$IFDEF ASM_LOCAL}
+function NewPaintbox( AParent: PControl ): PControl;
+asm
+ XOR EDX, EDX
+ CALL NewLabel
+ ADD [EAX].TControl.fBoundsRect.Bottom, 64-22
+end;
+{$ELSE ASM_LOCAL} //Pascal
+function NewPaintbox( AParent: PControl ): PControl;
+begin
+{$IFDEF GRAPHCTL_XPSTYLES}
+ Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD {or
+ SS_LEFTNOWORDWRAP or SS_NOPREFIX }or SS_NOTIFY,
+ False, {$IFDEF PACK_COMMANDACTIONS} LabelActions_Packed
+ {$ELSE} @LabelActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:PaintBox';
+ {$ENDIF}
+ {$IFDEF USE_FLAGS}
+ include( Result.fFlagsG1, G1_SizeRedraw );
+ if G2_Transparent in Result.fFlagsG2 then
+ include( Result.fFlagsG2, G2_ClassicTransparent )
+ else exclude( Result.fFlagsG2, G2_ClassicTransparent );
+ {$ELSE} Result.fSizeRedraw := True;
+ Result.fClassicTransparent := Result.fTransparent;
+ {$ENDIF}
+ Result.fControlClassName := 'obj_PAINT';
+{$ELSE}
+ Result := NewLabel( AParent, '' );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Paintbox';
+ {$ENDIF}
+ with Result.fBoundsRect do
+ begin
+ Bottom := Top + 64; //Right := Left + 64 {done in NewLabel};
+ end;
+{$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION NewPaintbox( AParent: PControl ): PControl;
+BEGIN
+ Result := NewLabel( AParent, '' );
+ Result.Height := 64;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$ENDIF USE_CONSTRUCTORS}
+{$IFDEF WIN_GDI}
+
+{$IFDEF _D2}
+function SetBrushOrgEx(DC: HDC; X, Y: Integer; PrevPt: PPoint): BOOL; stdcall;
+external gdi32 name 'SetBrushOrgEx';
+{$ENDIF}
+
+{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION PAS_VERSION}
+function WndProcDoEraseBkgnd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var DC: HDC;
+ R: TRect;
+begin
+ Result := FALSE;
+ if Msg.message = WM_ERASEBKGND then
+ begin
+ Self_.CreateChildWindows;
+ if Self_.Transparent then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ DC := Msg.wParam;
+ SetBkMode( DC, OPAQUE );
+ SetBkColor( DC, Color2RGB( Self_.fColor ) );
+ SetBrushOrgEx( DC, 0, 0, nil );
+ GetClientRect( Self_.fHandle, R );
+ Windows.FillRect( DC, R, Global_GetCtlBrushHandle( Self_ ) );
+ Rslt := 1;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function WndProcImageShow( Sender: PControl; var Msg: TMsg;
+ var Rslt: Integer ): Boolean;
+var PaintStruct: TPaintStruct;
+ IL: PImageList;
+ OldPaintDC: HDC;
+ {$IFDEF TEST_IL}
+ B: PBitmap;
+ {$ENDIF TEST_IL}
+begin
+ Result := FALSE;
+ if (Msg.message = WM_PAINT) or (Msg.message = WM_PRINT) then
+ begin
+ OldPaintDC := Sender.fPaintDC;
+ Sender.fPaintDC := Msg.wParam;
+ if Sender.fPaintDC = 0 then
+ Sender.fPaintDC := BeginPaint( Sender.fHandle, PaintStruct );
+ IL := Sender.ImageListNormal;
+ if IL <> nil then
+ begin
+ IL.DrawingStyle := [ dsTransparent ];
+ {$IFDEF TEST_IL}
+ B := NewBitmap( 0, 0 );
+ B.Handle := IL.GetBitmap;
+ B.SaveToFile( GetStartDir + 'test_IL_show.bmp' );
+ B.ReleaseHandle;
+ B.Free;
+ {$ENDIF TEST_IL}
+ IL.Draw( Sender.fCurIndex, Sender.fPaintDC, Sender.fClientLeft, Sender.fClientTop );
+ Result := TRUE;
+ end;
+ if Msg.wParam = 0 then
+ EndPaint( Sender.fHandle, PaintStruct );
+ Sender.fPaintDC := OldPaintDC;
+ Rslt := 0; {Result := True;} Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+end;
+
+function NewImageShow( AParent: PControl; AImgList: PImageList;
+ ImgIdx: Integer ): PControl;
+var W, H: Integer;
+begin
+ Result := NewLabel( AParent, '' );
+ Result.ImageListNormal := AImgList;
+ Result.AttachProc( WndProcImageShow );
+ Result.AttachProc( WndProcDoEraseBkgnd );
+ W := 32; H := 32;
+ if AImgList <> nil then
+ begin
+ W := AImgList.ImgWidth;
+ H := AImgList.ImgHeight;
+ end;
+ with Result.fBoundsRect do
+ begin
+ Right := Left + W;
+ Bottom := Top + H;
+ end;
+ Result.CurIndex := ImgIdx;
+end;
+
+//===================== Scrollbar ========================//
+const
+ KSB_INITIALIZE = WM_USER + 10000;
+ KSB_KEY = $3232;
+
+function WndProcScrollBarParent( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var
+ Bar: PControl;
+ SI: TScrollInfo;
+ NewPos: Integer;
+ AllowChange: Boolean;
+ Cmd: Word;
+
+begin
+ Result := False;
+ case Msg.message of
+ WM_HSCROLL, WM_VSCROLL:
+ if (Msg.lParam <> 0) then begin
+ {$IFDEF USE_PROP}
+ Bar := Pointer(GetProp(Msg.lParam, ID_SELF));
+ {$ELSE}
+ Bar := Pointer( GetWindowLong( Msg.lParam, GWL_USERDATA ) );
+ {$ENDIF}
+ if (Bar <> nil) then begin
+ ZeroMemory(@SI, SizeOf(SI));
+ SI.cbSize := SizeOf(SI);
+ SI.fMask := SIF_RANGE or SIF_POS or SIF_TRACKPOS or SIF_PAGE;
+ Bar.SBGetScrollInfo(SI);
+
+ Cmd := Msg.wParam and $0000FFFF;
+ case Cmd of
+ SB_BOTTOM: NewPos := SI.nMax;
+ SB_TOP: NewPos := SI.nMin;
+ SB_LINEDOWN: NewPos := SI.nPos + 1;
+ SB_LINEUP: NewPos := SI.nPos - 1;
+ SB_PAGEDOWN: NewPos := SI.nPos + Integer(SI.nPage);
+ SB_PAGEUP: NewPos := SI.nPos - Integer(SI.nPage);
+ {!ecm}
+ SB_THUMBPOSITION,SB_THUMBTRACK: NewPos := SI.nTrackPos;
+ SB_ENDSCROLL: NewPos := SI.nPos;
+ {/!ecm}
+ else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+
+ if (NewPos > SI.nMax - Integer(SI.nPage) + 1) then
+ NewPos := SI.nMax - Integer(SI.nPage) + 1;
+ if (NewPos < SI.nMin) then
+ NewPos := SI.nMin;
+
+ AllowChange := True;
+ {$IFDEF NIL_EVENTS}
+ if Assigned(Bar.EV.fOnSBBeforeScroll) then
+ {$ENDIF}
+ Bar.EV.fOnSBBeforeScroll(Bar, SI.nPos, NewPos, Cmd, AllowChange);
+ if AllowChange then
+ SI.nPos := NewPos
+ else
+ SI.nTrackPos := SI.nPos;
+ Bar.DF.fSBPosition := SI.nPos;
+ Bar.DF.fSBPosition := Bar.SBSetScrollInfo(SI);
+ if AllowChange
+ {$IFDEF NIL_EVENTS} and Assigned(Bar.EV.fOnSBScroll) {$ENDIF} then
+ Bar.EV.fOnSBScroll(Bar, Cmd);
+ end;
+ end;
+ end;
+end;
+
+function NewScrollBar( AParent: PControl; BarSide: TScrollerBar ): PControl;
+const SBS_Directions: array[ TScrollerBar ] of DWORD = ( SBS_HORZ or SBS_BOTTOMALIGN,
+ SBS_VERT or SBS_RIGHTALIGN );
+begin
+ Result := _NewCommonControl( AParent, 'SCROLLBAR',
+ WS_VISIBLE or WS_CHILD or SBS_Directions[ BarSide ],
+ False, {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS )
+ {$ELSE} nil {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:ScrollBar';
+ {$ENDIF}
+ {!ecm} Result.GetWindowHandle; {/!ecm}
+ Result.DetachProc(WndProcCtrl);
+ Result.fLookTabKeys := [tkTab];
+
+ //#ecm Result.AttachProc(WndProcScrollBar);
+ AParent.AttachProc(WndProcScrollBarParent);
+end;
+
+//===================== Scrollbox ========================//
+function WndProcScrollBox( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var Bar: DWORD;
+ SI: TScrollInfo;
+ OldNotifyProc: pointer;
+begin
+
+ case Msg.message of
+ WM_HSCROLL: Bar := SB_HORZ;
+ WM_VSCROLL: Bar := SB_VERT;
+ WM_SIZE: begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.PP.fNotifyChild ) then
+ {$ENDIF}
+ Sender.PP.fNotifyChild( Sender, nil );
+ Result := FALSE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ else Result := FALSE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+
+ SI.cbSize := Sizeof( SI );
+ SI.fMask := SIF_RANGE or SIF_POS or SIF_PAGE or
+ {$IFDEF F_P}$10{$ELSE}SIF_TRACKPOS{$ENDIF};
+ GetScrollInfo( Sender.fHandle, Bar, SI );
+ SI.fMask := SIF_POS;
+ case LoWord( Msg.wParam ) of
+ SB_BOTTOM: SI.nPos := SI.nMax;
+ SB_TOP: SI.nPos := SI.nMin;
+ SB_LINEDOWN: Inc( SI.nPos, Sender.DF.fScrollLineDist[ Bar ] );
+ SB_LINEUP: Dec( SI.nPos, Sender.DF.fScrollLineDist[ Bar ] );
+ SB_PAGEDOWN: Inc( SI.nPos, Max( SI.nPage, 1 ) );
+ SB_PAGEUP: Dec( SI.nPos, Max( SI.nPage, 1 ) );
+ SB_THUMBTRACK:SI.nPos := SI.nTrackPos;
+ end;
+ if SI.nPos > SI.nMax { - Integer( SI.nPage ) } then
+ SI.nPos := SI.nMax { - Integer( SI.nPage ) };
+ if SI.nPos < SI.nMin then
+ SI.nPos := SI.nMin;
+ SetScrollInfo( Sender.fHandle, Bar, SI, TRUE );
+
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.PP.fScrollChildren ) then
+ {$ENDIF}
+ begin
+ OldNotifyProc := @ Sender.PP.fNotifyChild;
+ Sender.PP.fNotifyChild := @DummyObjProc;
+ Sender.PP.fScrollChildren( Sender );
+ Sender.PP.fNotifyChild := OldNotifyProc;
+ end;
+
+ SetScrollInfo( Sender.fHandle, Bar, SI, TRUE );
+ Result := FALSE;
+end;
+
+function NewScrollBox( AParent: PControl; EdgeStyle: TEdgeStyle;
+ Bars: TScrollerBars ): PControl;
+var SBFlag: Integer;
+begin
+ SBFlag := EdgeStyles[ EdgeStyle ];
+ if sbHorizontal in Bars then
+ SBFlag := SBFlag or WS_HSCROLL;
+ if sbVertical in Bars then
+ SBFlag := SBFlag or WS_VSCROLL;
+
+ Result := _NewControl( AParent, 'ScrollBox', WS_VISIBLE or WS_CHILD or
+ SBFlag, EdgeStyle = esLowered,
+ {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS )
+ {$ELSE} nil {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:ScrollBox';
+ {$ENDIF}
+ Result.AttachProc( WndProcForm ); //!!!
+ Result.AttachProc( WndProcScrollBox );
+ Result.AttachProc( WndProcDoEraseBkgnd );
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG3, G3_IsControl );
+ {$ELSE} Result.fIsControl := TRUE; {$ENDIF}
+end;
+
+function Scrollbar_GetMinPos( sb: PControl ): Integer;
+begin
+ Result := sb.SBMax;
+end;
+procedure Scrollbar_SetMinPos( sb: PControl; m: Integer );
+begin
+ sb.SBMin := m;
+end;
+procedure Scrollbar_SetAll( sb: PControl; min, max, pg, cur: Integer );
+begin
+ sb.SBMin := min;
+ sb.SBMax := max;
+ sb.SBPageSize := pg;
+ sb.SBPosition := cur;
+end;
+function Scrollbar_GetMaxPos( sb: PControl ): Integer;
+begin
+ Result := sb.SBMax;
+end;
+procedure Scrollbar_SetMaxPos( sb: PControl; m: Integer );
+begin
+ sb.SBMax := m;
+end;
+function Scrollbar_GetCurPos( sb: PControl ): Integer;
+begin
+ Result := sb.SBPosition;
+end;
+procedure Scrollbar_SetCurPos( sb: PControl; newp: Integer );
+begin
+ sb.SBPosition := newp;
+end;
+procedure Scrollbar_SetPageSz( sb: PControl; psz: Integer );
+begin
+ sb.SBPageSize := psz;
+end;
+function Scrollbar_GetPageSz( sb: PControl ): Integer;
+begin
+ Result := sb.SBPageSize;
+end;
+procedure Scrollbar_SetLineSz( sb: PControl; lnz: Integer );
+begin
+ //
+end;
+function Scrollbar_GetLineSz( sb: PControl ): Integer;
+begin
+ Result := 1;
+end;
+
+function WndProcNotifyParentAboutResize( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var P: PControl;
+begin
+ if (Msg.message = WM_SIZE) or (Msg.message = WM_MOVE) or (Msg.message = CM_SHOW) then
+ begin
+ P := Sender.Parent;
+ if P <> nil then
+ {$IFDEF NIL_EVENTS}
+ if Assigned( P.PP.fNotifyChild ) then
+ {$ENDIF}
+ P.PP.fNotifyChild( P, nil );
+ end
+ else
+ if Msg.message = WM_SHOWWINDOW then
+ PostMessage( Sender.fHandle, CM_SHOW, 0, 0 );
+ Result := FALSE;
+end;
+
+procedure CalcMinMaxChildren( Self_: PControl; var SzR: TRect );
+var I: Integer;
+ C: PControl;
+ R: TRect;
+begin
+ Szr := MakeRect( 0, 0, 0, 0 );
+ for I := 0 to Self_.fChildren.fCount - 1 do
+ begin
+ C := Self_.fChildren.Items[ I ];
+ if C.ToBeVisible then
+ begin
+ R := C.BoundsRect;
+ if (SzR.Left = SzR.Right) or (R.Left < SzR.Left) or (R.Right > SzR.Right) then
+ begin
+ if SzR.Left = SzR.Right then
+ begin
+ SzR.Left := R.Left;
+ SzR.Right := R.Right;
+ end
+ else
+ begin
+ if R.Left < SzR.Left then SzR.Left := R.Left;
+ if R.Right > SzR.Right then SzR.Right := R.Right;
+ end;
+ end;
+ if (SzR.Top = SzR.Bottom) or (R.Top < SzR.Top) or (R.Bottom > SzR.Bottom) then
+ begin
+ if SzR.Top = SzR.Bottom then
+ begin
+ SzR.Top := R.Top;
+ SzR.Bottom := R.Bottom;
+ end
+ else
+ begin
+ if R.Top < SzR.Top then SzR.Top := R.Top;
+ if R.Bottom > SzR.Bottom then SzR.Bottom := R.Bottom;
+ end;
+ end;
+ end;
+ end;
+ Dec( SzR.Left, Self_.Border );
+ Inc( SzR.Right, Self_.Border - 1 );
+ Dec( SzR.Top, Self_.Border );
+ Inc( SzR.Bottom, Self_.Border - 1 );
+end;
+
+procedure NotifyScrollBox( Self_, Child: PControl );
+var SI: TScrollInfo;
+
+ procedure GetSetScrollInfo( SBar: DWORD; WH, R_RightBottom, SzR_LeftTop, SzR_RightBottom: Integer );
+ {$IFDEF SBOX_OLDPOS} var OldPos: Double; {$ENDIF}
+ begin
+ {$IFDEF SBOX_OLDPOS} OldPos := 0; {$ENDIF}
+ if not GetScrollInfo( Self_.fHandle, SBar, SI ) then
+ begin
+ SI.nMin := 0;
+ SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 );
+ end
+ else
+ begin
+ {$IFDEF SBOX_OLDPOS}
+ if SI.nMax > SI.nMin then
+ begin
+ OldPos := (SI.nPos - SI.nMin) / (SI.nMax - SI.nMin);
+ SI.nMin := 0;
+ SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 );
+ if SzR_LeftTop < 0 then
+ SI.nMax := Max( R_RightBottom - SzR_LeftTop - 1, WH - 1 );
+ end
+ else
+ begin
+ SI.nMin := 0;
+ SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 );
+ end;
+ {$ENDIF}
+ SI.nMin := 0; {!ecm}
+ SI.nMax := SzR_RightBottom - SzR_LeftTop; {!ecm}
+ end;
+ {$IFDEF SBOX_OLDPOS}
+ SI.nPos := SI.nMin + Round( (SI.nMax - SI.nMin) * OldPos );
+ {$ELSE}
+ SI.nPos := - SzR_LeftTop;
+ {$ENDIF}
+ SI.nPage := R_RightBottom;
+ SetScrollInfo( Self_.fHandle, SBar, SI, TRUE );
+ end;
+
+var W, H: Integer;
+ SzR: TRect;
+ R: TRect;
+begin
+ if ( Child <> nil ) then
+ begin
+ Child.AttachProc( WndProcNotifyParentAboutResize ); Exit; {>>>>>>>>>>>>>>}
+ end;
+ CalcMinMaxChildren( Self_, SzR );
+ W := SzR.Right - SzR.Left;
+ H := SzR.Bottom - SzR.Top;
+
+ R := Self_.ClientRect;
+ if (R.Right = 0) or (R.Bottom = 0) then
+ Exit; // for case when form is minimized {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ SI.cbSize := sizeof( SI );
+ SI.fMask := SIF_RANGE or SIF_PAGE or SIF_POS;
+
+ SI.cbSize := sizeof( SI );
+ SI.fMask := SIF_RANGE or SIF_PAGE or SIF_POS;
+
+ GetSetScrollInfo( SB_HORZ, W, R.Right, SzR.Left, SzR.Right );
+{+ecm}R := Self_.ClientRect;{/+ecm}
+ GetSetScrollInfo( SB_VERT, H, R.Bottom, SzR.Top, SzR.Bottom );
+{+ecm} {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.PP.fScrollChildren ) then
+ {$ENDIF}
+ Self_.PP.fScrollChildren(Self_); {/+ecm}
+end;
+
+procedure ScrollChildren( _Self_: PControl );
+var SzR, R: TRect;
+ I, Xpos, Ypos: Integer;
+ OldNotifyProc: Pointer;
+ C: PControl;
+ DeltaX, DeltaY: Integer;
+
+begin
+
+ CalcMinMaxChildren( _Self_, SzR );
+ Xpos := GetScrollPos( _Self_.fHandle, SB_HORZ );
+ Ypos := GetScrollPos( _Self_.fHandle, SB_VERT );
+
+ DeltaX := -Xpos - SzR.Left;
+ DeltaY := -Ypos - SzR.Top;
+
+ if (DeltaX <> 0) or (DeltaY <> 0) then
+ begin
+
+ OldNotifyProc := @ _Self_.PP.fNotifyChild;
+ _Self_.PP.fNotifyChild := @DummyObjProc;
+
+ for I := 0 to _Self_.fChildren.fCount - 1 do
+ begin
+ C := _Self_.fChildren.Items[ I ];
+ R := C.BoundsRect;
+ OffsetRect( R, DeltaX, DeltaY );
+ C.BoundsRect := R;
+ end;
+
+ _Self_.PP.fNotifyChild := OldNotifyProc;
+ CalcMinMaxChildren( _Self_, R );
+ if //(SzR.Left <> R.Left) or (SzR.Top <> R.Top) or
+ //(Szr.Right <> R.Right) or (SzR.Bottom <> R.Bottom)
+ ((SzR.Right - SzR.Left) <> (R.Right - R.Left)) or
+ ((SzR.Bottom - SzR.Top) <> (R.Bottom - R.Top))
+ then
+ {$IFDEF NIL_EVENTS}
+ if Assigned( _Self_.PP.fNotifyChild ) then
+ {$ENDIF}
+ _Self_.PP.fNotifyChild( _Self_, nil );
+
+ end;
+
+end;
+
+function NewScrollBoxEx( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
+begin
+ Result := NewScrollBox( AParent, EdgeStyle, [ ] );
+ Result.PP.fNotifyChild := NotifyScrollBox;
+ Result.PP.fScrollChildren := ScrollChildren;
+ Result.DF.fScrollLineDist[ 0 ] := 16;
+ Result.DF.fScrollLineDist[ 1 ] := 16;
+end;
+
+function WndProcOnScroll( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var Bar: TScrollerBar;
+begin
+ Bar := sbHorizontal; //0
+ if Msg.message = WM_VSCROLL then
+ Bar := sbVertical
+ else
+ if Msg.message <> WM_HSCROLL then
+ begin
+ Result := FALSE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnScroll ) then
+ {$ENDIF}
+ Sender.EV.fOnScroll( Sender, Bar, LoWord( Msg.wParam ),
+ HiWord( Msg.wParam ) );
+ Result := FALSE;
+end;
+
+procedure TControl.SetOnScroll(const Value: TOnScroll);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .FOnScroll := Value;
+ AttachProc( @ WndProcOnScroll );
+end;
+
+//===================== Groupbox ========================//
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewGroupbox( AParent: PControl; const Caption: AnsiString ): PControl;
+begin
+ new( Result, CreateGroupbox( AParent, Caption ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Groupbox';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function NewGroupbox( AParent: PControl; const Caption: KOLString ): PControl;
+begin
+ Result := _NewControl( AParent, 'BUTTON',
+ WS_CHILD
+ or WS_CLIPSIBLINGS
+ or WS_CLIPCHILDREN
+ or WS_VISIBLE
+ or BS_GROUPBOX,
+ FALSE, {$IFDEF PACK_COMMANDACTIONS} ButtonActions_Packed
+ {$ELSE} @ButtonActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Groupbox';
+ {$ENDIF}
+ Result.fExStyle := Result.fExStyle or WS_EX_CONTROLPARENT;
+ Result.Caption := Caption;
+ with Result.fBoundsRect do
+ begin
+ Right := Left + 100;
+ Bottom := Top + 100;
+ end;
+ Result.fClientTop := 22;
+ Result.fClientBottom := 2;
+ Result.fClientLeft := 2;
+ Result.fClientRight := 2;
+ {$IFDEF USE_FLAGS}
+ exclude( Result.fStyle.f2_Style, F2_Tabstop );
+ include( Result.fFlagsG5, G5_IsGroupbox );
+ {$ELSE} Result.fTabstop := False;
+ Result.fIsGroupBox := TRUE;
+ {$ENDIF}
+ Result.AttachProc( WndProcDoEraseBkgnd );
+{$IFDEF GRAPHCTL_XPSTYLES}
+ Attach_WM_THEMECHANGED(Result, XP_Themes_For_GroupBox);
+{$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== Panel ========================//
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
+begin
+ new( Result, CreatePanel( AParent, EdgeStyle ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Panel';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
+begin
+ Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or SS_NOTIFY or
+ SS_LEFTNOWORDWRAP or SS_NOPREFIX, False,
+ {$IFDEF PACK_COMMANDACTIONS} LabelActions_Packed
+ {$ELSE} @LabelActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Panel';
+ {$ENDIF}
+ Result.aAutoSzX := 1;
+ Result.aAutoSzY := 1;
+ with Result.fBoundsRect do
+ begin
+ Right := Left + 100;
+ Bottom := Top + 100;
+ end;
+ Result.fStyle.Value := Result.fStyle.Value or Edgestyles[ EdgeStyle ];
+ Result.fExStyle := Result.fExStyle or WS_EX_CONTROLPARENT;
+ Result.fVerticalAlign := vaTop;
+{$IFDEF GRAPHCTL_XPSTYLES}
+ if AppTheming then
+ Result.fStyle.Value := Result.fStyle.Value and (not Edgestyles[ EdgeStyle ]);
+ Result.SetEdgeStyle(EdgeStyle);
+ Attach_WM_THEMECHANGED(Result, XP_Themes_For_Panel);
+{$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== Splitter ==============================//
+
+//{$DEFINE USE_ASM_DODRAG}
+
+ {$IFNDEF USE_ASM_DODRAG}
+ {$DEFINE USE_PAS_DODRAG}
+ {$ENDIF}
+ {$IFNDEF ASM_VERSION}
+ {$DEFINE USE_PAS_DODRAG}
+ {$ENDIF}
+{$IFDEF USE_PAS_DODRAG}
+procedure DoDrag( Self_: PControl; Cancel: Boolean );
+var NewSize1, NewSize2: Integer;
+ MousePos: TPoint;
+ R: TRect;
+ Prev: PControl;
+ I, M : Integer;
+begin
+ if {$IFDEF USE_FLAGS} G6_Dragging in Self_.fFlagsG6
+ {$ELSE} Self_.fDragging {$ENDIF} then
+ begin
+ I := Self_.fParent.fChildren.IndexOf( Self_ );
+ Prev := Self_;
+ 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 Cancel then
+ MousePos := Self_.DF.fSplitStartPos;
+ M := 1;
+ if Self_.FAlign in [ caRight, caBottom ] then
+ M := -1;
+ if Self_.FAlign in [ caTop, caBottom ] then
+ begin
+ NewSize1 := (MousePos.y - Self_.DF.fSplitStartPos.y)* M
+ + Self_.DF.fSplitStartSize;
+ NewSize2 := Self_.fParent.ClientHeight - NewSize1
+ - Self_.fBoundsRect.Bottom + Self_.fBoundsRect.Top
+ - Self_.fParent.fMargin * 4;
+ if Self_.DF.fSecondControl <> nil then
+ begin
+ NewSize2 := Self_.DF.fSecondControl.fBoundsRect.Bottom
+ - Self_.DF.fSecondControl.fBoundsRect.Top;
+ if Self_.DF.fSecondControl.FAlign = caClient then
+ NewSize2 := Self_.DF.fSplitStartPos2.y
+ - (MousePos.y - Self_.DF.fSplitStartPos.y)* M
+ - Self_.fParent.fMargin * 4;
+ end;
+ end else
+ begin
+ NewSize1 := (MousePos.x - Self_.DF.fSplitStartPos.x)* M
+ + Self_.DF.fSplitStartSize;
+ NewSize2 := Self_.fParent.ClientWidth - NewSize1
+ - Self_.fBoundsRect.Right + Self_.fBoundsRect.Left
+ - Self_.fParent.fMargin * 4;
+ if Self_.DF.fSecondControl <> nil then
+ begin
+ NewSize2 := Self_.DF.fSecondControl.fBoundsRect.Right
+ - Self_.DF.fSecondControl.fBoundsRect.Left;
+ if Self_.DF.fSecondControl.FAlign = caClient then
+ NewSize2 := Self_.DF.fSplitStartPos2.x
+ - (MousePos.x - Self_.DF.fSplitStartPos.x)* M
+ - Self_.fParent.Margin * 4;
+ end;
+ end;
+ if (NewSize1 < Self_.DF.fSplitMinSize1) then
+ begin
+ Dec( NewSize2, Self_.DF.fSplitMinSize1 - NewSize1 );
+ NewSize1 := Self_.DF.fSplitMinSize1;
+ end;
+ if (NewSize2 < Self_.DF.fSplitMinSize2) then
+ begin
+ Dec( NewSize1, Self_.DF.fSplitMinSize2 - NewSize2 );
+ NewSize2 := Self_.DF.fSplitMinSize2;
+ end;
+ if NewSize1 < Self_.DF.fSplitMinSize1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>}
+ if NewSize2 < Self_.DF.fSplitMinSize2 then Exit; {>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnSplit ) then
+ {$ENDIF}
+ if not Self_.EV.fOnSplit( Self_, NewSize1, NewSize2 ) then Exit; {>>}
+ R := Prev.BoundsRect;
+ case Self_.FAlign of
+ caTop: R.Bottom := R.Top + NewSize1;
+ caBottom: R.Top := R.Bottom - NewSize1;
+ caRight: R.Left := R.Right - NewSize1;
+ else R.Right := R.Left + NewSize1;
+ end;
+ Prev.BoundsRect := R;
+ {$IFDEF OLD_ALIGN}
+ Global_Align( Self_.fParent );
+ {$ELSE NEW_ALIGN}
+ Global_Align( Self_ );
+ {$ENDIF}
+ end;
+end;
+{$ENDIF}
+
+const
+ chkLeft=2;
+ chkTop=4;
+ chkRight=8;
+ chkBott=16;
+
+{$DEFINE USE!_ASM_DODRAG}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function WndProcSplitter( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var I: Integer;
+ Prev: PControl;
+
+ procedure FinDrag;
+ begin
+ KillTimer( Self_.fHandle, $7B );
+ {$IFDEF USE_FLAGS} exclude( Self_.fFlagsG6, G6_Dragging );
+ {$ELSE} Self_.fDragging := False; {$ENDIF}
+ ReleaseCapture;
+ end;
+begin
+ case Msg.message of
+ WM_NCHITTEST:
+ begin
+ Rslt := DefWindowProc( Self_.fHandle, Msg.message, Msg.wParam, Msg.lParam );
+ if Rslt > 0 then
+ Rslt := HTCLIENT;
+ Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ WM_MOUSEMOVE:
+ begin
+ Windows.SetCursor( Self_.fCursor );
+ DoDrag( Self_, False );
+ end;
+ WM_LBUTTONDOWN:
+ begin
+ if Self_.fParent <> nil then
+ begin
+ I := Self_.fParent.fChildren.IndexOf( Self_ );
+ Prev := Self_;
+ if I > 0 then
+ Prev := Self_.FParent.fChildren.Items[ I - 1 ];
+ if Self_.fAlign in [ caTop, caBottom ] then
+ Self_.DF.fSplitStartSize := Prev.Height
+ else
+ Self_.DF.fSplitStartSize := Prev.Width;
+ if Self_.DF.fSecondControl <> nil then
+ 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}
+ {$IFDEF USE_FLAGS} Include( Self_.fFlagsG6, G6_Dragging );
+ {$ELSE} Self_.fDragging := True; {$ENDIF}
+ SetTimer( Self_.fHandle, $7B, 100, nil );
+ GetCursorPos( Self_.DF.fSplitStartPos );
+ end;
+ end;
+ WM_LBUTTONUP:
+ begin
+ DoDrag( Self_, False );
+ FinDrag;
+ end;
+ WM_TIMER:
+ if {$IFDEF USE_FLAGS} (G6_Dragging in Self_.fFlagsG6)
+ {$ELSE} Self_.fDragging {$ENDIF}
+ and (GetAsyncKeyState( VK_ESCAPE ) < 0) then
+ begin
+ DoDrag( Self_, True );
+ FinDrag;
+ end;
+ end;
+ Result := False;
+end;
+{$ENDIF PAS_VERSION}
+
+function NewSplitter( AParent: PControl; MinSizePrev, MinSizeNext: Integer ): PControl;
+begin
+ Result := NewSplitterEx( AParent, MinSizePrev, MinSizeNext, esLowered );
+end;
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;
+ EdgeStyle: TEdgeStyle ): PControl;
+begin
+ new( Result, CreateSplitter( AParent, MinSizePrev, MinSizeNext, EdgeStyle ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:SplitterEx';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;
+ EdgeStyle: TEdgeStyle ): PControl;
+var PrevCtrl: PControl;
+ Sz0: Integer;
+begin
+ Result := NewPanel( AParent, EdgeStyle );
+ Result.DF.fSplitMinSize1 := MinSizePrev;
+ Result.DF.fSplitMinSize2 := MinSizeNext;
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG5, G5_IsSplitter );
+ {$ELSE} Result.fIsSplitter := TRUE; {$ENDIF}
+ Sz0 := 4;
+ with Result.fBoundsRect do
+ begin
+ Right := Left + Sz0;
+ Bottom := Top + Sz0;
+ end;
+ if AParent <> nil then
+ begin
+ if AParent.fChildren.fCount > 1 then
+ begin
+ PrevCtrl := AParent.fChildren.Items[ AParent.fChildren.fCount - 2 ];
+ case PrevCtrl.FAlign of
+ caLeft, caRight:
+ begin
+ Result.fCursor := LoadCursor( 0, IDC_SIZEWE );
+ end;
+ caTop, caBottom:
+ begin
+ Result.fCursor := LoadCursor( 0, IDC_SIZENS );
+ end;
+ end;
+ Result.Align := PrevCtrl.FAlign;
+ end;
+ end;
+ Result.AttachProc( WndProcSplitter );
+{$IFDEF GRAPHCTL_XPSTYLES}
+ Attach_WM_THEMECHANGED(Result, XP_Themes_For_Splitter);
+{$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+{$IFDEF USE_MDI}
+//===================== MDI client window control =============//
+
+procedure DestroyMDIChildren( Form: PControl );
+var MDIClient: PControl;
+ I: Integer;
+ Ch: PControl;
+ MDIChildren: PList;
+begin
+ //MDIClient := Form.MDIClient;
+ MDIClient := nil;
+ for I := 0 to Form.ChildCount-1 do
+ begin
+ Ch := Form.Children[I];
+ if Ch.PropInt[ MDI_CHLDRN ] <> 0 then
+ begin
+ MDIClient := Ch;
+ break;
+ end;
+ end;
+ if MDIClient = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ MDIClient.fAnchors := MDIClient.fAnchors or MDI_DESTROYING;
+ MDIChildren := Pointer( MDIClient.PropInt[ MDI_CHLDRN ] );
+ if MDIChildren <> nil then
+ for I := MDIChildren.Count - 1 downto 0 do
+ begin
+ Ch := MDIChildren.Items[ I ];
+ if Ch.fHandle <> 0 then
+ MDIClient.Perform( WM_MDIDESTROY, Ch.fHandle, 0 );
+ end;
+ MDIChildren.Free;
+ MDIClient.PropInt[ MDI_CHLDRN ] := 0;
+ if Form.fMenu <> 0 then
+ begin
+ MDIClient.Perform( WM_MDISETMENU, 0, 0 );
+ MDIClient.Perform( WM_MDIREFRESHMENU, 0, 0 );
+ DrawMenuBar( Form.fHandle );
+ Form.fMenuObj.Free;
+ Form.fMenuObj := nil;
+ end;
+ MDIClient.Free;
+end;
+
+function ProcMDIAccel( Applet: PControl; var Msg: TMsg ): Boolean;
+var Form: PControl;
+begin
+ Result := FALSE;
+ if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
+ begin
+ Form := Applet.ActiveControl;
+ if Form <> nil then
+ begin
+ if Form.IsMDIChild then
+ Form := Form.Parent;
+ Form := Form.ParentForm;
+ if (Form <> nil) and (Form.MDIClient <> nil) then
+ Result := TranslateMDISysAccel( Form.MDIClient.fHandle,
+ Windows.TMsg(Msg) );
+ end;
+ end;
+end;
+
+function CallDefFrameProc( Wnd: HWnd; Msg: Integer; wParam, lParam: Integer ): Integer;
+stdcall;
+var Form, MDIClient: PControl;
+begin
+ {$IFDEF USE_PROP}
+ Form := Pointer( GetProp( Wnd, ID_SELF ) );
+ {$ELSE}
+ Form := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
+ {$ENDIF}
+ if Form <> nil then
+ Form := Form.ParentForm;
+ MDIClient := Form.MDIClient;
+ if (Form <> nil) and (MDIClient <> nil) then
+ Result := DefFrameProc( Wnd, MDIClient.fHandle, Msg, wParam, lParam )
+ else
+ Result := DefWindowProc( Wnd, Msg, wParam, lParam );
+end;
+
+function WndFuncMDIClient( Wnd: HWnd; Msg, wParam, lParam: Integer ): Integer;
+stdcall;
+var C: PControl;
+ M: TMsg;
+begin
+ {$IFDEF USE_PROP}
+ C := Pointer( GetProp( Wnd, ID_SELF ) );
+ {$ELSE}
+ C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
+ {$ENDIF}
+ if C <> nil then
+ begin
+ M.hwnd := Wnd;
+ M.message := Msg;
+ M.wParam := wParam;
+ M.lParam := lParam;
+ Result := C.WndProc( M );
+ end
+ else
+ Result := DefWindowProc( Wnd, Msg, wParam, lParam );
+end;
+
+function ShowMDIClientEdge( MDIClient: PControl ): Boolean;
+var ShowEdge: Boolean;
+ I: Integer;
+ Ch: PControl;
+ ExStyle: Integer;
+ MDIChildren: PList;
+begin
+ Result := FALSE;
+ ShowEdge := TRUE;
+ MDIChildren := Pointer( MDIClient.PropInt[ MDI_CHLDRN ] );
+ if MDIChildren.Count > 0 then
+ for I := 0 to MDIChildren.Count-1 do
+ begin
+ Ch := MDIChildren.Items[ I ];
+ if IsZoomed( Ch.fHandle ) then
+ begin
+ ShowEdge := FALSE;
+ break;
+ end;
+ end;
+ ExStyle := MDIClient.ExStyle;
+ if ShowEdge then
+ if ExStyle and WS_EX_CLIENTEDGE = 0 then
+ ExStyle := ExStyle or WS_EX_CLIENTEDGE
+ else Exit {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ else if ExStyle and WS_EX_CLIENTEDGE <> 0 then
+ ExStyle := ExStyle and not WS_EX_CLIENTEDGE
+ else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ MDIClient.ExStyle := ExStyle;
+ Result := TRUE;
+end;
+
+function WndProcMDIClient( MDIClient: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := FALSE;
+ if MDIClient.fAnchors and MDI_DESTROYING = 0 then
+ case Msg.message of
+ $3f:
+ begin
+ PostMessage( MDIClient.fHandle, CM_MDIClientShowEdge, 0, 0 );
+ end;
+ CM_MDIClientShowEdge:
+ begin
+ ShowMDIClientEdge( MDIClient );
+ end;
+ WM_NCHITTEST: // not necessary though
+ begin
+ Rslt := DefWindowProc( MDIClient.fHandle, WM_NCHITTEST, Msg.wParam, Msg.lParam );
+ if Rslt = HTCLIENT then Rslt := HTTRANSPARENT;
+ end;
+ WM_WINDOWPOSCHANGING:
+ begin
+ MDIClient.Perform( WM_SETREDRAW, 0, 0 );
+ end;
+ WM_WINDOWPOSCHANGED:
+ begin
+ Global_Align( {$IFDEF OLD_ALIGN}MDIClient.Parent{$ELSE}MDIClient{$ENDIF} );
+ MDIClient.Invalidate;
+ MDIClient.Parent.Invalidate;
+ MDIClient.Perform( WM_SETREDRAW, 1, 0 );
+ PostMessage( MDIClient.fHandle, CM_INVALIDATE, 0, 0 );
+ end;
+ CM_INVALIDATE:
+ begin
+ MDIClient.InvalidateNC( TRUE );
+ MDIClient.InvalidateEx;
+ end;
+ WM_DESTROY:
+ begin
+ MDIClient.FParent.fMDIClient := nil;
+ end;
+ end;
+end;
+
+// function added by Thaddy de Koning to fix MDI behaviour
+function WndProcParentNotifyMouseLDown( Sender: PControl; var Msg: TMsg;
+var Rslt: Integer ): Boolean;
+begin
+ Result := FALSE;
+ if (Sender.IsMDIChild) and (Msg.message = WM_PARENTNOTIFY) and
+ (LOWORD(msg.wparam)=WM_LBUTTONDOWN) then
+ BringWindowToTop( Sender.Handle );
+end;
+
+function NewMDIClient( AParent: PControl; WindowMenu: THandle ): PControl;
+var F: PControl;
+ CCS: TClientCreateStruct;
+ PrntWin: HWnd;
+begin
+ PrntWin := 0;
+ if AParent <> nil then
+ begin
+ F := AParent.ParentForm;
+ if F <> nil then
+ begin
+ F.Add2AutoFreeEx( TObjectMethod( MakeMethod( F, @ DestroyMDIChildren ) ) );
+ F.GetWindowHandle; // must be created before MDI client creation
+ F.fDefWndProc := @CallDefFrameProc;
+ end;
+ PrntWin := AParent.GetWindowHandle;
+ end;
+ Applet.PP.fExMsgProc := ProcMDIAccel;
+ Result := _NewControl( AParent, 'MDICLIENT',
+ WS_CHILD or WS_CLIPCHILDREN or WS_VSCROLL or WS_HSCROLL or
+ WS_VISIBLE or WS_TABSTOP or MDIS_ALLCHILDSTYLES, TRUE,
+ {$IFDEF PACK_COMMANDACTIONS} PAnsiChar(OTHER_ACTIONS)
+ {$ELSE} nil {$ENDIF} );
+ AParent.fMDIClient := Result;
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:MDIClient';
+ {$ENDIF}
+ Result.fExStyle := WS_EX_CLIENTEDGE;
+
+ CCS.hWindowMenu := WindowMenu;
+ CCS.idFirstChild := $FF00;
+ Result.fHandle := CreateWindowEx( WS_EX_CLIENTEDGE, 'MDICLIENT', nil,
+ WS_CHILD or WS_CLIPCHILDREN or WS_VSCROLL or WS_HSCROLL or
+ WS_VISIBLE or WS_TABSTOP,
+ 0, 0, 0, 0, PrntWin, 0, hInstance, @ CCS );
+ Result.fDefWndProc := Pointer( GetWindowLong( Result.fHandle, GWL_WNDPROC ) );
+ SetWindowLong( Result.fHandle, GWL_WNDPROC, Integer( @WndFuncMDIClient ) );
+ Result.PropInt[ MDI_CHLDRN ] := Integer( NewList );
+ {$IFDEF USE_PROP}
+ SetProp( Result.fHandle, ID_SELF, Integer( Result ) );
+ {$ELSE}
+ SetWindowLong( Result.fHandle, GWL_USERDATA, Integer( Result ) );
+ {$ENDIF}
+ Result.AttachProc( WndProcMDIClient );
+ Result.GetWindowHandle;
+
+ Applet.AttachProc( WndProcParentNotifyMouseLDown );
+end;
+
+//===================== MDI child window object ==============//
+function MDIChildFunc( Wnd: HWnd; Msg: DWord; wParam, lParam: Integer ): Integer;
+stdcall;
+var C: PControl;
+ M: TMsg;
+begin
+ {$IFDEF USE_PROP}
+ C := Pointer( GetProp( Wnd, ID_SELF ) );
+ {$ELSE}
+ C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
+ {$ENDIF}
+ if C <> nil then
+ begin
+ M.hwnd := Wnd;
+ M.message := Msg;
+ M.wParam := wParam;
+ M.lParam := lParam;
+ Result := C.WndProc( M );
+ end
+ else
+ Result := DefMDIChildProc( Wnd, Msg, wParam, lParam );
+end;
+
+function Pass2DefMDIChildProc( Sender_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := FALSE;
+ if Sender_ = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Sender_.fParent = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if {$IFDEF USE_FLAGS} G2_Destroying in Sender_.fParent.fFlagsG2
+ {$ELSE} Sender_.fParent.fDestroying {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>}
+ if (Msg.message = WM_SYSCOMMAND) or (Msg.message = WM_CHILDACTIVATE) or
+ (Msg.message = WM_SETFOCUS) or (Msg.message = WM_SIZE) or
+ (Msg.message = WM_MOVE) or (Msg.message = WM_MENUCHAR) or
+ (Msg.message = WM_GETMINMAXINFO) {and IsZoomed( Sender_.fHandle ) {and (Msg.hwnd = Sender_.fHandle) { -- doesn't work -- }
+ or (Msg.message = WM_PAINT)
+ then
+ begin
+ Rslt := DefMDIChildProc( Msg.hwnd, Msg.message, Msg.lParam, Msg.wParam );
+ Result := TRUE;
+ end;
+end;
+
+function WndProcMDIChild( MDIChild: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var ClientWnd: HWnd;
+ MDIClient: PControl;
+ MDIForm: PControl;
+ MDIChildren: PList;
+begin
+ Result := FALSE;
+ MDIClient := MDIChild.Parent;
+ if MDIClient = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ ClientWnd := MDIClient.fHandle;
+ if ClientWnd = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ case Msg.message of
+ WM_DESTROY:
+ begin
+ MDIChildren := Pointer( MDIClient.PropInt[ MDI_CHLDRN ] );
+ MDIChildren.Remove( MDIChild );
+ MDIForm := MDIClient.ParentForm;
+ if MDIForm <> nil then
+ if MDIForm.fHandle <> 0 then
+ DrawMenuBar( MDIForm.fHandle );
+ MDIChild.Free;
+ Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ if MDIChild.fAnchors and MDI_NOT_AVAILABLE <> 0 then
+ begin
+ MDIChild.fAnchors := MDIChild.fAnchors and not MDI_NOT_AVAILABLE;
+ MDIChild.Invalidate;
+ end;
+end;
+
+procedure CreateMDIChildExt( Sender: PControl );
+var F: PControl;
+begin
+ F := Sender.Parent;
+ if F <> nil then
+ F := F.ParentForm;
+ if F <> nil then
+ DrawMenuBar( F.fHandle );
+end;
+
+var mdi_child_id: Integer = $FF00;
+
+function NewMDIChild( AParent: PControl; const ACaption: KOLString ): PControl;
+var MDIClient: PControl;
+ MDIChildren: PList;
+ i: Integer;
+begin
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( (AParent <> nil) and (AParent.ParentForm <> nil) and
+ (AParent.ParentForm.MDIClient <> nil), 'Error creating MDI child' );
+ {$ENDIF KOL_ASSERTIONS}
+ MDIClient := AParent.ParentForm.MDIClient;
+ MDIChildren := Pointer( MDIClient.PropInt[ MDI_CHLDRN ] );
+
+ for i := 0 to MDIChildren.Count-1 do
+ begin
+ Result := MDIChildren.Items[i];
+ //if Result.DF.fWindowState = wsMaximized then
+ if IsZoomed( Result.fHandle ) then
+ begin
+ MDIClient.Perform( WM_MDIRESTORE, Result.fHandle, 0 );
+ end;
+ end;
+
+ Result := NewForm( MDIClient, ACaption );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:MDIChild';
+ {$ENDIF}
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG3, G3_IsMDIChild );
+ {$ELSE} Result.fIsMDIChild := TRUE; {$ENDIF}
+ Result.fMenu := mdi_child_id; // CtlIdCount;
+ Inc( mdi_child_id );
+
+ MDIChildren.Add( Result );
+ Result.fExStyle := Result.fExStyle or WS_EX_MDICHILD;
+ Result.PP.fWndFunc := @ MDIChildFunc;
+ Result.fDefWndProc := @DefMDIChildProc;
+ Result.PP.fPass2DefProc := Pass2DefMDIChildProc;
+ Result.AttachProc( WndProcMDIChild );
+
+ Result.SubClassName := 'MDI_chld';
+ Result.fAnchors := Result.fAnchors or MDI_NOT_AVAILABLE;
+ Result.PP.fCreateWndExt := CreateMDIChildExt;
+ Result.fCreateWindowProc := CreateMDIWindow;
+end;
+{$ENDIF USE_MDI}
+
+//===================== Gradient panel ========================//
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;
+begin
+ new( Result, CreateGradientPanel( AParent, Color1, Color2 ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:GradientPanel';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;
+begin
+ Result := NewLabel( AParent, '' );
+ Result.AttachProc( WndProcGradient );
+ Result.DF.fColor2 := Color2;
+ Result.DF.fColor1 := Color1;
+ with Result.fBoundsRect do
+ begin
+ Right := Left + 40;
+ Bottom := Top + 40;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;
+ Style: TGradientStyle; Layout: TGradientLayout ): PControl;
+begin
+ new( Result, CreateGradientPanelEx( AParent, Color1, Color2,
+ Style, Layout ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:GradientPanelEx';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;
+ Style: TGradientStyle; Layout: TGradientLayout ): PControl;
+begin
+ Result := NewLabel( AParent, '' );
+ Result.AttachProc( WndProcGradientEx );
+ Result.DF.fColor2 := Color2;
+ Result.DF.fColor1 := Color1;
+ Result.DF.fGradientStyle := Style;
+ Result.DF.fGradientLayout := Layout;
+ with Result.fBoundsRect do
+ begin
+ Right := Left + 40;
+ Bottom := Top + 40;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== Edit box ========================//
+
+const Editflags: array [ TEditOption ] of Integer = (
+ not (ES_AUTOHSCROLL or WS_HSCROLL),
+ not (es_AutoVScroll or WS_VSCROLL),
+ es_Lowercase, es_Multiline,
+ es_NoHideSel, es_OemConvert, es_Password, es_Readonly,
+ es_UpperCase, es_WantReturn, 0, es_Number );
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl;
+begin
+ new( Result, CreateEditbox( AParent, Options ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Editbox';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF _D3orHigher}
+function WndProcUnicodeChars( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var WStr, WW: KOLWideString;
+ RepeatCount: Integer;
+ C: KOLChar;
+begin
+ Result := FALSE;
+ if (Msg.message = WM_CHAR)
+ and (Msg.wParam >= 32)
+ {$IFDEF UNICODE_CHAR_EXTCTL}
+ and (GetKeyState(VK_CONTROL) >= 0)
+ and (GetKeyState(VK_ALT) >= 0)
+ and (GetKeyState(VK_LWIN) >= 0)
+ and (GetKeyState(VK_RWIN) >= 0)
+ {$ENDIF} then
+ begin
+ Result := TRUE;
+
+ {$IFDEF NIL_EVENTS}
+ if assigned( Sender.EV.fOnChar ) then
+ {$ENDIF}
+ begin
+ C := KOLChar( Msg.wParam );
+ Sender.EV.fOnChar( Sender, C, GetShiftState );
+ Msg.wParam := Integer( C );
+ end;
+
+ WStr := WideChar(Msg.wParam);
+ if WStr <> '' then
+ begin
+ RepeatCount := Msg.lParam and $FFFF;
+ if RepeatCount > 1 then
+ begin
+ WW := WStr[1];
+ for RepeatCount := 2 to RepeatCount do
+ WStr := WStr + WW;
+ end;
+ Sender.ReplaceSelection( KOLString( WStr ), TRUE );
+ end;
+ Rslt := 0;
+ end;
+end;
+{$ENDIF _D3orHigher}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl;
+var Flags: Integer;
+begin
+ Flags := MakeFlags( @Options, EditFlags );
+ if not(eoMultiline in Options) then
+ Flags := Flags and not(WS_HSCROLL or WS_VSCROLL);
+ Result := _NewControl( AParent, 'EDIT', WS_VISIBLE or WS_CHILD or WS_TABSTOP
+ or WS_BORDER or Flags, True,
+ {$IFDEF PACK_COMMANDACTIONS} EditActions_Packed
+ {$ELSE} @EditActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Editbox';
+ {$ENDIF}
+ Result.aAutoSzY := 6;
+ with Result.fBoundsRect do
+ begin
+ Right := Left + 100;
+ Bottom := Top + 22;
+ if eoMultiline in Options then
+ begin
+ Right := Right + 100;
+ Bottom := Top + 200;
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG5, G5_IgnoreDefault );
+ {$ELSE} Result.fIgnoreDefault := TRUE; {$ENDIF}
+ end;
+ end;
+ Result.fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ];
+ if eoMultiline in Options then
+ Result.fLookTabKeys := [ tkTab ];
+ if eoWantTab in Options then
+ exclude( Result.fLookTabKeys, tkTab );
+ {$IFDEF UNICODE_CTRLS}
+ {$IFDEF _D3orHigher}
+ Result.AttachProc( WndProcUnicodeChars );
+ {$ENDIF}
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== List box ========================//
+
+const ListFlags: array[TListOption] of Integer = (
+ LBS_DISABLENOScroll, not LBS_ExtendedSel,
+ LBS_MultiColumn or WS_HSCROLL,
+ LBS_MultiPLESel,
+ LBS_NoIntegralHeight, LBS_NoSel, LBS_Sort, LBS_USETabstops,
+ not LBS_HASSTRINGS, LBS_NODATA, LBS_OWNERDRAWFIXED,
+ LBS_OWNERDRAWVARIABLE, WS_HSCROLL );
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewListbox( AParent: PControl; Options: TListOptions ): PControl;
+begin
+ new( Result, CreateListbox( AParent, Options ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Listbox';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function NewListbox( AParent: PControl; Options: TListOptions ): PControl;
+var Flags: Integer;
+begin
+ Flags := MakeFlags( @Options, ListFlags );
+ Result := _NewControl( AParent, 'LISTBOX', WS_VISIBLE or WS_CHILD or WS_TABSTOP
+ or WS_BORDER or WS_VSCROLL
+ or LBS_NOTIFY or Flags, True,
+ {$IFDEF PACK_COMMANDACTIONS} ListActions_Packed
+ {$ELSE} @ListActions {$ENDIF} );
+ {$IFDEF PACK_COMMANDACTIONS}
+ Result.fCommandActions.aClear := ClearListbox;
+ {$ENDIF}
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Listbox';
+ {$ENDIF}
+ with Result.fBoundsRect do
+ begin
+ Right := Right + 100;
+ Bottom := Top + 200;
+ end;
+ Result.fColor := clWindow;
+ Result.fLookTabKeys := [ tkTab, tkLeftRight ];
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== Combo box ========================//
+
+{$IFNDEF USE_DROPDOWNCOUNT}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure ComboboxDropDown( Sender: PObj );
+var
+ CB: PControl;
+ IC: Integer;
+begin
+ CB := PControl( Sender );
+ IC := CB.Count;
+ if IC > 8 then IC := 8;
+ if IC < 1 then IC := 1;
+
+ SetWindowPos( CB.Handle, 0, 0, 0, CB.Width, CB.Height * (IC + 1) + 2,
+ SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_NOREDRAW +
+ SWP_HIDEWINDOW);
+
+ SetWindowPos( CB.Handle, 0, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE
+ + SWP_NOZORDER + SWP_NOACTIVATE
+ + SWP_NOREDRAW + SWP_SHOWWINDOW);
+ {$IFDEF NIL_EVENTS}
+ if assigned( CB.EV.fOnDropDown ) then
+ {$ENDIF}
+ CB.EV.fOnDropDown( CB );
+end;
+{$ENDIF PAS_VERSION}
+{$ELSE newcode}
+procedure ComboboxDropDown( Sender: PObj );
+var
+ CB: PControl;
+ Count: Integer;
+ DropDownCount: Integer;
+ ItemHeight: Integer;
+begin
+ CB := PControl(Sender);
+ Count := CB.Count;
+ DropDownCount := CB.DropDownCount; // 8;
+ if (Count > DropDownCount) then
+ Count := DropDownCount;
+ if (Count < 1) then
+ Count := 1;
+ ItemHeight := CB.Perform(CB_GETITEMHEIGHT, 0, 0);
+ SetWindowPos(
+ CB.Handle, 0, 0, 0, CB.Width, ItemHeight * Count + CB.Height + 2,
+ SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or SWP_HIDEWINDOW);
+ SetWindowPos(
+ CB.Handle, 0, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER or
+ SWP_NOACTIVATE or SWP_NOREDRAW or SWP_SHOWWINDOW);
+ {$IFDEF NIL_EVENTS}
+ if Assigned(CB.EV.fOnDropDown) then
+ {$ENDIF}
+ CB.EV.fOnDropDown(CB);
+end;
+{$ENDIF USE_DROPDOWNCOUNT}
+
+function WndFuncCombo( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
+ : Integer; stdcall;
+var Combo, Form: PControl;
+ ParentWnd : HWnd;
+ MsgStruct: TMsg;
+ PrevProc:Pointer; //********************************** Added By M.Gerasimov
+begin
+ Combo := nil;
+
+ ParentWnd := GetParent( W );
+ if ParentWnd <> 0 then
+ {$IFDEF USE_PROP}
+ Combo := Pointer( GetProp( ParentWnd, ID_SELF ) );
+ {$ELSE}
+ Combo := Pointer( GetWindowLong( ParentWnd, GWL_USERDATA ) );
+ {$ENDIF}
+
+ if (Combo <> nil) then
+ begin
+ MsgStruct.hwnd := Combo.fHandle;
+ MsgStruct.message := Msg;
+ MsgStruct.wParam := wParam;
+ MsgStruct.lParam := lParam;
+ Form := Combo.ParentForm;
+ if fGlobalProcKeybd( Combo, MsgStruct, Result ) then Exit; {>>>>>>>>>>>>>}
+ if W <> Combo.FHandle then
+ begin
+ if ( Applet <> nil )
+ {$IFDEF NIL_EVENTS} and Assigned( Applet.EV.fOnMessage ) {$ENDIF} then
+ if Applet.EV.fOnMessage( MsgStruct, Result ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if (Applet <> Form) and (Form <> nil) then
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Form.EV.fOnMessage ) then
+ {$ENDIF}
+ if Form.EV.fOnMessage( MsgStruct, Result ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if (Combo.ToBeVisible) and
+ ((Msg = WM_KEYDOWN) or (Msg = WM_KEYUP) or (Msg = WM_CHAR)) then
+ begin
+ Result := 0;
+ if (wParam = VK_TAB) then
+ begin
+ case Msg of
+ WM_KEYDOWN:
+ if {$IFDEF NIL_EVENTS} Assigned( Combo.PP.fGotoControl ) and {$ENDIF}
+ Combo.PP.fGotoControl( Combo, wParam, FALSE ) then Exit; {>>>>>>}
+ else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end
+ else
+ if (Msg = WM_CHAR) and ((wParam = VK_ESCAPE) or (wParam = VK_RETURN)) then
+ begin
+ if Combo.Perform( CB_GETDROPPEDSTATE, 0, 0 ) <> 0 then
+ begin
+ Combo.Perform( CB_SHOWDROPDOWN, 0, 0 );
+ if wParam = VK_ESCAPE then
+ Combo.Perform( CB_SETCURSEL, Combo.DF.fCurIdxAtDrop, 0 );
+ Combo.PP.fWndProcKeybd( Combo, MsgStruct, Result );
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end
+ {$IFDEF ESC_CLOSE_DIALOGS}
+ //---------------------------------Babenko Alexey--------------------------
+ else
+ if (wparam = VK_ESCAPE) then
+ if (combo.ParentForm.ExStyle and WS_EX_DLGMODALFRAME) <> 0 then begin
+ SendMessage(combo.ParentForm.Handle, WM_CLOSE, 0, 0);
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ {$ENDIF}
+ end;
+ {$IFDEF KEY_PREVIEW}
+ if {$IFDEF USE_FLAGS} not(G4_Pushed in Form.fFlagsG4)
+ {$ELSE} not Form.fKeyPreviewing {$ENDIF} then
+ begin
+ if {$IFDEF USE_FLAGS} G6_KeyPreview in Form.fFlagsG6
+ {$ELSE} Form.fKeyPreview {$ENDIF} then
+ begin
+ {$IFDEF USE_FLAGS} include( Form.fFlagsG4, G4_Pushed );
+ {$ELSE} Form.fKeyPreviewing := TRUE; {$ENDIF}
+ inc( Form.DF.FKeyPreviewCount );
+ //Form.Perform(Msg, wParam, lParam);
+ Form.PP.fWndProcKeybd( Form, MsgStruct, Result );
+ dec( Form.DF.fKeyPreviewCount );
+ if MsgStruct.wParam = 0 then
+ begin
+ Result := 0;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end;
+ {$ENDIF}
+ Combo.PP.fWndProcKeybd( Combo, MsgStruct, Result );
+ end
+ else
+ if Msg = WM_SETFOCUS then
+ begin
+ if Form <> nil then Form.DF.fCurrentControl := Combo;
+ end;
+ MsgStruct.hwnd := W;
+//********************************************************* Added By M.Gerasimov
+ PrevProc:=Pointer(GetProp( W, ID_PREVPROC ));
+ if PrevProc <> Nil then
+ Result := CallWindowProc( PrevProc , W, MsgStruct.message,
+ MsgStruct.wParam, MsgStruct.lParam )
+ else
+ Result:=0;
+//*********************************************************
+ end
+ else
+ Result := DefWindowProc( W, Msg, wParam, lParam );
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+procedure CreateComboboxWnd( Combo: PControl );
+var W : HWND;
+ PrevProc: DWORD;
+begin
+ W := GetWindow( Combo.fHandle, GW_CHILD );
+ {if W <> 0 then
+ W := GetWindow( W, GW_HWNDNEXT );}
+ while W <> 0 do
+ begin
+ PrevProc :=
+ SetWindowLong( W, GWL_WNDPROC, Longint( @WndFuncCombo ) );
+ SetProp( W, ID_PREVPROC, PrevProc ); //
+ W := GetWindow( W, GW_HWNDNEXT );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure RemoveChldPrevProc( fHandle: HWnd );
+var Chld: HWnd;
+begin
+ Chld := GetWindow( fHandle, GW_CHILD );
+ while Chld <> 0 do
+ begin
+ if GetProp( Chld, ID_PREVPROC ) <> 0 then
+ RemoveProp(Chld, ID_PREVPROC);
+ Chld := GetWindow( Chld, GW_HWNDNEXT );
+ end;
+end;
+
+function WndProcCombo( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+{$IFDEF UNICODE_CTRLS}
+var s: KOLString;
+ w: PWideChar;
+ L: Integer;
+{$ENDIF}
+begin
+ Result := FALSE;
+ if (Msg.message >= WM_CTLCOLORMSGBOX) and (Msg.message <= WM_CTLCOLORSTATIC) then
+ begin
+ Rslt := Sender.Perform( Msg.message + CN_BASE, Msg.wParam, Msg.lParam );
+ Result := TRUE;
+ end
+ else
+ if (Msg.message >= CN_CTLCOLORMSGBOX) and (Msg.message <= CN_CTLCOLORSTATIC) then
+ begin
+ if {$IFDEF USE_FLAGS} G2_Transparent in Sender.fFlagsG2
+ {$ELSE} Sender.fTransparent {$ENDIF} then
+ case Msg.message of
+ CN_CTLCOLORLISTBOX:
+ begin
+ SetBkMode( Msg.wParam, Windows.OPAQUE );
+ SetBkColor(Msg.WParam, Color2RGB( Sender.fColor ) );
+ Rslt := Global_GetCtlBrushHandle( Sender );
+ Result := TRUE;
+ end;
+ end;
+ end
+ else
+ if (Msg.message = CM_COMMAND) and Sender.ToBeVisible then
+ begin
+ case HiWord( Msg.wParam ) of
+ CBN_DROPDOWN:
+ begin
+ Sender.DF.fCurIdxAtDrop := Sender.CurIndex;
+ //Sender.fDropDownProc( Sender );
+ ComboboxDropDown( Sender );
+ end;
+ CBN_CLOSEUP:
+ begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnCloseUp ) then
+ {$ENDIF}
+ Sender.EV.fOnCloseUp( Sender );
+ end;
+ CBN_SELCHANGE:
+ begin
+ PostMessage( Sender.fHandle, CM_COMMAND, CM_CBN_SELCHANGE shl 16, 0 );
+ end;
+ end;
+ end
+ else
+ if Msg.message = WM_DESTROY then
+ RemoveChldPrevProc( Sender.Handle )
+ {$IFDEF UNICODE_CTRLS}
+ else
+ if (Msg.message = CB_INSERTSTRING)
+ or (Msg.message = CB_ADDSTRING) then
+ begin
+ if {$IFDEF USE_FLAGS} not(G5_IsButton in Sender.fFlagsG5)
+ {$ELSE} not Sender.fIsButton {$ENDIF} then
+ begin
+ {$IFDEF USE_FLAGS} Include( Sender.fFlagsG5, G5_IsButton );
+ {$ELSE} Sender.fIsButton := TRUE; {$ENDIF}
+ w := Pointer( Msg.lParam );
+ L := WStrLen( w );
+ SetLength( s, L );
+ move( w^, s[1], L * SizeOf(KOLChar) );
+ Rslt := SendMessageW( Msg.hwnd, Msg.message, Msg.wParam,
+ Integer( @s[1] ) );
+ Result := TRUE;
+ {$IFDEF USE_FLAGS} Exclude( Sender.fFlagsG5, G5_IsButton );
+ {$ELSE} Sender.fIsButton := FALSE; {$ENDIF}
+ end;
+ end;
+ {$ENDIF}
+end;
+
+const ComboFlags: array[ TComboOption ] of Integer = (
+ CBS_DROPDOWNLIST, not CBS_AUTOHScroll,
+ CBS_DISABLENOSCROLL, CBS_LowerCase, CBS_NoIntegralHeight,
+ CBS_OemConvert, CBS_Sort, CBS_UpperCase,
+ CBS_OWNERDRAWFIXED, CBS_OWNERDRAWVARIABLE, CBS_SIMPLE );
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;
+begin
+ new( Result, CreateCombobox( AParent, Options ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Combobox';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;
+var Flags: Integer;
+begin
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ {$IFDEF UNICODE_CTRLS}
+ InitCommonControls;
+ {$ENDIF}
+ {$ENDIF}
+ Flags := MakeFlags( @Options, ComboFlags );
+ if not LongBool( Flags and CBS_SIMPLE ) then
+ Flags := Flags or CBS_DROPDOWN;
+ Result := _NewControl( AParent, 'COMBOBOX',
+ WS_VISIBLE
+ or WS_CHILD
+ or WS_VSCROLL
+ or CBS_HASSTRINGS or WS_TABSTOP
+ or Flags
+ ,True,
+ {$IFDEF PACK_COMMANDACTIONS} ComboActions_Packed
+ {$ELSE} @ComboActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Combobox';
+ {$ENDIF}
+ {$IFDEF PACK_COMMANDACTIONS}
+ Result.fCommandActions.aClear := @ClearCombobox;
+ {$ENDIF}
+ Result.aAutoSzY := 6;
+ Result.PP.fCreateWndExt := CreateComboboxWnd;
+ Result.fClsStyle := Result.fClsStyle or CS_DBLCLKS;
+ with Result.fBoundsRect do
+ begin
+ Right := Left + 100;
+ Bottom := Top + 22;
+ end;
+ Result.fLookTabKeys := [ tkTab ];
+ if coReadOnly in Options then
+ Result.fLookTabKeys := [ tkTab, tkLeftRight ];
+ Result.AttachProc( @ WndProcCombo );
+ {$IFDEF USE_DROPDOWNCOUNT}
+ Result.DropDownCount := 8;
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+{$IFDEF ASM_TLIST}
+function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+asm
+ PUSH ESI
+ CMP word ptr [EDX].TMsg.message, WM_SIZE
+ JNZ @@exit
+
+ MOV ESI, [EAX].TControl.fChildren
+ MOV ECX, [ESI].TList.fCount
+ JECXZ @@exit
+ MOV ESI, [ESI].TList.fItems
+@@loo: PUSH ECX
+ LODSD
+ PUSH EAX
+ PUSH EAX
+ PUSH CM_SIZE
+ PUSH EAX
+ CALL TControl.Perform
+ POP ECX
+ LOOP @@loo
+
+@@exit: XOR EAX, EAX
+ POP ESI
+end;
+{$ELSE PAS_VERSION} //Pascal
+function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var I: Integer;
+ C: PControl;
+begin
+ if Msg.message = WM_SIZE then
+ begin
+ for I:= 0 to Self_.fChildren.fCount - 1 do
+ begin
+ C := Self_.fChildren.Items[ I ];
+ C.Perform( CM_SIZE, 0, 0 );
+ end;
+ end;
+ Result := False; // don't stop further processing
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function WndProcParentResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := False;
+ case Msg.message of
+ CM_SIZE:
+ begin
+ Self_.Perform( WM_SIZE, 0, 0 );
+ Self_.Invalidate;
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure InitCommonControlCommonNotify( Ctrl: PControl );
+var AParent: PControl;
+begin
+ {$IFDEF USE_FLAGS} include( Ctrl.fFlagsG5, G5_IsCommonCtl );
+ {$ELSE} Ctrl.fIsCommonControl := True; {$ENDIF}
+ AParent := Ctrl.Parent;
+ if AParent <> nil then
+ begin
+ Ctrl.AttachProc( WndProcCommonNotify );
+ AParent.AttachProc( WndProcNotify );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure InitCommonControlSizeNotify( Ctrl: PControl );
+var AParent: PControl;
+begin
+ AParent := Ctrl.Parent;
+ if AParent <> nil then
+ begin
+ Ctrl.AttachProc( WndProcParentResize );
+ AParent.AttachProc( WndProcResize );
+ end;
+end;
+
+function _NewCommonControl( AParent: PControl; ClassName: PKOLChar; Style: DWORD;
+ Ctl3D: Boolean; Actions: TCommandActionsParam ): PControl;
+begin
+ {*************} DoInitCommonControls( ICC_WIN95_CLASSES );
+ Result := _NewControl( AParent, ClassName, Style, Ctl3D, Actions );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:CommonControl';
+ {$ENDIF}
+ InitCommonControlCommonNotify( Result );
+end;
+
+//==================== Progress bar ======================//
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewProgressbar( AParent: PControl ): PControl;
+begin
+ new( Result, CreateProgressbar( AParent ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Progressbar';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewProgressbar( AParent: PControl ): PControl;
+begin
+ Result := _NewCommonControl( AParent, PROGRESS_CLASS,
+ WS_CHILD or WS_VISIBLE, True,
+ {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( PROGRESS_ACTIONS )
+ {$ELSE} nil {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:ProgressBar';
+ {$ENDIF}
+ with Result.fBoundsRect do
+ begin
+ Right := Left + 300;
+ Bottom := Top + 20;
+ end;
+ Result.fMenu := 0;
+ Result.fTextColor := clHighlight;
+ Result.fCommandActions.aSetBkColor := PBM_SETBKCOLOR;
+ //Result.fNCDestroyed := TRUE; // do not call DestroyWindow!
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;
+begin
+ new( Result, CreateProgressbarEx( AParent, Options ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:ProgressBarEx';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;
+const ProgressBarFlags: array[ TProgressbarOption ] of Integer =
+ (PBS_VERTICAL, PBS_SMOOTH );
+begin
+ Result := NewProgressbar( AParent );
+ Result.fStyle.Value := Result.fStyle.Value or
+ DWORD( MakeFlags( @Options, ProgressBarFlags ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== List view ========================//
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var NMhdr: PNMHdr;
+ Child: PControl;
+begin
+ Result := False;
+ if Msg.message = WM_NOTIFY then
+ begin
+ NMhdr := Pointer( Msg.lParam );
+ {$IFDEF USE_PROP}
+ Child := Pointer( GetProp( NMhdr.hwndFrom, ID_SELF ) );
+ {$ELSE}
+ Child := Pointer( GetWindowLong( NMhdr.hwndFrom, GWL_USERDATA ) );
+ {$ENDIF}
+ if (Child <> nil)
+ and (Child <> Self_) //+ by Galkov, Jun-2009
+ then
+ begin
+ Msg.hwnd := Child.fHandle;
+ Result := EnumDynHandlers( Child, Msg, Rslt );
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var NMhdr: PNMHdr;
+begin
+ Result := False;
+ if Msg.message = WM_NOTIFY then
+ begin
+ NMHdr := Pointer( Msg.lParam );
+ case NMHdr.code of
+ NM_RCLICK,
+ NM_CLICK: {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnClick ) then
+ {$ENDIF}
+ begin
+ {$IFDEF USE_FLAGS}
+ if NMHdr.code = NM_RCLICK then
+ include( Self_.fFlagsG6, G6_RightClick )
+ else exclude( Self_.fFlagsG6, G6_RightClick );
+ {$ELSE} Self_.fRightClick := NMHdr.code=NM_RCLICK; {$ENDIF}
+ Self_.EV.fOnClick( Self_ );
+ end;
+ NM_KILLFOCUS: {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnLeave ) then
+ {$ENDIF}
+ Self_.EV.fOnLeave( Self_ );
+ NM_RETURN,
+ NM_SETFOCUS: {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnEnter ) then
+ {$ENDIF}
+ Self_.EV.fOnEnter( Self_ );
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+const ListViewStyles: array[ TListViewStyle ] of DWORD = ( LVS_ICON, LVS_SMALLICON,
+ LVS_LIST, LVS_REPORT, LVS_REPORT or LVS_NOCOLUMNHEADER );
+ ListViewFlags: array[ TListViewOption ] of Integer = ( LVS_ALIGNLEFT, LVS_AUTOARRANGE,
+ $400 {LVS_BUTTON}, LVS_EDITLABELS, LVS_NOLABELWRAP,
+ LVS_NOSCROLL, LVS_NOSORTHEADER,
+ not LVS_SHOWSELALWAYS, not LVS_SINGLESEL, LVS_SORTASCENDING,
+ LVS_SORTDESCENDING, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ LVS_OWNERDATA, LVS_OWNERDRAWFIXED );
+
+ ListViewExFlags: array[ TListViewOption ] of Integer = ( 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, LVS_EX_GRIDLINES,
+ LVS_EX_SUBITEMIMAGES, LVS_EX_CHECKBOXES, LVS_EX_TRACKSELECT,
+ LVS_EX_HEADERDRAGDROP, LVS_EX_FULLROWSELECT, LVS_EX_ONECLICKACTIVATE,
+ LVS_EX_TWOCLICKACTIVATE, LVS_EX_FLATSB, LVS_EX_REGIONAL,
+ LVS_EX_INFOTIP, LVS_EX_UNDERLINEHOT, LVS_EX_MULTIWORKAREAS, 0, 0 );
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure ApplyImageLists2Control( Sender: PControl );
+var IL: PImageList;
+begin
+ if Sender.fCommandActions.aSetImgList = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>}
+ IL := Sender.ImageListNormal;
+ if IL <> nil then
+ Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_NORMAL, IL.Handle );
+ IL := Sender.ImageListSmall;
+ if IL <> nil then
+ Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_SMALL, IL.Handle );
+ IL := Sender.ImageListState;
+ if IL <> nil then
+ Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_STATE, IL.Handle );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure ApplyImageLists2ListView( Sender: PControl );
+var Flags: DWORD;
+begin
+ Flags := MakeFlags( @Sender.DF.fLVOptions, ListViewFlags );
+ Sender.Style := Sender.Style and not $403F//$4FFC
+ or Flags or ListViewStyles[ Sender.DF.fLVStyle ];
+ Flags := MakeFlags( @Sender.DF.fLVOptions, ListViewExFlags );
+ Sender.Perform( LVM_SETEXTENDEDLISTVIEWSTYLE, $3FFF, Flags );
+ ApplyImageLists2Control( Sender );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;
+ ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;
+begin
+ new( Result, CreateListView( AParent, Style, Options, ImageListSmall,
+ ImageListNormal, ImageListState ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:ListView';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;
+ ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;
+begin
+ Result := _NewCommonControl( AParent, WC_LISTVIEW, ListViewStyles[ Style ] or
+ LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE or WS_TABSTOP or WS_CLIPCHILDREN,
+ True, {$IFDEF PACK_COMMANDACTIONS} ListViewActions_Packed
+ {$ELSE} @ListViewActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:ListView';
+ {$ENDIF}
+ {$IFDEF PACK_COMMANDACTIONS}
+ Result.fCommandActions.aClear := @ClearListView;
+ {$ENDIF}
+ Result.DF.fLVOptions := Options;
+ Result.DF.fLVStyle := Style;
+ Result.fStyle.Value := Result.fStyle.Value and not LVS_TYPESTYLEMASK
+ or DWORD( MakeFlags( @Options, ListViewFlags ) );
+ Result.PP.fCreateWndExt := ApplyImageLists2ListView;
+ with Result.fBoundsRect do
+ begin
+ Right := Left + 200;
+ Bottom := Top + 150;
+ end;
+ Result.ImageListSmall := ImageListSmall;
+ Result.ImageListNormal := ImageListNormal;
+ Result.ImageListState := ImageListState;
+ Result.DF.fLVTextBkColor := clWindow;
+ Result.fLookTabKeys := [ tkTab ];
+ //Result.fMargin := 0;
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== Tree view ========================//
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var NM: PNMTreeView;
+ DI: PTVDispInfo;
+ P: TPoint;
+ S: KOL_String;
+begin
+ if Msg.message = WM_NOTIFY then
+ begin
+ NM := Pointer( Msg.lParam );
+ case NM.hdr.code of
+ NM_RCLICK:
+ begin
+ GetCursorPos( P );
+ P := Self_.Screen2Client( P );
+ Self_.PostMsg( WM_RBUTTONUP, MK_RBUTTON or GetShiftState,
+ (P.x and $FFFF) or (P.y shl 16) );
+ end;
+ TVN_BEGINDRAG {$IFDEF TV_DRAG_RBUTTON}, TVN_BEGINRDRAG{$ENDIF}:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnTVBeginDrag ) then
+ {$ENDIF}
+ Self_.EV.fOnTVBeginDrag( Self_, NM.itemNew.hItem );
+ TVN_BEGINLABELEDIT:
+ begin
+ if {$IFDEF USE_FLAGS} G6_Dragging in Self_.fFlagsG6
+ {$ELSE} Self_.fDragging {$ENDIF} then
+ begin
+ Rslt := 1; // do not allow edit while dragging
+ Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ DI := Pointer( NM );
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnTVBeginEdit ) then
+ {$ENDIF}
+ begin
+ Rslt := Integer( not Self_.EV.fOnTVBeginEdit( Self_, DI.item.hItem ) );
+ Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ TVN_ENDLABELEDIT:
+ begin
+ DI := Pointer( NM );
+ if Assigned( Self_.EV.fOnTVEndEdit ) then
+ begin
+ S := DI.item.pszText;
+ if (DI.item.pszText = nil) then
+ begin
+ Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Rslt := Integer(
+ Self_.EV.fOnTVEndEdit( Self_, DI.item.hItem, S ) );
+ end
+ else
+ Rslt := 1;
+ Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ TVN_ITEMEXPANDING:
+ begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnTVExpanding ) then
+ {$ENDIF}
+ begin
+ Rslt := Integer( Self_.EV.fOnTVExpanding( Self_, NM.itemNew.hItem,
+ NM.action = TVE_EXPAND ) );
+ //Result := TRUE; //Exit;
+ end;
+ end;
+ TVN_ITEMEXPANDED:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnTVExpanded ) then
+ {$ENDIF}
+ Self_.EV.fOnTVExpanded( Self_, NM.itemNew.hItem, NM.action=TVE_EXPAND );
+ TVN_SELCHANGING:
+ begin //------------------ TVN_SELCHANGING by Sergey Shisminzev
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnTVSelChanging ) then
+ {$ENDIF}
+ begin
+ Rslt := Integer( not Self_.EV.fOnTVSelChanging( Self_, NM.itemOld.hItem, NM.itemNew.hItem ) );
+ //Result := TRUE; //Exit;
+ end;
+ end; //----------------------------------------
+ TVN_SELCHANGED:
+ Self_.DoSelChange;
+ end;
+ end;
+ Result := False;
+end;
+{$ENDIF PAS_VERSION}
+
+function ProcTVDeleteItem( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var NM: PNMTreeView;
+begin
+ if Msg.message = WM_NOTIFY then
+ begin
+ NM := Pointer( Msg.lParam );
+ case NM.hdr.code of
+ TVN_DELETEITEM:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnTVDelete ) then
+ {$ENDIF}
+ Self_.EV.fOnTVDelete( Self_, NM.itemOld.hItem );
+ end;
+ end;
+ Result := FALSE;
+end;
+
+procedure ClearTreeView( TV: PControl );
+begin
+ TV.TVDelete( TVI_ROOT );
+end;
+
+const
+ TreeViewFlags: array[ TTreeViewOption ] of Integer = ( not TVS_HASLINES, TVS_LINESATROOT,
+ not TVS_HASBUTTONS, TVS_EDITLABELS, not TVS_SHOWSELALWAYS,
+ not TVS_DISABLEDRAGDROP, TVS_NOTOOLTIPS, TVS_CHECKBOXES,
+ TVS_TRACKSELECT, TVS_SINGLEEXPAND, TVS_INFOTIP,
+ TVS_FULLROWSELECT, TVS_NOSCROLL, TVS_NONEVENHEIGHT );
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewTreeView( AParent: PControl; Options: TTreeViewOptions;
+ ImgListNormal, ImgListState: PImageList ): PControl;
+begin
+ new( Result, CreateTreeView( AParent, Options, ImgListNormal, ImgListState ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:TreeView';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewTreeView( AParent: PControl; Options: TTreeViewOptions;
+ ImgListNormal, ImgListState: PImageList ): PControl;
+var Flags: Integer;
+begin
+ Flags := MakeFlags( @Options, TreeViewFlags );
+ Result := _NewCommonControl( AParent, WC_TREEVIEW, Flags or WS_VISIBLE or
+ WS_CHILD or WS_TABSTOP, True, {$IFDEF PACK_COMMANDACTIONS} TreeViewActions_Packed
+ {$ELSE} @TreeViewActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:TreeView';
+ {$ENDIF}
+ {$IFDEF PACK_COMMANDACTIONS}
+ Result.fCommandActions.aClear := @ClearTreeView;
+ {$ENDIF}
+ Result.PP.fCreateWndExt := ApplyImageLists2Control;
+ Result.fColor := clWindow;
+ Result.AttachProc( WndProcTreeView );
+ with Result.fBoundsRect do
+ begin
+ Right := Left + 150;
+ Bottom := Top + 200;
+ end;
+ Result.ImageListNormal := ImgListNormal;
+ Result.ImageListState := ImgListState;
+ Result.fLookTabKeys := [ tkTab ];
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== Tab Control ========================//
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+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 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, Integer( @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:
+ begin
+ Hdr := Pointer( Msg.lParam );
+ case Hdr.code of
+ TCN_SELCHANGING:
+ Self_.fCurIndex := Self_.GetCurIndex;
+ TCN_SELCHANGE:
+ begin
+ A := Self_.GetCurIndex;
+ WasActive := Self_.fCurIndex = A;
+ if (not WasActive)and(Self_.fCurIndex>=0) then
+ Self_.Pages[Self_.fCurIndex].Visible := false;
+ Self_.fCurIndex := A;
+ Self_.Pages[Self_.fCurIndex].Visible := true;
+ Self_.Pages[Self_.fCurIndex].BringToFront;
+ if not WasActive then
+ {$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_.fClientRight := R.Right;
+ Self_.fClientBottom := R.Bottom;
+ Self_.Perform( TCM_ADJUSTRECT, 0, Integer( @R ) );
+ Self_.fClientLeft := R.Left;
+ Self_.fClientTop := R.Top;
+ Dec(Self_.fClientRight,R.Right);
+ Dec(Self_.fClientBottom,R.Bottom);
+{$ENDIF}
+ end;
+ end;
+ Result := False;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF GRAPHCTL_XPSTYLES}
+ {$DEFINE RICHEDIT_XPBORDER}
+{$ENDIF}
+
+{$IFDEF RICHEDIT_XPBORDER}
+function WndProc_RichEditXPBorder( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var ExStyle: DWORD;
+ DrawRect, EmptyRect: TRect;
+ DC: HDC;
+ Details: TThemedElementDetails;
+begin
+ Result := FALSE;
+ if Msg.message = WM_NCPAINT then
+ begin
+ ExStyle := GetWindowLong(Self_.Handle, GWL_EXSTYLE);
+ if (ExStyle and WS_EX_CLIENTEDGE) <> 0 then
+ begin
+ GetWindowRect(Self_.Handle, DrawRect);
+ OffsetRect(DrawRect, -DrawRect.Left, -DrawRect.Top);
+ DC := GetWindowDC(Self_.Handle);
+ //try
+ EmptyRect := DrawRect;
+ with DrawRect do
+ ExcludeClipRect(DC, Left + 2, Top + 2, Right - 2, Bottom - 2);
+ Details.Element := teEdit;
+ Details.Part := 1 {EP_EDITTEXT};
+ Details.State := Ord(teEditTextNormal) - Ord(teEditTextNormal) + 1;
+ if not Assigned( DrawThemeBackground ) then
+ begin
+ ThemeLibrary := LoadLibrary(themelib);
+ DrawThemeBackground := GetProcAddress(ThemeLibrary, 'DrawThemeBackground');
+ OpenThemeData := GetProcAddress(ThemeLibrary, 'OpenThemeData');
+ end;
+ if Assigned( DrawThemeBackground ) then
+ begin
+ Result := TRUE;
+ Rslt := Self_.CallDefWndProc( Msg );
+ with Details do
+ DrawThemeBackground(OpenThemeData(0, 'edit'),
+ DC, Part, State, DrawRect, nil);
+ end;
+ //finally
+ ReleaseDC(Self_.Handle, DC);
+ //end;
+ end;
+ end;
+end;
+{$ENDIF RICHEDIT_XPBORDER}
+
+const TabControlFlags: array[ TTabControlOption ] of Integer = ( TCS_BUTTONS,
+ TCS_FIXEDWIDTH, not TCS_FOCUSNEVER,
+ TCS_FIXEDWIDTH or TCS_FORCEICONLEFT, TCS_FIXEDWIDTH or TCS_FORCELABELLEFT,
+ TCS_MULTILINE, TCS_MULTISELECT, TCS_RIGHTJUSTIFY, TCS_SCROLLOPPOSITE,
+ TCS_BOTTOM, TCS_VERTICAL, TCS_FLATBUTTONS, TCS_HOTTRACK, 0, TCS_OWNERDRAWFIXED );
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewTabControl( AParent: PControl; Tabs: array of String; Options: TTabControlOptions;
+ ImgList: PImageList; ImgList1stIdx: Integer ): PControl;
+begin
+ new( Result, CreateTabControl( AParent, Tabs, Options, ImgList, ImgList1stIdx ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:TabControl';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function NewTabControl( AParent: PControl; const Tabs: array of PKOLChar; Options: TTabControlOptions;
+ ImgList: PImageList; ImgList1stIdx: Integer ): PControl;
+var I, II : Integer;
+ Flags: Integer;
+begin
+ Flags := MakeFlags( @Options, TabControlFlags );
+ if tcoFocusTabs in Options then
+ Flags := Flags or (WS_TABSTOP or TCS_FOCUSONBUTTONDOWN);
+ Result := _NewCommonControl( AParent, WC_TABCONTROL,
+ Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE),
+ True, {$IFDEF PACK_COMMANDACTIONS} TabControlActions_Packed
+ {$ELSE} @TabControlActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:TabControl';
+ {$ENDIF}
+ if not( tcoBorder in Options ) then
+ begin
+ Result.fExStyle := Result.fExStyle and not WS_EX_CLIENTEDGE;
+ end;
+ Result.AttachProc( WndProcTabControl );
+ with Result.fBoundsRect do
+ begin
+ Right := Left + 100;
+ Bottom := Top + 100;
+ end;
+ if ImgList <> nil then
+ Result.Perform( TCM_SETIMAGELIST, 0, ImgList.Handle );
+ II := ImgList1stIdx;
+ for I := 0 to High( Tabs ) do
+ begin
+ Result.TC_Insert( I, Tabs[ I ], II );
+ Inc( II );
+ end;
+ Result.fLookTabKeys := [ tkTab ];
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFNDEF OLD_ALIGN}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewTabEmpty( AParent: PControl; Options: TTabControlOptions;
+ ImgList: PImageList ): PControl;
+var Flags: Integer;
+begin
+ Flags := MakeFlags( @Options, TabControlFlags );
+ if tcoFocusTabs in Options then
+ Flags := Flags or (WS_TABSTOP or TCS_FOCUSONBUTTONDOWN);
+ Result := _NewCommonControl( AParent, WC_TABCONTROL,
+ Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE),
+ True, {$IFDEF PACK_COMMANDACTIONS} TabControlActions_Packed
+ {$ELSE} @TabControlActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:TabControl(TabEmpty)';
+ {$ENDIF}
+ if not( tcoBorder in Options ) then
+ Result.fExStyle := Result.fExStyle and not WS_EX_CLIENTEDGE;
+ Result.AttachProc( WndProcTabControl );
+ with Result.fBoundsRect do begin
+ Right := Left + 100;
+ Bottom := Top + 100;
+ end;
+ if ImgList <> nil then
+ Result.Perform( TCM_SETIMAGELIST, 0, ImgList.Handle );
+ Result.fLookTabKeys := [ tkTab ];
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//===================== Tool bar ========================//
+
+{$IFDEF ASM_TLIST} //TTN_NEEDTEXTW ASM_TLIST!
+{$IFDEF _D3orHigher}
+{$IFDEF ASM_VERSION}
+procedure CopyPChar2WideChars( dest: PWideChar; src: PChar; Len: Integer );
+asm
+ PUSH ESI
+ PUSH EDI
+ XCHG EDI, EAX
+ MOV ESI, ECX
+ PUSH 0
+ MOV EAX, ESP
+ CALL System.@LStrFromPChar
+ MOV EAX, [ESP]
+ CALL System.@LStrLen
+ TEST EAX, EAX
+ JZ @@exit_copy
+ CMP ESI, EAX
+ JL @@1_len
+ XCHG EAX, ESI
+@@1_len:
+ POP EDX
+ PUSH EDX
+ PUSH 0
+ MOV EAX, ESP
+ CALL System.@WStrFromLStr
+
+ MOV ECX, ESI
+ INC ECX
+ POP ESI
+ PUSH ESI
+ REP MOVSW
+ MOV EAX, ESP
+ CALL System.@WStrClr
+ POP EAX
+@@exit_copy:
+ MOV EAX, ESP
+ CALL System.@LStrClr
+ POP EAX
+ POP EDI
+ POP ESI
+end;
+{$ELSE PAS_VERSION}
+procedure CopyPChar2WideChars( dest: PWideChar; src: PChar; Len: Integer );
+var W: WideString;
+ s: String;
+begin
+ s := src;
+ if Len > Length(s) then
+ Len := Length(s);
+ W := s;
+ Move( W[1], dest^, (Len+1) * Sizeof( WideChar ) );
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF _D3orHigher}
+
+function WndProcToolbarCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+asm
+ PUSH EBX
+ XOR EBX, EBX
+ CMP word ptr [EDX].TMsg.message, WM_WINDOWPOSCHANGED
+ JNE @@chk_CM_COMMAND
+ MOV dword ptr [ECX], 0 // Rslt := 0
+ XCHG EDX, EAX
+ {$IFDEF EVENTS_DYNAMIC}
+ MOV EDX, [EDX].TControl.EV
+ MOV ECX, [EDX].TEvents.fOnResize.TMethod.Code
+ MOV EAX, [EDX].TEvents.fOnResize.TMethod.Data
+ {$ELSE}
+ MOV ECX, [EDX].TControl.EV.fOnResize.TMethod.Code
+ MOV EAX, [EDX].TControl.EV.fOnResize.TMethod.Data
+ {$ENDIF}
+ {$IFDEF NIL_EVENTS}
+ JECXZ @@ret_true1
+ {$ENDIF}
+ CALL ECX // Self_.fOnResize
+@@ret_true1:
+ MOV AL, 1 // Result := TRUE
+ POP EBX
+ RET
+@@chk_CM_COMMAND: //////////////////////////////////////////////////////////////
+ CMP word ptr [EDX].TMsg.message, CM_COMMAND
+ JNE @@chk_WM_NOTIFY
+ MOVZX ECX, word ptr [EDX].TMsg.wParam
+ MOV [EAX].TControl.DF.fTBCurItem, ECX
+ XCHG EBX, EAX
+ PUSH 0
+ PUSH ECX
+ PUSH TB_COMMANDTOINDEX
+ PUSH EBX
+ CALL TControl.Perform
+ PUSH EAX
+ PUSH VK_RETURN
+ CALL GetKeyState
+ TEST EAX, EAX
+ POP ECX
+ MOV [EBX].TControl.fCurIndex, ECX
+ {$IFDEF USE_FLAGS}
+ SETL DL
+ SHL DL, G6_RightClick
+ AND [EBX].TControl.fFlagsG6, not(1 shl G6_RightClick)
+ OR [EBX].TControl.fFlagsG6, DL
+ {$ELSE}
+ SETL DL
+ MOV [EBX].TControl.fRightClick, DL
+ {$ENDIF}
+@@ret_false1:
+ XOR EAX, EAX
+ POP EBX
+ RET
+@@chk_WM_NOTIFY: ///////////////////////////////////////////////////////////////
+ CMP word ptr [EDX].TMsg.message, WM_NOTIFY
+ JNE @@ret_false1
+ MOV EDX, [EDX].TMsg.lParam
+ MOV ECX, [EDX].TTooltipText.hdr.code
+ CMP ECX, TTN_NEEDTEXT
+ JE @@TTN_NEEDTEXT
+ CMP ECX, TTN_NEEDTEXTW
+ JNE @@chk_NM_RCLICK
+ MOV BL, 1
+@@TTN_NEEDTEXT:
+ PUSH EAX // ###>
+ PUSH EDX // ***>
+ MOV EDX, [EDX].TTooltipText.hdr.idFrom
+ MOV ECX, [EAX].TControl.DF.fTBttCmd
+ OR EAX, -1
+ JECXZ @@idxReady
+ XCHG EAX, ECX
+ CALL TList.IndexOf
+@@idxReady: // EAX = -1 or index of button tooltip
+ POP EDX //<***
+ LEA EDX, [EDX].TTooltipText.szText
+ AND word ptr [EDX], 0
+ POP ECX //<###
+ TEST EAX, EAX
+ JL @@ret_true1
+ MOV ECX, [ECX].TControl.DF.fTBttTxt
+ MOV ECX, [ECX].TStrList.fList
+ MOV ECX, [ECX].TList.fItems
+ MOV EAX, [ECX+EAX*4]
+ XCHG EAX, EDX
+ XOR ECX, ECX
+ MOV CL, 79
+ {$IFDEF _D3orHigher}
+ CMP BL, 0
+ JZ @@strlcopy
+ {$IFDEF UNICODE_CTRLS}
+ CALL WStrLCopy
+ {$ELSE}
+ //CALL CopyPChar2WideChars (inlined here)
+ PUSH ESI
+ PUSH EDI
+ XCHG EDI, EAX
+ MOV ESI, ECX
+ PUSH 0
+ MOV EAX, ESP
+ CALL System.@LStrFromPChar
+ MOV EAX, [ESP]
+ CALL System.@LStrLen
+ TEST EAX, EAX
+ JZ @@exit_copy
+ CMP ESI, EAX
+ JL @@1_len
+ XCHG EAX, ESI
+@@1_len:
+ POP EDX
+ PUSH EDX
+ PUSH 0
+ MOV EAX, ESP
+ CALL System.@WStrFromLStr
+
+ MOV ECX, ESI
+ INC ECX
+ POP ESI
+ PUSH ESI
+ REP MOVSW
+ MOV EAX, ESP
+ CALL System.@WStrClr
+ POP EAX
+@@exit_copy:
+ MOV EAX, ESP
+ CALL System.@LStrClr
+ POP EAX
+ POP EDI
+ POP ESI
+ {$ENDIF}
+ JMP @@ret_true1
+ {$ENDIF _D3orHigher}
+@@strlcopy:
+ CALL StrLCopy
+ JMP @@ret_true1
+@@chk_NM_RCLICK: ///////////////////////////////////////////////////////////////
+ CMP ECX, NM_RCLICK
+ JNE @@chk_NM_CLICK
+ {$IFDEF USE_FLAGS}
+ OR [EAX].TControl.fFlagsG6, 1 shl G6_RightClick
+ {$ELSE}
+ OR [EAX].TControl.fRightClick, 1
+ {$ENDIF}
+ MOV ECX, [EDX].TNMMouse.dwItemSpec
+ OR [EAX].TControl.fCurIndex, -1
+ XCHG EBX, EAX
+ PUSH 0
+ PUSH ECX
+ PUSH TB_COMMANDTOINDEX
+ PUSH EBX
+ CALL TControl.Perform
+ MOV [EBX].TControl.fCurIndex, EAX
+ JMP @@ret_false1
+@@chk_NM_CLICK: ///////////////////////////////////////////////////////////////
+ CMP ECX, NM_CLICK
+ JNE @@chk_TBN_DROPDOWN
+ {$IFDEF USE_FLAGS}
+ AND [EAX].TControl.fFlagsG6, not(1 shl G6_RightClick)
+ {$ELSE}
+ MOV [EAX].TControl.fRightClick, 0
+ {$ENDIF}
+ OR [EAX].TControl.DF.fTBCurItem, -1
+ OR [EAX].TControl.fCurIndex, -1
+ CMP [EDX].TTBNotify.iItem, -1
+ SETNZ AL
+ POP EBX
+ RET
+@@chk_TBN_DROPDOWN: ////////////////////////////////////////////////////////////
+ CMP ECX, TBN_DROPDOWN
+ JNE @@ret_false1
+ MOV EDX, [EDX].TTBNotify.iItem
+ MOV [EAX].TControl.DF.fTBCurItem, EDX
+ PUSH EAX
+ CALL TControl.TBItem2Index
+ POP EDX
+ MOV [EDX].TControl.fCurIndex, EAX
+ {$IFDEF EVENTS_DYNAMIC}
+ MOV EAX, [EDX].TControl.EV
+ MOV ECX, [EAX].TEvents.fOnDropDown.TMethod.Code
+ {$ELSE}
+ MOV ECX, [EDX].TControl.EV.fOnDropDown.TMethod.Code
+ {$ENDIF}
+ {$IFDEF NIL_EVENTS}
+ JECXZ @@ret_z
+ {$ENDIF}
+ {$IFDEF EVENTS_DYNAMIC}
+ MOV EAX, [EAX].TEvents.fOnDropDown.TMethod.Data
+ {$ELSE}
+ MOV EAX, [EDX].TControl.EV.fOnDropDown.TMethod.Data
+ {$ENDIF}
+ CALL ECX
+@@ret_z:
+ XOR EAX, EAX
+ POP EBX
+end;
+{$ELSE PAS_VERSION} //Pascal
+function WndProcToolbarCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+var lpttt: PTooltipText;
+ idBtn, Idx: Integer;
+var Notify: PTBNotify;
+ Mouse: PNMMouse;
+{$IFNDEF _FPC}
+{$IFNDEF _D2}
+var WStr: KOLWideString;
+{$ENDIF _D2}
+{$ENDIF _FPC}
+begin
+ Result := False;
+ if Msg.message = WM_WINDOWPOSCHANGED then
+ begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnResize ) then
+ {$ENDIF}
+ Self_.EV.fOnResize( Self_ );
+ {$IFNDEF TOOLBAR_FORCE_CHILDALIGN}
+ //-- removed by MTsv DN (v.290), crash in Win 98:
+ //-- if WinVer >= wvNT then // todo: check it.
+ Result := TRUE; // this provides (prevents?) the Align working for child controls of Toolbar !
+ // but removing this line makes it impossible to correct the Align property for
+ // the neighbour controls on form!!!
+ {$ENDIF}
+ Rslt := 0;
+ end
+ else if Msg.message = CM_COMMAND then
+ begin
+ Self_.DF.fTBCurItem := Loword( Msg.wParam );
+ Self_.fCurIndex := Self_.Perform( TB_COMMANDTOINDEX, Loword( Msg.wParam ), 0 );
+ {$IFDEF USE_FLAGS}
+ if GetKeyState( VK_RBUTTON ) < 0 then
+ include( Self_.fFlagsG6, G6_RightClick )
+ else exclude( Self_.fFlagsG6, G6_RightClick );
+ {$ELSE} Self_.fRightClick := GetKeyState( VK_RBUTTON ) < 0; {$ENDIF}
+ end
+ else if Msg.message = WM_NOTIFY then
+ begin
+ lpttt := Pointer( Msg.lParam );
+ Notify := Pointer( Msg.lParam );
+ case lpttt.hdr.code of
+ TTN_NEEDTEXT:
+ begin
+ Result := True;
+ idBtn := lpttt.hdr.idFrom;
+ Idx := -1;
+ if Self_.DF.fTBttCmd <> nil then
+ Idx := Self_.DF.fTBttCmd.IndexOf( Pointer( idBtn ) );
+ lpttt.szText[ 0 ] := #0;
+ if Idx >= 0 then
+ {$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF}
+ ( lpttt.szText, Self_.DF.fTBttTxt.fList.Items[ Idx ], 79 );
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ {$IFNDEF _FPC}
+ {$IFNDEF _D2}
+ TTN_NEEDTEXTW: // for Windows XP
+ begin
+ Result := True;
+ idBtn := lpttt.hdr.idFrom;
+ Idx := -1;
+ if Self_.DF.fTBttCmd <> nil then
+ Idx := Self_.DF.fTBttCmd.IndexOf( Pointer( idBtn ) );
+ ZeroMemory( @lpttt.szText[ 0 ], 160 );
+ if Idx >= 0 then
+ begin
+ WStr := KOLWideString(Self_.DF.fTBttTxt.Items[ Idx ]);
+ if WStr <> '' then
+ Move( Wstr[ 1 ], lpttt.szText, Min( 158,
+ (Length( WStr ) + 1) * Sizeof(WideChar) ) );
+ end;
+ Exit;{>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ {$ENDIF _D2}
+ {$ENDIF _FPC}
+ NM_RCLICK:
+ begin
+ Mouse := Pointer( Msg.lParam );
+ Self_.DF.fTBCurItem := Mouse.dwItemSpec;
+ Self_.fCurIndex := Self_.Perform( TB_COMMANDTOINDEX, Mouse.dwItemSpec, 0 );
+ {$IFDEF USE_FLAGS} include( Self_.fFlagsG6, G6_RightClick );
+ {$ELSE} Self_.fRightClick := True; {$ENDIF}
+ end;
+ NM_CLICK:
+ begin
+ Self_.DF.fTBCurItem := -1; // return CurItem = -1
+ Self_.fCurIndex := -1;
+ {$IFDEF USE_FLAGS}
+ exclude( Self_.fFlagsG6, G6_RightClick );
+ {$ELSE}
+ Self_.fRightClick := False;
+ {$ENDIF}
+ Result := Notify.iItem <> -1; // do not handle - will be handled in WM_COMMAND
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ TBN_DROPDOWN:
+ begin
+ Self_.DF.fTBCurItem := Notify.iItem;
+ Self_.fCurIndex := Self_.TBItem2Index( Self_.DF.fTBCurItem );
+ {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnDropDown ) then
+ {$ENDIF}
+ Self_.EV.fOnDropDown( Self_ );
+ end;
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+const ToolbarAligns: array[ TControlAlign ] of DWORD =
+ ( CCS_NOPARENTALIGN {or CCS_NOMOVEY} {or CCS_NORESIZE} or CCS_NODIVIDER, CCS_TOP or CCS_VERT, CCS_TOP, CCS_BOTTOM or CCS_VERT, CCS_BOTTOM,
+ CCS_TOP );
+ ToolbarOptions: array[ TToolbarOption ] of Integer = ( TBSTYLE_LIST, not TBSTYLE_LIST,
+ TBSTYLE_FLAT, TBSTYLE_TRANSPARENT, TBSTYLE_WRAPABLE, CCS_NODIVIDER, 0,
+ TBSTYLE_CUSTOMERASE );
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
+ Bitmap: HBitmap; Buttons: array of PAnsiChar;
+ BtnImgIdxArray: array of Integer ) : PControl;
+begin
+ new( Result, CreateToolbar( AParent, Align, Options, Bitmap, Buttons, BtnImgIdxArray ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Toolbar';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
+ Bitmap: HBitmap; const Buttons: array of PKOLChar;
+ const BtnImgIdxArray: array of Integer ) : PControl;
+var Flags: DWORD;
+begin
+ if Options <> [] then
+ begin
+ if not( tboTextBottom in Options ) then
+ include( Options, tboTextRight );
+ if tboTextRight in Options then
+ exclude( Options, tboTextBottom );
+ end;
+ Flags := MakeFlags( @Options, ToolbarOptions )
+ //or TBSTYLE_AUTOSIZE
+ //or CCS_NOPARENTALIGN or CCS_NOMOVEY //or CCS_NORESIZE
+ or CCS_NODIVIDER or TBSTYLE_TRANSPARENT
+ ;
+ DoInitCommonControls( ICC_BAR_CLASSES );
+ Result := _NewCommonControl( AParent, TOOLBARCLASSNAME,
+ (ToolbarAligns[ Align ] or WS_CHILD or WS_VISIBLE or TBSTYLE_TOOLTIPS
+ or Flags and not (TBSTYLE_FLAT or TBSTYLE_TRANSPARENT)), {!ecm}
+ tbo3DBorder in Options,
+ {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( TOOLBAR_ACTIONS )
+ {$ELSE} nil {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:Toolbar';
+ {$ENDIF}
+ Result.fCommandActions.aClear := ClearToolbar; ///+++ anyway +++///
+ Result.fCommandActions.aGetCount := TB_BUTTONCOUNT;
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG5, G5_IsButton );
+ {$ELSE} Result.fIsButton := TRUE; {$ENDIF}
+ with Result.fBoundsRect do
+ begin
+ if Align in [ caNone ] then
+ begin
+ Bottom := Top + 26;
+ Right := Left + 1000;
+ end
+ else
+ begin
+ Left := 0; Right := 0;
+ Top := 0; Bottom := 0;
+ end;
+ end;
+ Result.AttachProc( WndProcToolbarCtrl );
+ Result.AttachProc( WndProcDoEraseBkgnd );
+ Result.Perform(TB_SETEXTENDEDSTYLE, 0, Result.Perform(TB_GETEXTENDEDSTYLE, 0, 0) or
+ TBSTYLE_EX_DRAWDDARROWS);
+
+ Result.Perform( TB_BUTTONSTRUCTSIZE, Sizeof( TTBButton ), 0 );
+ Result.Perform( TB_SETINDENT, Result.fMargin, 0 );
+ with Result.fBoundsRect do
+ begin
+ if Align in [ caLeft, caRight ] then
+ Right := Left + 24
+ else if not (Align in [caNone]) then
+ Bottom := Top + 22;
+ end;
+ {$IFnDEF TBBUTTONS_DFLT_NOAUTOSIZE}
+ Result.DF.fDefaultTBBtnStyle := TBSTYLE_AUTOSIZE;
+ {$ENDIF}
+ if Bitmap <> 0 then
+ Result.TBAddBitmap( Bitmap );
+ Result.TBAddButtons( Buttons, BtnImgIdxArray );
+ Result.Perform( WM_SIZE, 0, 0 );
+ Result.Style := Result.Style or Flags; {+ecm}
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+//================== DateTimePicker =====================//
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION}
+function WndProcDateTimePickerNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var NMhdr: PNMHdr;
+ D: TDateTime;
+ AllowChg: Boolean;
+ NMDTString: PNMDateTimeString;
+begin
+ Result := False;
+ if Msg.message = WM_NOTIFY then
+ begin
+ NMHdr := Pointer( Msg.lParam );
+ CASE NMHdr.code OF
+ DTN_DROPDOWN:{$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnDropDown ) then
+ {$ENDIF}
+ Self_.EV.fOnDropDown( Self_ );
+ DTN_CLOSEUP: {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnCloseUp ) then
+ {$ENDIF}
+ Self_.EV.fOnCloseUp( Self_ );
+ DTN_DATETIMECHANGE:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnChangeCtl ) then
+ {$ENDIF}
+ Self_.EV.fOnChangeCtl( Self_ );
+ DTN_USERSTRING:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnDTPUserString ) then
+ {$ENDIF}
+ begin
+ NMDTString := Pointer( NMHdr );
+ D := Self_.DateTime;
+ AllowChg := TRUE;
+ Self_.EV.fOnDTPUserString( Self_, KOLString(NMDTString.pszUserString), D, AllowChg );
+ NMDTString.dwFlags := Integer( not AllowChg );
+ end;
+ END;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+const
+ DateTimePickerOptions: array[ TDateTimePickerOption ] of Integer = (
+ DTS_TIMEFORMAT, DTS_LONGDATEFORMAT, DTS_UPDOWN, DTS_RIGHTALIGN,
+ DTS_SHOWNONE, DTS_APPCANPARSE );
+
+function NewDateTimePicker( AParent: PControl; Options: TDateTimePickerOptions )
+ : PControl;
+var Flags: DWORD;
+const
+ CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS or
+ CS_VREDRAW or CS_HREDRAW;
+begin
+ DoInitCommonControls( ICC_DATE_CLASSES );
+ Flags := MakeFlags( @Options, DateTimePickerOptions );
+ Result := _NewCommonControl( AParent, DATETIMEPICK_CLASS,
+ (WS_CHILD or WS_VISIBLE or WS_TABSTOP or Flags {or DTS_APPCANPARSE}),
+ TRUE, {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS )
+ {$ELSE} nil {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:DateTimePicker';
+ {$ENDIF}
+ Result.SetSize( 110, 24 );
+ Result.AttachProc( WndProcDateTimePickerNotify );
+end;
+
+procedure TControl.SetDateTime(Value: TDateTime);
+var ST: TSystemTime;
+ D0: TDateTime;
+begin
+ if not IsNAN( Value ) then
+ begin
+ EncodeDate( 1899, 12, 31, D0 );
+ if Trunc( Value ) < D0 then
+ Value := Frac( Value ) + D0;
+ DateTime2SystemTime( Value, ST );
+ end;
+ Perform( DTM_SETSYSTEMTIME, Integer( IsNAN( Value ) ) , Integer( @ ST ) );
+end;
+
+function TControl.GetDateTime: TDateTime;
+var ST: TSystemTime;
+begin
+ if Perform( DTM_GETSYSTEMTIME, 0, Integer( @ ST ) ) = GDT_VALID then
+ SystemTime2DateTime( ST, Result )
+ else
+ Result := NAN;
+end;
+
+function TControl.Get_SystemTime: TSystemTime;
+begin
+ //FillChar( Result, Sizeof( Result ), #0 );
+ ZeroMemory( @Result, Sizeof( Result ) );
+ Perform( DTM_GETSYSTEMTIME, 0, Integer( @ Result ) ); // <> GDT_VALID then
+end;
+
+procedure TControl.Set_SystemTime(const Value: TSystemTime);
+begin
+ Perform( DTM_SETSYSTEMTIME, Integer( Value.wYear = 0 ) , Integer( @ Value ) );
+end;
+
+function TControl.GetDate: TDateTime;
+begin
+ Result := DateTime;
+ if not IsNAN( Result ) then
+ Result := Trunc( DateTime );
+end;
+
+function TControl.GetTime: TDateTime;
+begin
+ Result := DateTime;
+ if not IsNAN( Result ) then
+ Result := Frac( Result );
+end;
+
+procedure TControl.SetDate(const Value: TDateTime);
+begin
+ if IsNAN( Value ) then
+ DateTime := Value
+ else
+ if not IsNAN( DateTime ) then
+ DateTime := Trunc( Value ) + Frac( DateTime )
+ else
+ DateTime := Trunc( Value );
+end;
+
+procedure TControl.SetTime(const Value: TDateTime);
+begin
+ if IsNAN( Value ) then
+ DateTime := Value
+ else
+ if not IsNAN( DateTime ) then
+ DateTime := Trunc( DateTime ) + Frac( Value )
+ else
+ DateTime := 1.0 + Frac( Value );
+end;
+
+function TControl.GetDateTimeRange: TDateTimeRange;
+var ST_R: array[ 0..1 ] of TSystemTime;
+begin
+ Perform( DTM_GETRANGE, 0, Integer( @ ST_R[ 0 ] ) );
+ SystemTime2DateTime( ST_R[ 0 ], Result.FromDate );
+ SystemTime2DateTime( ST_R[ 1 ], Result.ToDate );
+end;
+
+procedure TControl.SetDateTimeRange(Value: TDateTimeRange);
+var ST_R: array[ 0..1 ] of TSystemTime;
+begin
+ DateTime2SystemTime( Value.FromDate, ST_R[ 0 ] );
+ DateTime2SystemTime( Value.ToDate , ST_R[ 1 ] );
+ Perform( DTM_SETRANGE,
+ Integer( IsNAN( Value.FromDate ) ) or
+ (Integer( IsNAN( Value.ToDate ) ) shl 1),
+ Integer( @ ST_R[ 0 ] ) );
+end;
+
+function TControl.GetDateTimePickerColor( Index: TDateTimePickerColor): TColor;
+begin
+ Result := Perform( DTM_GETMCCOLOR, Integer( Index ), 0 );
+end;
+
+procedure TControl.SetDateTimePickerColor(
+ Index: TDateTimePickerColor; Value: TColor);
+begin
+ Perform( DTM_SETMCCOLOR, Integer( Index ), Color2RGB( Value ) );
+end;
+
+procedure TControl.SetDateTimeFormat(const Value: KOLString);
+begin
+ Perform( DTM_SETFORMAT, 0, Integer( PKOLChar( Value ) ) );
+end;
+
+function TControl.GetTBAutoSizeButtons: Boolean;
+begin
+ Result := DF.fDefaultTBBtnStyle and TBSTYLE_AUTOSIZE <> 0;
+end;
+
+function TControl.GetTVEditing: Boolean;
+begin
+ Result := Perform( TVM_GETEDITCONTROL, 0, 0 ) <> 0;
+end;
+
+procedure TControl.SetTBAutoSizeButtons(const Value: Boolean);
+begin
+ DF.fDefaultTBBtnStyle := Integer( Value ) shl 4;
+end;
+
+{$IFDEF USE_FLAGS}
+function TControl.GetTabStop: Boolean;
+begin
+ Result := F2_Tabstop in fStyle.f2_Style;
+end;
+
+procedure TControl.SetTabStop(const Value: Boolean);
+begin
+ if Value then include( fStyle.f2_Style, F2_Tabstop )
+ else exclude( fStyle.f2_Style, F2_Tabstop );
+end;
+
+function TControl.GetWordWrap: Boolean;
+begin
+ Result := G1_WordWrap in fFlagsG1;
+end;
+
+procedure TControl.SetWordWrap(const Value: Boolean);
+begin
+ if Value then include( fFlagsG1, G1_WordWrap )
+ else exclude( fFlagsG1, G1_WordWrap );
+end;
+
+function TControl.GetCannotDoubleBuf: Boolean;
+begin
+ Result := G1_CanNotDoublebuf in fFlagsG1;
+end;
+
+procedure TControl.SetCannotDoubleBuf(const Value: Boolean);
+begin
+ if Value then include( fFlagsG1, G1_CanNotDoublebuf )
+ else exclude( fFlagsG1, G1_CanNotDoublebuf );
+end;
+
+function TControl.GetDoubleBuffered: Boolean;
+begin
+ Result := G2_DoubleBuffered in fFlagsG2;
+end;
+
+function TControl.GetTransparent: Boolean;
+begin
+ Result := G2_Transparent in fFlagsG2;
+end;
+
+function TControl.GetIsForm: Boolean;
+begin
+ Result := G3_IsForm in fFlagsG3;
+end;
+
+function TControl.GetSizeGrip: Boolean;
+begin
+ Result := G3_SizeGrip in fFlagsG3;
+end;
+
+procedure TControl.SetSizeGrip(const Value: Boolean);
+begin
+ if Value then include( fFlagsG3, G3_SizeGrip )
+ else exclude( fFlagsG3, G3_SizeGrip );
+end;
+
+function TControl.GetIsApplet: Boolean;
+begin
+ Result := G3_IsApplet in fFlagsG3;
+end;
+
+function TControl.GetIsControl: Boolean;
+begin
+ Result := G3_IsControl in fFlagsG3;
+end;
+
+function TControl.GetIsMDIChild: Boolean;
+begin
+ Result := G3_IsMDIChild in fFlagsG3;
+end;
+
+function TControl.GetCreateVisible: Boolean;
+begin
+ Result := G4_CreateVisible in fFlagsG4;
+end;
+
+procedure TControl.SetCreateVisible(const Value: Boolean);
+begin
+ if Value then include( fFlagsG4, G4_CreateVisible )
+ else exclude( fFlagsG4, G4_CreateVisible );
+end;
+
+function TControl.GetIsButton: Boolean;
+begin
+ Result := G5_IsButton in fFlagsG5;
+end;
+
+function TControl.GetFlat: Boolean;
+begin
+ Result := G3_Flat in fFlagsG3;
+end;
+
+function TControl.GetMouseInCtl: Boolean;
+begin
+ Result := G3_MouseInCtl in fFlagsG3;
+end;
+
+function TControl.GetEraseBackground: Boolean;
+begin
+ Result := G5_EraseBkgnd in fFlagsG5;
+end;
+
+procedure TControl.SetEraseBackground(const Value: Boolean);
+begin
+ if Value then include( fFlagsG5, G5_EraseBkgnd )
+ else exclude( fFlagsG5, G5_EraseBkgnd );
+end;
+
+function TControl.Get3ButtonPress: Boolean;
+begin
+ Result := G5_3ButtonPress in fFlagsG5;
+end;
+
+function TControl.GetKeyPreview: Boolean;
+begin
+ Result := G6_KeyPreview in fFlagsG6;
+end;
+
+procedure TControl.SetKeyPreview(const Value: Boolean);
+begin
+ if Value then include( fFlagsG6, G6_KeyPreview )
+ else exclude( fFlagsG6, G6_KeyPreview );
+end;
+
+function TControl.GetIgnoreDefault: Boolean;
+begin
+ Result := G5_IgnoreDefault in fFlagsG5;
+end;
+
+procedure TControl.SetIgnoreDefault(const Value: Boolean);
+begin
+ if Value then include( fFlagsG5, G5_IgnoreDefault )
+ else exclude( fFlagsG5, G5_IgnoreDefault );
+end;
+
+function TControl.GetWindowed: Boolean;
+begin
+ Result := not(G6_GraphicCtl in fFlagsG6);
+end;
+
+procedure TControl.SetWindowed(const Value: Boolean);
+begin
+ if Value then exclude( fFlagsG6, G6_GraphicCtl )
+ else include( fFlagsG6, G6_GraphicCtl );
+end;
+
+function TControl.Get_RightClick: Boolean;
+begin
+ Result := G6_RightClick in fFlagsG6;
+end;
+
+function TControl.Get_Dragging: Boolean;
+begin
+ Result := G6_Dragging in fFlagsG6;
+end;
+
+function TControl.Get_SizeRedraw: Boolean;
+begin
+ Result := G1_SizeRedraw in fFlagsG1;
+end;
+
+procedure TControl.Set_SizeRedraw(const Value: Boolean);
+begin
+ if Value then include( fFlagsG1, G1_SizeRedraw )
+ else exclude( fFlagsG1, G1_SizeRedraw );
+end;
+
+{$ENDIF USE_FLAGS}
+
+function TControl.GetDroppedDown: Boolean;
+begin
+ Result := DF.fTBDropped
+ or (Perform( CB_GetDroppedState, 0, 0 ) <> 0);
+end;
+
+//===================== RichEdit ========================//
+{$IFNDEF NOT_USE_RICHEDIT}
+type PENLink = ^TENLink;
+ TENLink = packed record
+ hdr: TNMHDR;
+ msg: DWORD;
+ wParam: Integer;
+ lParam: Integer;
+ chrg: TCHARRANGE;
+ end;
+ TEXTRANGEA = packed record
+ chrg: TCharRange;
+ lpstrText: PAnsiChar;
+ end;
+
+{$IFDEF not_ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var Link: PENLink;
+ Range: TextRangeA;
+ Buffer: Array[ 0..1023 ] of AnsiChar; // KOL_ANSI
+ Buf_W : array[ 0..511 ] of WideChar absolute Buffer;
+ s: KOLString;
+begin
+ Result := False;
+ if (Msg.message = WM_NOTIFY) and (PNMHdr( Msg.lParam ).code = EN_LINK) then
+ begin
+ Link := Pointer( Msg.lParam );
+ Range.chrg := Link.chrg;
+ Range.lpstrText := @Buffer[ 0 ];
+ Buffer[ 0 ] := #0;
+ Self_.Perform( EM_GETTEXTRANGE, 0, Integer( @Range ) );
+ {$IFDEF UNICODE_CTRLS}
+ s := Buf_W; //todo: check it!
+ {$ELSE}
+ {$IFDEF _D3orHigher}
+ if (Buffer[ 1 ] = #0) and (Range.chrg.cpMax - Range.chrg.cpMin > 1) then
+ begin
+ {$WARNINGS OFF}
+ s := Buf_W;
+ {$WARNINGS ON}
+ end
+ else
+ {$ENDIF}
+ s := Buffer;
+ {$ENDIF}
+ if Self_.DF.fREUrl <> nil then
+ FreeMem( Self_.DF.fREUrl );
+ if s <> '' then
+ begin
+ GetMem( Self_.DF.fREUrl, (Length(s)+1) * Sizeof(KOLChar) );
+ Move( s[1], Self_.DF.fREUrl^, (Length(s)+1)*Sizeof(KOLChar) );
+ end;
+ case Link.msg of
+ WM_MOUSEMOVE:
+ {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnREOverURL ) then
+ {$ENDIF}
+ Self_.EV.fOnREOverURL( Self_ );
+ WM_LBUTTONDOWN, WM_RBUTTONDOWN:
+ {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnREUrlClick ) then
+ {$ENDIF}
+ Self_.EV.fOnREUrlClick( Self_ );
+ end;
+ Rslt := 0;
+ Result := TRUE;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_noVERSION}
+function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+const int_IDC_ARROW = integer( IDC_ARROW );
+asm
+ CMP word ptr [EDX].TMsg.message, WM_NOTIFY
+ JNE @@chk_WM_DESTROY
+ MOV EDX, [EDX].TMsg.lParam
+ CMP [EDX].TNMHdr.code, EN_SELCHANGE
+ JNE @@ret_false
+ CALL TControl.DoSelChange
+ JMP @@ret_false
+@@chk_WM_DESTROY:
+ CMP word ptr [EDX].TMsg.message, WM_DESTROY
+ JNZ @@ret_false
+ LEA EAX, [EAX].TControl.fREUrl
+ CALL @LStrClr
+@@ret_false:
+ XOR EAX, EAX
+ RET
+end;
+{$ELSE PAS_VERSION} //Pascal
+function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var NMhdr: PNMHdr;
+begin
+ Result := False;
+ if Msg.message = WM_NOTIFY then
+ begin
+ NMHdr := Pointer( Msg.lParam );
+ case NMHdr.code of
+ EN_SELCHANGE:
+ begin
+ Self_.DoSelChange;
+ if {$IFDEF USE_FLAGS} G2_Transparent in Self_.fFlagsG2
+ {$ELSE} Self_.fTransparent {$ENDIF} then
+ Self_.Invalidate;
+ end;
+ end;
+ end
+ else
+ if Msg.message = WM_DESTROY then
+ begin
+ if Self_.DF.fREUrl <> nil then
+ FreeMem( Self_.DF.fREUrl );
+ Self_.DF.fREURL := nil;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+const RichEditflags: array [ TEditOption ] of Integer = (
+ not (es_AutoHScroll or WS_HSCROLL),
+ not (es_AutoVScroll or WS_VSCROLL),
+ 0 {es_Lowercase - not supported},
+ 0 {es_Multiline - RichEdit always multiline},
+ es_NoHideSel,
+ 0 {es_OemConvert - not suppoted},
+ 0 {es_Password - not supported},
+ es_Readonly,
+ 0 {es_UpperCase - not supported},
+ es_WantReturn, 0, es_Number );
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;
+begin
+ new( Result, CreateRichEdit1( AParent, Options ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:RichEdit';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$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;
+begin
+ {$IFDEF INPACKAGE}
+ Log( '->NewRichEdit1' );
+ TRY
+ {$ENDIF INPACKAGE}
+ if FRichEditModule = 0 then
+ begin
+ search_richedit:
+ I := RichEditIdx;
+ Last := High( RichEditLibnames );
+ d := 1;
+ if RichEditIdx > 1 then // 50W, 20A
+ begin
+ I := Last;
+ Last := 0;
+ d := -1;
+ end;
+ SaveErrMode := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS );
+ while I <> Last + d do
+ begin
+ FRichEditModule := LoadLibrary( RichEditLibnames[ I ] );
+ RichEditClass := RichEditClasses[ I ];
+ if FRichEditModule > HINSTANCE_ERROR then break;
+ inc( I, d );
+ end;
+ if FRichEditModule <= HINSTANCE_ERROR then
+ FRichEditModule := 0;
+ SetErrorMode( SaveErrMode );
+ end;
+ Flags := MakeFlags( @Options, RichEditFlags );
+ {$IFDEF INPACKAGE}
+ Log( '//// calling _NewCommonControl' );
+ {$ENDIF INPACKAGE}
+ Result := _NewCommonControl( AParent, RichEditClass, WS_VISIBLE or WS_CHILD
+ or WS_TABSTOP or WS_BORDER or ES_MULTILINE or Flags,
+ True, {$IFDEF PACK_COMMANDACTIONS} RichEditActions_Packed
+ {$ELSE} @RichEditActions {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:RichEdit';
+ {$ENDIF}
+ {$IFDEF STATIC_RICHEDIT_DATA}{$ELSE}
+ Result.DF.fRECharFormatRec := AllocMem( Sizeof( TCharFormat ) + Sizeof( TParaFormat2 ) );
+ Result.DF.fREParaFmtRec := Pointer( Integer( @ Result.DF.fRECharFormatRec )
+ + Sizeof( TCharFormat ) );
+ Result.Add2AutoFreeEx( Result.FreeCharFormatRec );
+ {$ENDIF}
+ {$IFDEF INPACKAGE}
+ Log( '//// after _NewCommonControl called' );
+ {$ENDIF INPACKAGE}
+ Result.fLookTabKeys := [ tkTab ];
+ if eoWantTab in Options then
+ Result.fLookTabKeys := [ ];
+
+ Result.AttachProc( WndProcRichEditNotify );
+ {$IFDEF USE_FLAGS}
+ include( Result.fFlagsG1, G1_CanNotDoublebuf );
+ exclude( Result.fFlagsG2, G2_DoubleBuffered );
+ include( Result.fFlagsG5, G5_IgnoreDefault );
+ {$ELSE} Result.fCannotDoubleBuf := True;
+ Result.fDoubleBuffered := False;
+ Result.fIgnoreDefault := TRUE;
+ {$ENDIF}
+ with Result.fBoundsRect do
+ begin
+ Right := Right + 100;
+ Bottom := Top + 200;
+ end;
+ {$IFDEF INPACKAGE}
+ Log( '//// before Perform' );
+ {$ENDIF INPACKAGE}
+ Result.Perform( EM_SETEVENTMASK, 0,
+ ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or
+ ENM_PROTECTED or $04000000 {ENM_LINK} or ENM_KEYEVENTS );
+ {$IFDEF INPACKAGE}
+ Log( '//// after Perform' );
+ {$ENDIF INPACKAGE}
+ Result.fColor := clWindow;
+ Result.Perform( EM_SETBKGNDCOLOR, 0, Color2RGB(Result.fColor));
+ {$IFDEF RICHEDIT_XPBORDER}
+ Result.AttachProc( WndProc_RichEditXPBorder );
+ {$ENDIF}
+ {$IFDEF INPACKAGE}
+ LogOK;
+ FINALLY
+ Log( '<-NewRichEdit1' );
+ END;
+ {$ENDIF INPACKAGE}
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF NOT_USE_RICHEDIT}
+
+{$ENDIF USE_CONSTRUCTORS}
+
+function OleInitialize(pwReserved: Pointer): HResult; stdcall;
+ external 'ole32.dll' name 'OleInitialize';
+procedure OleUninitialize; stdcall;
+ external 'ole32.dll' name 'OleUninitialize';
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function OleInit: Boolean;
+begin
+ if OleInitCount = 0 then
+ begin
+ Result := False;
+ if OleInitialize( nil ) <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Inc( OleInitCount );
+ Result := True;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure OleUnInit;
+begin
+ if OleInitCount > 0 then
+ begin
+ Dec( OleInitCount );
+ if OleInitCount = 0 then
+ OleUninitialize;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function SysAllocStringLen;
+ external 'oleaut32.dll' name 'SysAllocStringLen';
+procedure SysFreeString( psz: PWideChar ); stdcall;
+ external 'oleaut32.dll' name 'SysFreeString';
+
+function StringToOleStr(const Source: Ansistring): PWideChar;
+var
+ SourceLen, ResultLen: Integer;
+ Buffer: array[0..1023] of WideChar;
+begin
+ SourceLen := Length(Source);
+ if Length(Source) < SizeOf(Buffer) div 2 then
+ Result := SysAllocStringLen(Buffer, MultiByteToWideChar(0, 0,
+ PAnsiChar(Source), SourceLen, Buffer, SizeOf(Buffer) div 2))
+ else
+ begin
+ ResultLen := MultiByteToWideChar(0, 0,
+ Pointer(Source), SourceLen, nil, 0);
+ Result := SysAllocStringLen(nil, ResultLen);
+ MultiByteToWideChar(0, 0, Pointer(Source), SourceLen,
+ Result, ResultLen);
+ end;
+end;
+
+{$IFNDEF NOT_USE_RICHEDIT}
+{$IFDEF USE_CONSTRUCTORS}
+function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;
+begin
+ new( Result, CreateRichEdit( AParent, Options ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:RichEdit';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;
+begin
+ {$IFDEF INPACKAGE}
+ Log( '->NewRichEdit' );
+ TRY
+ {$ENDIF INPACKAGE}
+ if OleInit then
+ begin
+ {$IFDEF INPACKAGE}
+ Log( '//// OleInit OK: call NewRichEdit1' );
+ {$ENDIF INPACKAGE}
+ {$IFDEF UNICODE_CTRLS}
+ RichEditIdx := 0;
+ {$ELSE}
+ RichEditIdx := 0; // Richedit20A / RichEdit
+ {$ENDIF}
+ Result := NewRichEdit1( AParent, Options );
+ Result.DF.fCharFmtDeltaSz := 24; //sizeof( TCharFormat2 ) - sizeof( RichEdit.TCharFormat );
+ // sizeof( TCharFormat2 ) is calculated incorrectly
+ Result.DF.fParaFmtDeltaSz := sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat );
+ end
+ else
+ begin
+ {$IFDEF INPACKAGE}
+ Log( '//// OleInit failed: call NewRichEdit1' );
+ {$ENDIF INPACKAGE}
+ Result := NewRichEdit1( AParent, Options );
+ end;
+ {$IFDEF INPACKAGE}
+ LogOK;
+ FINALLY
+ Log( '<-NewRichEdit' );
+ END;
+ {$ENDIF INPACKAGE}
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_CONSTRUCTORS}
+{$ENDIF NOT_USE_RICHEDIT}
+
+//=====================================================================//
+{$ENDIF WIN_GDI}
+
+{ TControl }
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.Init;
+{$IFNDEF OLD_EVENTS_MODEL}
+var i: Integer;
+{$ENDIF}
+begin
+ {$IFDEF CALL_INHERITED}
+ inherited; // nothing here for Delphi 4 and higher
+ {$ENDIF}
+ {$IFDEF GDI}
+ {$IFDEF OLD_EVENTS_MODEL}
+ {$IFDEF USE_GRAPHCTLS}
+ PP.fDoInvalidate := InvalidateWindowed;
+ {$ENDIF}
+ PP.fOnDynHandlers := WndProcDummy;
+ PP.fWndProcKeybd := WndProcDummy;
+ //{-2.95}PP.fWndProcResizeFlicks := WndProcDummy;
+ PP.fPass2DefProc := WndProcDummy;
+ PP.fControlClick := DummyObjProc;
+ PP.fAutoSize := DummyObjProc;
+ PP.fWndFunc := @ WndFunc;
+ {$ELSE}
+ {$IFDEF EVENTS_DYNAMIC}
+ if not Assigned( EmptyEvents.fOnMessage ) then
+ for i := 0 to idx_LastEvent do
+ EmptyEvents.MethodEvents[i].Code := DummyProcTable[InitEventsTable[i] and $F];
+ EV := @ EmptyEvents;
+ for i := 0 to High(PP.Procedures) do
+ PP.Procedures[i] := DummyProcTable[InitEventsTable[i] shr 4];
+ {$ELSE}
+ for i := 0 to idx_LastEvent do
+ begin
+ EV.MethodEvents[i].Code := DummyProcTable[InitEventsTable[i] and $F];
+ //EV.MethodEvents[i].Data := @Self;
+ if i < idx_LastProc - idx_LastEvent then
+ PP.Procedures[i] := DummyProcTable[InitEventsTable[i] shr 4];
+ end;
+ {$ENDIF}
+ {$ENDIF NEW_EVENTS_MODEL}
+ fAlphaBlend := 255;
+ //---- fCommandActions.aClear := ClearText; //--- moved to _NewWindowed
+ fColor := clBtnFace;
+ fTextColor := clWindowText;
+ {$ENDIF GDI}
+ fMargin := 2;
+ {$IFDEF GDI}
+ //fCtl3D := True; fCtl3Dchild := True;
+ fCtl3D_child := 3;
+ {$ENDIF GDI}
+ fChildren := NewList;
+ {$IFDEF GDI}
+ fClsStyle := CS_OWNDC;
+ fStyle.Value := WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or
+ WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or
+ WS_BORDER or WS_THICKFRAME;
+ fExStyle := WS_EX_CONTROLPARENT;
+ {$ENDIF GDI}
+ {$IFDEF USE_FLAGS}
+ {$ELSE} fWindowed := True;
+ fVisible := True;
+ fEnabled := True;
+ {$ENDIF}
+ fDynHandlers := NewList;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.InitParented( AParent: PControl );
+begin
+ Init;
+ if AParent <> nil then
+ fColor := AParent.fColor;
+ Parent := AParent;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TControl.InitParented( AParent: PControl; widget: PGtkWidget;
+ need_eventbox: Boolean );
+BEGIN
+ Init;
+ fHandle := widget;
+ fCaptionHandle := fHandle;
+ fEventboxHandle := fHandle;
+ IF need_eventbox THEN
+ BEGIN
+ fEventboxHandle := gtk_event_box_new();
+ gtk_widget_set_events( fEventboxHandle, GDK_ALL_EVENTS_MASK );
+ //gtk_container_add( GTK_CONTAINER( AParent.fHandle ), fEventboxHandle );
+ gtk_widget_show( fEventboxHandle );
+ gtk_container_add( GTK_CONTAINER( fEventboxHandle ), fHandle );
+ END;
+ g_object_set_data( G_OBJECT( fEventboxHandle ), ID_SELF, @ Self );
+ if AParent <> nil then
+ fColor := AParent.fColor;
+ Parent := AParent;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+{$IFDEF WIN_GDI}
+
+procedure TControl.InitOrthaned( AParentWnd: HWnd );
+begin
+ Init;
+ FParentWnd := AParentWnd;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TControl.Destroy;
+var I: Integer;
+ F: PControl;
+ Ico: HIcon;
+begin
+ {$IFDEF USE_CUSTOMEXTENSIONS}
+ {$I CUSTOM_TCONTROL_DESTROY.INC}
+ {$ENDIF}
+ {$IFDEF USE_MHTOOLTIP}
+ {$DEFINE destroy}
+ /////fHint.Free;
+ {$UNDEF destroy}
+ {$ENDIF USE_MHTOOLTIP}
+ {$IFDEF DEBUG_ANY}
+ F := nil;
+ TRY
+ F := ParentForm; // or Applet - for form ???
+ EXCEPT
+ asm
+ nop
+ end;
+ END;
+ {$ELSE}
+ F := ParentForm; // or Applet - for form ???
+ {$ENDIF DEBUG_ANY}
+ if F <> nil then
+ if F.DF.FCurrentControl = @Self then
+ F.DF.FCurrentControl := nil;
+
+ if fHandle <> 0 then
+ 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 );
+ {$ELSE} fDestroying := True; {$ENDIF}
+
+ if {$IFDEF USE_FLAGS} G6_CtlClassNameChg in fFlagsG6
+ {$ELSE} fCtlClsNameChg {$ENDIF} then
+ begin
+ FreeMem( fControlClassName );
+ {$IFDEF USE_FLAGS} exclude( fFlagsG6, G6_CtlClassNameChg );
+ {$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
+ if {$IFDEF USE_FLAGS} not(G1_IconShared in fFlagsG1)
+ {$ELSE} not fIconShared {$ENDIF} then
+ DestroyIcon( Ico );
+ if IsWindow( I ) then
+ begin
+ // RemoveProp( I, ID_SELF ); //************** Remarked By M.Gerasimov
+ {$IFDEF USE_fNCDestroyed}
+ if not fNCDestroyed then
+ {$ENDIF}
+ begin
+ {$IFDEF DEBUG_ENDSESSION}
+ if EndSession_Initiated then
+ 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}
+ SetWindowLong( I, GWL_USERDATA, 0 );
+ {$ENDIF}
+ {$ENDIF}
+ *)
+ DestroyWindow( I );
+ end;
+ end;
+ fHandle := 0;
+ end;
+
+ if fCustomData <> nil then
+ FreeMem( fCustomData );
+ fCustomData := nil;
+ fCustomObj.Free;
+ fCustomObj := nil;
+
+ if fTmpBrush <> 0 then
+ DeleteObject( fTmpBrush );
+ fTmpBrush := 0;
+
+ //if FCaption <> nil then FreeMem( FCaption );
+ fCaption := '';
+ //if fStatusTxt <> nil then
+ // FreeMem( fStatusTxt );
+
+ if fParent <> nil then
+ begin
+ fParent.fChildren.Remove( @Self );
+ {$IFDEF USE_AUTOFREE4CHILDREN}
+ fParent.RemoveFromAutoFree( @ Self );
+ {$ENDIF}
+ if fParent.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;
+end;
+{$ENDIF PAS_VERSION}
+
+ {$IFDEF USE_MHTOOLTIP}
+ {$DEFINE code}
+ function TControl.GetHint: PMHHint;
+ begin
+ if fHint = nil then
+ fHint := NewHint(@Self);
+ Result := fHint;
+ end;
+ {$UNDEF code}
+ {$ENDIF}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetEnabled( Value: Boolean );
+begin
+ if GetEnabled = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF USE_FLAGS}
+ {$ELSE}
+ fEnabled := Value;
+ {$ENDIF USE_FLAGS}
+ if Value then
+ exclude( fStyle.f3_Style, F3_Disabled )
+ else include( fStyle.f3_Style, F3_Disabled );
+ if fHandle <> 0 then
+ begin
+ {$IFDEF USE_FLAGS}
+ EnableWindow( fHandle, not(F3_Disabled in fStyle.f3_Style));
+ {$ELSE}
+ EnableWindow( fHandle, fEnabled );
+ {$ENDIF}
+ end;
+ Invalidate; // necessary for Graphic controls
+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;
+begin
+ {$IFDEF INPACKAGE}
+ Log( '->TControl.GetWindowHandle' );
+ 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 );
+ CreateWindow; //virtual!!!
+ {$IFDEF USE_FLAGS} include( fFlagsG4, G4_CreateHidden );
+ {$ELSE} fCreateHidden := True; {$ENDIF}
+ end else
+ {$ENDIF CREATE_HIDDEN}
+ CreateWindow; //virtual!!!
+ end;
+ Result := fHandle;
+ {$IFDEF INPACKAGE}
+ LogOK;
+ FINALLY
+ Log( '<-TControl.GetWindowHandle' );
+ END;
+ {$ENDIF INPACKAGE}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF DEBUG_CREATEWINDOW}
+procedure Debug_CreateWindow1( _Self: PControl );
+begin
+ {LogFileOutput( GetStartDir + 'Session.log', 'TControl.CreateWindow, ' +
+ ' Self = ' + Int2Str( Integer( _Self ) ) +
+ ' Caption = ' + _Self.fCaption +
+ ' fChildren = ' + Int2Hex( Integer( _Self.fChildren ), 4 ) +
+ ' ChildCount = ' + Int2Str( _Self.ChildCount ) );}
+end;
+
+procedure Debug_CreateWindow2( _Self: PControl; const Params: TCreateWndParams );
+begin
+ LogFileOutput( GetStartDir + 'Session.log',
+ ' ExStyle=' + Int2Hex( Params.ExStyle, 4 ) +
+ ' WinClassName=' + Params.WinClassName +
+ ' Caption=' + Params.Caption +
+ ' Style=' + Int2Hex( Params.Style, 4 ) +
+ ' X=' + Int2Str( Params.X ) +
+ ' Y=' + Int2Str( Params.Y ) +
+ ' Width=' + Int2Str( Params.Width ) +
+ ' Height=' + Int2Str( Params.Height ) +
+ //' WndParent=' + Int2Str( Params.WndParent ) +
+ ' Parent=' + Int2Hex( DWORD( _Self.Parent ), 6 ) +
+ ' Menu=' + Int2Str( Params.Menu ) +
+ ' hInstance=' + Int2Str( Params.WindowClass.hInstance ) +
+ ' Param=' + Int2Str( Integer( Params.Param ) ) +
+ ' WindowClass.style:' + Int2Str( Params.WindowClass.style ) +
+ ' WindowClass.lpfnWndProc:' + Int2Str( DWORD( Pointer( Params.WindowClass.lpfnWndProc ) ) ) +
+ ' WindowClass.cbClsExtra:' + Int2Str( DWORD( Params.WindowClass.cbClsExtra ) ) +
+ ' WindowClass.cbWndExtra:' + Int2Str( DWORD( Params.WindowClass.cbWndExtra ) ) +
+ ' WindowClass.hInstance:' + Int2Str( Params.WindowClass.hInstance ) +
+ ' WindowClass.hIcon:' + Int2Str( Params.WindowClass.hIcon ) +
+ ' WindowClass.hCursor:' + Int2Str( Params.WindowClass.hCursor ) +
+ ' WindowClass.hbrBackground:' + Int2Str( Params.WindowClass.hbrBackground ) +
+ ' WindowClass.lpszMenuName:' + Params.WindowClass.lpszMenuName +
+ ' WindowClass.lpszClassName:' + Params.WindowClass.lpszClassName
+ );
+end;
+{$ENDIF DEBUG_CREATEWINDOW}
+
+//var LockedWindow: HWnd;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TControl.CreateWindow: Boolean;
+const
+ CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS;
+ CS_ON = 0; //CS_VREDRAW or CS_HREDRAW;
+var TempClass: TWndClass;
+ Params: TCreateWndParams;
+ ClassRegistered: Boolean;
+ {$IFDEF _FPC}
+ SClassName: AnsiString;
+ {$ENDIF PAS_VERSION}
+ {$IFDEF UNICODE_CTRLS}
+ TempOleStr : PWideChar;
+ {$ENDIF}
+ {$IFDEF CREATE_HIDDEN}
+ {$ELSE}
+ lock: Boolean;
+ {$ENDIF}
+begin
+ {$IFDEF INPACKAGE}
+ Log( '->TControl.CreateWindow' );
+ TRY
+ {$ENDIF INPACKAGE}
+ {$IFDEF DEBUG_CREATEWINDOW}
+ Debug_CreateWindow1( @ Self );
+ {$ENDIF DEBUG_CREATEWINDOW}
+ Result := False;
+ if fParent <> nil then
+ if fParent.GetWindowHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if fHandle <> 0 then
+ begin
+ {$IFDEF CREATE_HIDDEN}
+ if {$IFDEF USE_FLAGS} G4_CreateHidden in fFlagsG4
+ {$ELSE} fCreateHidden {$ENDIF} then
+ begin
+ CreateChildWindows;
+ Set_Visible( True );
+ {$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_CreateHidden );
+ {$ELSE} fCreateHidden := False; {$ENDIF}
+ 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;
+ {$ENDIF INPACKAGE}
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+
+ {$IFDEF USE_GRAPHCTLS}
+ if {$IFDEF USE_FLAGS} (G6_GraphicCtl in fFlagsG6)
+ {$ELSE} not fWindowed {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$ENDIF}
+
+ {$IFDEF INPACKAGE}
+ Log( '/// Filling Params' );
+ {$ENDIF INPACKAGE}
+
+ //FillChar( Params, Sizeof( Params ), 0 );
+ ZeroMemory( @Params, Sizeof( Params ) );
+ Params.WindowClass.hCursor := LoadCursor( 0, IDC_ARROW );
+ Params.WindowClass.hInstance := hInstance;
+ Params.WindowClass.lpfnWndProc := fDefWndProc;
+ Params.WindowClass.style := fClsStyle;
+ {$IFDEF _FPC}
+ SClassName := SubClassName;
+ StrCopy( Params.WinClsNamBuf, @ SClassName[ 1 ] );
+ {$ELSE}
+ {$IFNDEF UNICODE_CTRLS}
+ StrCopy( Params.WinClsNamBuf, @ SubClassName[ 1 ] );
+ {$ELSE}
+ TempOleStr := StringToOleStr(AnsiString(SubClassName));
+ lstrcpyW(Params.WinClsNamBuf, TempOleStr); // vampir_infernal 15.10.2008
+ SysFreeString( TempOleStr );
+ {$ENDIF}
+ {$ENDIF}
+ Params.Param := nil;
+ Params.Inst := hInstance;
+ Params.Menu := fMenu;
+ Params.WndParent := GetParentWnd( TRUE );
+ Params.Height := fBoundsRect.Bottom - fBoundsRect.Top;
+ if Params.Height = 0 then
+ Params.Height := CW_UseDefault;
+ Params.Width := fBoundsRect.Right - fBoundsRect.Left;
+ if Params.Width = 0 then
+ Params.Width := CW_UseDefault;
+ Params.Y := fBoundsRect.Top;
+ Params.X := fBoundsRect.Left;
+ if {$IFDEF USE_FLAGS} not(G3_IsControl in fFlagsG3)
+ {$ELSE} not fIsControl {$ENDIF}
+ and {$IFDEF USE_FLAGS} not(G2_ChangedPos in fFlagsG2)
+ {$ELSE} (fChangedPosSz and 3 = 0) {$ENDIF} then
+ begin
+ Params.Y := CW_UseDefault;
+ Params.X := CW_UseDefault;
+ end;
+ Params.Style := fStyle.Value;
+ Params.Caption := PKOLChar( fCaption );
+ Params.WinClassName := @ Params.WinClsNamBuf[ 0 ];
+ Params.ExStyle := fExStyle;
+
+ {$IFDEF INPACKAGE}
+ Log( '/// Getting class info' );
+ {$ENDIF INPACKAGE}
+ 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;
+ end;
+ if fDefWndProc = nil then
+ fDefWndProc := {$ifdef FPC}@{$endif}Params.WindowClass.lpfnWndProc;
+ if Params.WndParent = 0 then
+ if Params.Style and WS_CHILD <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>}
+
+ {$IFNDEF UNICODE_CTRLS}
+ ClassRegistered := GetClassInfo( Params.WindowClass.hInstance,Params.WinClassName, TempClass );
+ {$ELSE}
+ ClassRegistered := GetClassInfoW( Params.WindowClass.hInstance,Params.WinClassName, TempClass );
+ {$ENDIF}
+
+ {$IFDEF INPACKAGE}
+ Log( '/// Registering window class' );
+ {$ENDIF INPACKAGE}
+ if not ClassRegistered then
+ begin
+ Params.WindowClass.lpszClassName := Params.WinClassName;
+ Params.WindowClass.lpfnWndProc := @ WndFunc;
+ {$IFNDEF UNICODE_CTRLS}
+ if RegisterClass( Params.WindowClass ) = 0 then Exit; {>>>>>>>>>>>>>>>>>>>}
+ {$ELSE}
+ if RegisterClassW(Params.WindowClass ) = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>}
+ {$ENDIF}
+ end;
+
+ {$IFDEF DEBUG_CREATEWINDOW}
+ Debug_CreateWindow2( @ Self, Params );
+ {$ENDIF}
+ CreatingWindow := @Self;
+ {$IFDEF INPACKAGE}
+ Log( '/// Calling CreateWindowEx' );
+ {$ENDIF INPACKAGE}
+ {$IFDEF USE_MDI}
+ if Assigned( fCreateWindowProc ) then
+ fHandle := fCreateWindowProc(
+ Params.WinClassName, Params.Caption, Params.Style,
+ Params.X, Params.Y, Params.Width, Params.Height,
+ Params.WndParent, Params.WindowClass.hInstance,
+ Integer( Params.Param ) )
+ else
+ {$ENDIF}
+ begin
+ {$IFNDEF UNICODE_CTRLS}
+ fHandle := CreateWindowEx(
+ Params.ExStyle, Params.WinClassName,
+ Params.Caption, Params.Style, Params.X, Params.Y,
+ Params.Width, Params.Height, Params.WndParent,
+ Params.Menu, Params.WindowClass.hInstance,
+ Params.Param );
+ {$ELSE}
+ fHandle := CreateWindowExW(
+ Params.ExStyle{ or WS_EX_RTLREADING}, Params.WinClassName,
+ Params.Caption, Params.Style, Params.X, Params.Y,
+ Params.Width, Params.Height, Params.WndParent,
+ Params.Menu, Params.WindowClass.hInstance,
+ Params.Param );
+ {$ENDIF}
+ end;
+ {$IFDEF INPACKAGE}
+ Log( '/// CreateWindowEx called' );
+ {$ENDIF INPACKAGE}
+
+
+ {$IFDEF DEBUG_CREATEWINDOW}
+ if fHandle = 0 then
+ begin
+ MessageBox(0,
+ PKOLChar(SysErrorMessage(GetLastError)),
+ 'Error creating window',mb_iconhand);
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ {$ENDIF}
+ {$IFDEF INPACKAGE}
+ Log( '/// SendMessage WM_UPDATEUISTATE' );
+ {$ENDIF INPACKAGE}
+ 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}
+ CreatingWindow := nil;
+ SetWindowLong( FHandle, GWL_USERDATA, Integer(@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}, GetIcon );
+ {$ENDIF}
+ {$IFDEF NIL_EVENTS}
+ if Assigned( PP.FCreateWndExt ) then
+ {$ENDIF}
+ PP.FCreateWndExt( @Self );
+ {$IFDEF INPACKAGE}
+ Log( '/// ApplyFont2Wnd' );
+ {$ENDIF INPACKAGE}
+
+ ApplyFont2Wnd_Proc( @Self );
+ ApplyFont2Wnd_Proc( @Self );
+
+ {$IFDEF INPACKAGE}
+ Log( '/// CreateChildWindows' );
+ {$ENDIF INPACKAGE}
+
+ CreateChildWindows;
+
+ {$IFDEF INPACKAGE}
+ Log( '/// CreateChildWindows called OK' );
+ {$ENDIF INPACKAGE}
+
+ Result := True;
+ {$IFDEF INPACKAGE}
+ LogOK;
+ FINALLY
+ Log( '<-TControl.CreateWindow' );
+ END;
+ {$ENDIF INPACKAGE}
+end;
+{$ENDIF}
+{$ENDIF WIN_GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TControl.VisualizyWindow;
+VAR i: Integer;
+ C: PControl;
+BEGIN
+ IF fHandle = nil THEN Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ IF {$IFDEF USE_FLAGS} not(G3_IsApplet in fFlagsG3)
+ {$ELSE} not fIsApplet {$ENDIF}
+ AND {$IFDEF USE_FLAGS} (F3_Visible in fStyle.f3_Style)
+ {$ELSE} FVisible {$ENDIF} then
+ BEGIN
+ FOR i := 0 to ChildCount-1 do
+ BEGIN
+ C := Children[ i ];
+ if {$IFDEF USE_FLAGS} F3_Visible in fStyle.f3_Style
+ {$ELSE} C.fVisible {$ENDIF} then
+ C.VisualizyWindow;
+ END;
+ gtk_widget_show( fHandle );
+ END;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+//-
+procedure TControl.CreateSubclass(var Params: TCreateParams;
+ ControlClassName: PKOLChar);
+const
+ CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS;
+ CS_ON = 0; //CS_VREDRAW or CS_HREDRAW;
+var
+ SaveInstance: THandle;
+begin
+ if fControlClassName <> nil then
+ with Params do
+ begin
+ SaveInstance := WindowClass.hInstance;
+ {$IFNDEF UNICODE_CTRLS}
+ if not GetClassInfo(HInstance, fControlClassName, WindowClass) and
+ not GetClassInfo(0, fControlClassName, WindowClass)
+ then
+ GetClassInfo(WindowClass.hInstance, fControlClassName, WindowClass);
+ {$ELSE}
+ if not GetClassInfoW(HInstance, pWideChar(fControlClassName), WindowClass) and
+ not GetClassInfoW(0, pWidechar(fControlClassName), WindowClass)
+ then
+ GetClassInfoW(WindowClass.hInstance, pWideChar(fControlClassName), WindowClass);
+ {$ENDIF}
+ WindowClass.hInstance := SaveInstance;
+ WindowClass.style := WindowClass.style and not CS_OFF or CS_ON;
+ end;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function WndProcMouse(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+var MouseData: TMouseEventData;
+begin
+ Result := False;
+ if (Msg.message >= WM_MOUSEFIRST) and (Msg.message <= $20A {WM_MOUSELAST}) then
+ with MouseData do
+ begin
+ Shift := Msg.wParam;
+ if GetKeyState( VK_MENU ) < 0 then
+ Shift := Shift or MK_ALT;
+ X := LoWord( Msg.lParam );
+ Y := HiWord( Msg.lParam );
+ //Button := TMouseButton(Msg.wParam);
+ // not possible: wParam can contain a combination of flags
+ // MK_CONTROL, MK_LBUTTON, MK_RBUTTON, MK_MBUTTON, MK_SHIFT, MK_XBUTTON1, MK_XBUTTON2
+ // So, Shift must be tested.
+ Button := mbNone;
+
+ StopHandling := FALSE;
+ Rslt := 0; // needed ?
+ case Msg.message of
+ WM_LBUTTONDOWN:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseDown ) then
+ {$ENDIF}
+ begin
+ Button := mbLeft;
+ Self_.EV.fOnMouseDown( Self_, MouseData );
+ end;
+ WM_RBUTTONDOWN:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseDown ) then
+ {$ENDIF}
+ begin
+ Button := mbRight;
+ Self_.EV.fOnMouseDown( Self_, MouseData );
+ end;
+ WM_MBUTTONDOWN:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseDown ) then
+ {$ENDIF}
+ begin
+ Button := mbMiddle;
+ Self_.EV.fOnMouseDown( Self_, MouseData );
+ end;
+ WM_LBUTTONUP:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseUp ) then
+ {$ENDIF}
+ begin
+ Button := mbLeft;
+ Self_.EV.fOnMouseUp( Self_, MouseData );
+ end;
+ WM_RBUTTONUP:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseUp ) then
+ {$ENDIF}
+ begin
+ Button := mbRight;
+ Self_.EV.fOnMouseUp( Self_, MouseData );
+ end;
+ WM_MBUTTONUP:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseUp ) then
+ {$ENDIF}
+ begin
+ Button := mbMiddle;
+ Self_.EV.fOnMouseUp( Self_, MouseData );
+ end;
+ WM_MOUSEMOVE:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseMove ) then
+ {$ENDIF}
+ Self_.EV.fOnMouseMove( Self_, MouseData );
+ WM_LBUTTONDBLCLK:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseDblClk ) then
+ {$ENDIF}
+ begin
+ Button := mbLeft;
+ Self_.EV.fOnMouseDblClk( Self_, MouseData );
+ end;
+ WM_RBUTTONDBLCLK:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseDblClk ) then
+ {$ENDIF}
+ begin
+ Button := mbRight;
+ Self_.EV.fOnMouseDblClk( Self_, MouseData );
+ end;
+ WM_MBUTTONDBLCLK:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseDblClk ) then
+ {$ENDIF}
+ begin
+ Button := mbMiddle;
+ Self_.EV.fOnMouseDblClk( Self_, MouseData );
+ end;
+ $020A {WM_MOUSEWHEEL}:
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseWheel ) then
+ {$ENDIF}
+ Self_.EV.fOnMouseWheel( Self_, MouseData );
+ else
+ Exit; //Result := False; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := StopHandling;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function WndProcKeybd(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+var C : KOLChar;
+ Key: Integer;
+begin
+ Result := True;
+ case Msg.message of
+ WM_KEYDOWN, WM_SYSKEYDOWN:
+ begin
+ {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnKeyDown ) then
+ {$ENDIF}
+ Key := Msg.wParam;
+ Self_.EV.fOnKeyDown( Self_, Key, GetShiftState );
+ Msg.wParam := Key;
+ end;
+ WM_KEYUP, WM_SYSKEYUP:
+ begin
+ {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnKeyUp ) then
+ {$ENDIF}
+ Key := Msg.wParam;
+ Self_.EV.fOnKeyUp( Self_, Key, GetShiftState );
+ Msg.wParam := Key;
+ end;
+ WM_CHAR, WM_SYSCHAR:
+ {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnChar ) then
+ {$ENDIF}
+ begin
+ C := KOLChar( Msg.wParam );
+ Self_.EV.fOnChar( Self_, C, GetShiftState );
+ Msg.wParam := Integer( C );
+ end;
+ {$IFDEF SUPPORT_ONDEADCHAR}
+ WM_DEADCHAR, WM_SYSDEADCHAR:
+ {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnDeadChar ) then
+ {$ENDIF}
+ begin
+ C := KOLChar( Msg.wParam );
+ Self_.EV.fOnDeadChar( Self_, C, GetShiftState );
+ Msg.wParam := Integer( C );
+ end;
+ {$ENDIF SUPPORT_ONDEADCHAR}
+ else begin
+ Result := False; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ if Msg.wParam <> 0 then
+ Result := False;
+end;
+{$ENDIF PAS_VERSION}
+
+function WndProcDummy(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+begin
+ Result := False;
+end;
+
+const
+ MM_MCINOTIFY = $3B9;
+
+function WndProcOnClose( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
+ : Boolean;
+var Accept: Boolean;
+begin
+ Result := FALSE;
+ if Msg.message = WM_CLOSE then
+ begin
+ {$IFDEF NEW_MODAL}
+ // version of code by Alexander Pravdin
+ begin
+ Accept := True;
+ if Assigned( Sender.EV.fOnClose ) then
+ begin
+ Sender.EV.fOnClose( Sender, Accept );
+ if AppletRunning then
+ if Accept then
+ if Sender.DF.fModal > 0 then
+ begin
+ if Sender.DF.fModalResult = 0 then
+ Sender.DF.fModalResult := Integer($80000000);
+ Msg.message := 0;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end
+ else
+ TMethod( Sender.EV.fOnClose ).Code :=
+ {$IFDEF NIL_EVENTS} nil
+ {$ELSE} @DummyObjProc {$ENDIF}
+ else
+ begin
+ Rslt := 0;
+ Sender.DF.fModalResult := 0;
+ Result := TRUE;
+ end
+ else TMethod( Sender.EV.fOnClose ).Code :=
+ {$IFDEF NIL_EVENTS} nil
+ {$ELSE} @DummyObjProc {$ENDIF};
+ end else
+ begin
+ if Sender.DF.fModal > 0 then begin
+ if Sender.DF.fModalResult = 0 then
+ Sender.DF.fModalResult := Integer($80000000);
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+
+ if Accept then begin
+ if Sender.IsMainWindow or ( Applet = Sender ) then
+ begin
+ PostQuitMessage( 0 );
+ AppletTerminated := TRUE;
+ Rslt := 0;
+ end
+ else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ {$ELSE}
+ begin
+ Accept := True;
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnClose ) then
+ {$ENDIF}
+ begin
+ Sender.EV.fOnClose( Sender, Accept );
+ if (not Accept) and (AppletRunning) then
+ begin
+ Rslt := 0;
+ Result := TRUE;
+ end else
+ Sender.EV.fOnClose := nil;
+ end;
+ if Accept then
+ begin
+ if Sender.IsMainWindow or (Applet = Sender) then
+ begin
+ PostQuitMessage( 0 );
+ AppletTerminated := TRUE;
+ Rslt := 0;
+ end else
+ Exit; //Default; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ {$ENDIF}
+ end;
+end;
+
+procedure TControl.SetOnClose(const AOnClose: TOnEventAccept);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnClose := AOnClose;
+ AttachProc( WndProcOnClose );
+end;
+
+function WndProcFormOnClick( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := FALSE;
+ if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_LBUTTONDBLCLK) or
+ (Msg.message = WM_RBUTTONDOWN) or (Msg.message = WM_RBUTTONDBLCLK) or
+ (Msg.message = WM_MBUTTONDOWN) or (Msg.message = WM_MBUTTONDBLCLK)
+ then
+ begin
+ {$IFDEF USE_FLAGS}
+ if (Msg.message = WM_RBUTTONDOWN) or
+ (Msg.message = WM_RBUTTONDBLCLK) then
+ include( Sender.fFlagsG6, G6_RightClick )
+ else exclude( Sender.fFlagsG6, G6_RightClick );
+ {$ELSE}
+ Sender.fRightClick := (Msg.message = WM_RBUTTONDOWN) or
+ (Msg.message = WM_RBUTTONDBLCLK);
+ {$ENDIF}
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnClick ) then
+ {$ENDIF}
+ Sender.EV.fOnClick( Sender );
+ end;
+end;
+
+procedure TControl.SetFormOnClick(const AOnClick: TOnEvent);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnClick := AOnClick;
+ AttachProc( WndProcFormOnClick );
+end;
+
+{$IFDEF ASM_VERSION}//------------------
+
+{$DEFINE ASM_LOCAL}
+{$IFDEF NEW_MODAL}
+ {$UNDEF ASM_LOCAL}
+{$ENDIF}
+{$IFDEF USE_MDI}
+ {$UNDEF ASM_LOCAL}
+{$ENDIF}
+
+{$ELSE}//-------------------------------
+
+{$IFDEF ASM_LOCAL}
+ {$UNDEF ASM_LOCAL}
+{$ENDIF}
+
+{$ENDIF}//------------------------------
+
+{$IFDEF USE_GRAPHCTLS}
+ {$UNDEF ASM_LOCAL}
+{$ENDIF}
+
+{$IFDEF ASM_LOCAL}
+{$ELSE ASM_LOCAL} //Pascal
+
+ {$IFDEF DEBUG_CREATEWINDOW}
+ var DbgCWCount: Integer = 0;
+ {$ENDIF DEBUG_CREATEWINDOW}
+function TControl.WndProc( var Msg: TMsg ): Integer;
+var C : PControl;
+ F: HWnd;
+ PassFun: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+
+ procedure Default;
+ begin
+ Result := CallDefWndProc( Msg );
+ end;
+
+begin
+ //RefInc;
+ {$IFDEF INPACKAGE}
+ Log( '->TControl.WndProc' );
+ TRY
+ {$ENDIF INPACKAGE}
+ {$IFDEF DEBUG_CREATEWINDOW}
+ Inc( DbgCWCount );
+ if DbgCWCount < 10 then
+ LogFileOutput( GetStartDir + 'Session.log', 'TControl.WndProc: ' +
+ ' Msg.hwnd=' + Int2Str( Msg.hwnd ) +
+ ' Msg.message=' + Int2Hex( Msg.message, 2 ) +
+ ' Msg.wParam=' + Int2Str( Msg.wParam ) + '=$' + Int2Hex( Msg.wParam, 4 ) +
+ ' Msg.lParam=' + Int2Str( Msg.lParam ) + '=$' + Int2Hex( Msg.lParam, 4 ) );
+ {$ENDIF DEBUG_CREATEWINDOW}
+ if (Msg.hwnd <> 0) and (fHandle = 0)
+ {$IFDEF USE_GRAPHCTLS} and
+ {$IFDEF USE_FLAGS} not(G6_GraphicCtl in fFlagsG6)
+ {$ELSE} fWindowed {$ENDIF} {$ENDIF} then
+ fHandle := Msg.hwnd;
+
+ {$IFDEF DEBUG_MCK} mck_Log( '01' ); {$ENDIF}
+ PassFun := PP.fPass2DefProc;
+ {$IFDEF DEBUG_MCK} mck_Log( '01' ); {$ENDIF}
+ if not (AppletRunning and (Applet <> @Self) and ( Applet <> nil ) and
+ {$IFDEF NIL_EVENTS} Assigned( Applet.EV.fOnMessage ) and {$ENDIF}
+ Applet.EV.fOnMessage( Msg, Result )) then
+ begin {$IFDEF DEBUG_MCK} mck_Log( '02' ); {$ENDIF}
+ if not ({$IFDEF NIL_EVENTS} Assigned( EV.fOnMessage ) and {$ENDIF}
+ EV.fOnMessage( Msg, Result )) then
+ begin {$IFDEF DEBUG_MCK} mck_Log( '03' ); {$ENDIF}
+ if not PP.fOnDynHandlers( @Self, Msg, Result ) then
+ begin {$IFDEF DEBUG_MCK} mck_Log( '04' ); {$ENDIF}
+ //{-2.95}//if not PP.fWndProcResizeFlicks( @Self, Msg, Result ) then
+ begin {$IFDEF DEBUG_MCK} mck_Log( '05' ); {$ENDIF}
+ case Msg.message of
+ WM_CLOSE:
+ begin // handler by default - simple:
+ if (Applet = @ Self) or IsMainWindow then
+ begin
+ PostQuitMessage( 0 );
+ AppletTerminated := TRUE;
+ end;
+ Default;
+ end;
+ (*
+ {$IFDEF USE_PROP}
+ WM_NCDESTROY:
+ begin
+ RemoveProp( fHandle, ID_SELF ); //********* Added By M.Gerasimov
+ //RefDec;
+ end;
+ {$ENDIF}
+ *)
+ WM_NCDESTROY:
+ {$IFnDEF SMALLER_CODE}
+ if fHandle = Msg.hwnd then
+ {$ENDIF}
+ begin
+ {$IFnDEF SMALLER_CODE}
+ {$IFDEF USE_PROP}
+ RemoveProp( fHandle, ID_SELF ); //********* Added By M.Gerasimov
+ {$ELSE}
+ SetWindowLong( fHandle, GWL_USERDATA, 0 ); // VK + Alexey Kirov, 23.02.2012
+ {$ENDIF}
+ {$ENDIF} //-------------------------------------------
+ Default;
+ Exit;
+ end;
+ WM_DESTROY:
+ {$IFnDEF SMALLER_CODE}
+ if fHandle = Msg.hwnd then
+ {$ENDIF}
+ begin
+ {$IFDEF USE_FLAGS} include( fFlagsG2, G2_BeginDestroying );
+ {$ELSE} fBeginDestroying := TRUE; {$ENDIF}
+ Default;
+ {$IFDEF INPACKAGE} LogOK; {$ENDIF INPACKAGE}
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ WM_SIZE: begin
+ {$IFDEF INPACKAGE}
+ Log( 'WM_SIZE >>> Default' );
+ {$ENDIF INPACKAGE}
+ Default;
+ {$IFDEF INPACKAGE}
+ Log( '//// Default called' );
+ {$ENDIF INPACKAGE}
+ {$IFDEF OLD_ALIGN}
+ if {$IFDEF USE_FLAGS} not(G3_IsForm in fFlagsG3)
+ {$ELSE} not fIsForm {$ENDIF} then
+ Global_Align( fParent );
+ {$ENDIF}
+ {$IFDEF INPACKAGE}
+ Log( '//// Before Global_Align' );
+ {$ENDIF INPACKAGE}
+ Global_Align( @Self );
+ {$IFDEF INPACKAGE}
+ LogOK;
+ {$ENDIF INPACKAGE}
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ WM_SysCommand:
+ begin
+ if ((Msg.wParam and $FFF0) = SC_MINIMIZE) and
+ IsMainWindow and (@Self <> Applet) then
+ begin
+ PostMessage( Applet.Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0 );
+ Result := 0;
+ end
+ else Default;
+ end;
+ WM_SETFOCUS:
+ begin
+ if not DoSetFocus then
+ begin
+ Result := 0;
+ end
+ else
+ begin
+ Inc( fClickDisabled );
+ Default;
+ Dec( fClickDisabled );
+ {$IFDEF INPACKAGE}
+ LogOK;
+ {$ENDIF INPACKAGE}
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:
+ begin
+ Result := SendMessage(Msg.LParam, CN_BASE + Msg.message, Msg.WParam, Msg.LParam);
+ end;
+ WM_COMMAND:
+ begin
+ {$IFDEF USE_PROP}
+ C := Pointer( GetProp( Msg.lParam, ID_SELF ) );
+ {$ELSE}
+ C := Pointer( GetWindowLong( Msg.lParam, GWL_USERDATA ) );
+ {$ENDIF}
+ if C <> nil then
+ begin
+ Result := SendMessage( Msg.lParam, CM_COMMAND, Msg.wParam, Msg.lParam );
+ end
+ else Default;
+ end;
+ WM_KEYFIRST..WM_KEYLAST:
+ begin
+ F := GetFocus;
+ if {(F <> fFocusHandle) and} (F <> fHandle)
+ {$IFDEF USE_GRAPHCTLS} and
+ {$IFDEF USE_FLAGS} not(G6_GraphicCtl in fFlagsG6)
+ {$ELSE} fWindowed {$ENDIF} {$ENDIF}
+ {$IFDEF KEY_PREVIEW}
+ and {$IFDEF USE_FLAGS} not(G4_Pushed in fFlagsG4)
+ {$ELSE} not fKeyPreviewing {$ENDIF}
+ {$ENDIF}
+ then
+ begin
+ Result := 0;
+ // Jump to PassFun here. Prevents beep in case when WM_KEYDOWN
+ // called another form and focus is changed, so WM_KEYUP failed
+ // to handle.
+ end
+ else
+ begin
+ {$IFDEF KEY_PREVIEW} //ADDITION JUST FOR CORRECT KEYPREVIEWING
+ {$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_Pushed );
+ {$ELSE} fKeyPreviewing:=false; {$ENDIF}
+ {$ENDIF}
+ if fGlobalProcKeybd( @Self, Msg, Result ) then
+ begin
+ {$IFDEF INPACKAGE}
+ LogOK;
+ {$ENDIF INPACKAGE}
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if PP.fWndProcKeybd( @Self, Msg, Result ) then
+ begin
+ {$IFDEF INPACKAGE}
+ LogOK;
+ {$ENDIF INPACKAGE}
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if ((GetKeystate( VK_CONTROL ) or GetKeyState( VK_MENU )) >= 0) then
+ begin
+ //+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ if (Msg.message <> WM_CHAR) // v1.02 Tabulate AND " in EditBox fix
+ //+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ then
+ begin
+ C := ParentForm;
+ if (C <> nil)
+ {$IFDEF NIL_EVENTS}
+ and Assigned(C.PP.fGotoControl)
+ {$ENDIF}
+ and C.PP.fGotoControl( @Self, Msg.wParam,
+ (Msg.message <> WM_KEYDOWN) and
+ (Msg.message <> WM_SYSKEYDOWN) ) then
+ begin
+ Msg.wParam := 0;
+ Result := 0;
+ end
+ else Default;
+ end else
+ //+++++++++++++++++++++++++++++++++++++++++++++//
+ if Msg.wParam = 9 then // prevent system beep //
+ begin //
+ Msg.wParam := 0; //
+ Result := 0; //
+ end //
+ //+++++++++++++++++++++++++++++++++++++++++++++//
+ else Default;
+ end
+ else Default;
+ end;
+ end;
+ else begin
+ {$IFDEF DEBUG_MCK} mck_Log( 'else' ); {$ENDIF}
+ Default;
+ {$IFDEF INPACKAGE}
+ LogOK;
+ {$ENDIF INPACKAGE}
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+ {$IFDEF DEBUG_MCK} mck_Log( '06' ); {$ENDIF}
+ if not AppletTerminated
+ {$IFDEF USE_fNCDestroyed} and not fNCDestroyed {$ENDIF} then
+ begin {$IFDEF DEBUG_MCK} mck_Log( '07' ); {$ENDIF}
+ PassFun( @Self, Msg, Result ); //+-+
+ {$IFDEF DEBUG_MCK} mck_Log( '08' ); {$ENDIF}
+ end;
+ {$IFDEF INPACKAGE}
+ LogOK;
+ FINALLY
+ Log( '<-TControl.WndProc' );
+ //RefDec;
+ END;
+ {$ELSE}
+ //RefDec;
+ {$ENDIF INPACKAGE}
+end;
+{$ENDIF ASM_LOCAL}
+
+{$UNDEF ASM_LOCAL}
+
+{$ENDIF WIN_GDI}
+{$IFDEF GDI}
+procedure SetMouseEvent( Self_: PControl );
+begin
+ Self_.AttachProc( WndProcMouse );
+end;
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION mouse_events_handler( Obj: PGtkWidget; VAR Event: TGdkEventAny ): Boolean;
+ CDECL;
+VAR Sender: PControl;
+ M: TMouseEventData;
+ PROCEDURE PrepareMouseEvent( const Evt: TGdkEventMotion );
+ BEGIN
+ M.Button := mbNone;
+ if Evt.state and GDK_BUTTON1_MASK <> 0 then M.Button := mbLeft
+ else
+ if Evt.state and GDK_BUTTON2_MASK <> 0 then M.Button := mbRight
+ else
+ if Evt.state and GDK_BUTTON3_MASK <> 0 then M.Button := mbMiddle;
+ M.Shift := 0;
+ if Evt.state and GDK_SHIFT_MASK <> 0 then M.Shift := MK_SHIFT;
+ if Evt.state and GDK_CONTROL_MASK <> 0 then M.Shift := M.Shift or MK_CONTROL;
+ if Evt.state and GDK_LOCK_MASK <> 0 then M.Shift := M.Shift or MK_LOCK;
+ if Evt.state and GDK_BUTTON1_MASK <> 0 then M.Shift := M.Shift or MK_LBUTTON;
+ if Evt.state and GDK_BUTTON2_MASK <> 0 then M.Shift := M.Shift or MK_RBUTTON;
+ if Evt.state and GDK_BUTTON3_MASK <> 0 then M.Shift := M.Shift or MK_MBUTTON;
+ if Evt.state and GDK_LOCK_MASK <> 0 then M.Shift := M.Shift or MK_LOCK;
+ M.X := Round( Evt.x );
+ M.Y := Round( Evt.y );
+ END;
+VAR scrl: PGdkEventScroll;
+ z: SmallInt;
+BEGIN
+ Result := FALSE;
+ //Sender := Pointer( Event.window );
+ Sender := g_object_get_data( G_OBJECT( Obj ), ID_SELF );
+ CASE Event._type OF
+ GDK_MOTION_NOTIFY,
+ GDK_BUTTON_PRESS,
+ GDK_2BUTTON_PRESS,
+ GDK_3BUTTON_PRESS, // тройной клик мыши - считать как двойной?
+ GDK_BUTTON_RELEASE,
+ GDK_SCROLL: ;
+ else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ END;
+ PrepareMouseEvent( PGdkEventMotion( @ Event )^ );
+ CASE Event._type OF
+ GDK_MOTION_NOTIFY :
+ BEGIN
+ IF Assigned( Sender.fOnMouseMove ) THEN
+ BEGIN
+ Sender.fOnMouseMove( Sender, M );
+ Result := TRUE;
+ END;
+ END;
+ GDK_BUTTON_PRESS :
+ BEGIN
+ IF Assigned( Sender.fOnMouseDown ) THEN
+ BEGIN
+ Sender.fOnMouseDown( Sender, M );
+ Result := TRUE;
+ END;
+ END;
+ GDK_2BUTTON_PRESS,
+ GDK_3BUTTON_PRESS :
+ BEGIN
+ IF Assigned( Sender.fOnMouseDblClk ) THEN
+ BEGIN
+ {$IFDEF USE_FLAGS}
+ IF Event._type = GDK_3BUTTON_PRESS THEN
+ include( Sender.fFlagsG5, G5_3ButtonPress )
+ ELSE exclude( Sender.fFlagsG5, G5_3ButtonPress );
+ {$ELSE}
+ Sender.f3ButtonPress := Event._type = GDK_3BUTTON_PRESS;
+ {$ENDIF}
+ Sender.fOnMouseDblClk( Sender, M );
+ Result := TRUE;
+ END;
+ END;
+ GDK_BUTTON_RELEASE :
+ BEGIN
+ IF Assigned( Sender.fOnMouseUp ) THEN
+ BEGIN
+ Sender.fOnMouseUp( Sender, M );
+ Result := TRUE;
+ END;
+ if Assigned( Sender.fOnClick ) then
+ Sender.fOnClick( Sender );
+ END;
+ GDK_SCROLL :
+ BEGIN
+ IF Assigned( Sender.fOnMouseWheel ) THEN
+ BEGIN
+ scrl := @ Event;
+ IF scrl.direction = GDK_SCROLL_UP THEN
+ z := 120
+ ELSE IF scrl.direction = GDK_SCROLL_DOWN THEN
+ z := -120 //todo: direction and value?
+ ELSE
+ z := 0;
+ M.Shift := M.Shift or DWord(z shl 16);
+ Sender.fOnMouseWheel( Sender, M );
+ Result := TRUE;
+ END;
+ END;
+ END;
+END;
+
+PROCEDURE SetMouseEvent( Self_: PControl; event_name: PAnsiChar );
+BEGIN
+ gtk_signal_connect( GTK_OBJECT( Self_.fEventboxHandle ), event_name,
+ @mouse_events_handler, Self_ );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+function TControl.Get_OnMouseEvent(const Index: Integer): TOnMouse;
+begin
+ Result := TOnMouse( EV.MethodEvents[Index] );
+end;
+
+procedure TControl.SetOnMouseEvent(const Index: Integer;
+ const Value: TOnMouse);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .MethodEvents[Index] := TMethod( Value );
+ AttachProc( WndProcMouse );
+end;
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetClsStyle( Value: DWord );
+begin
+ if fClsStyle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fClsStyle := Value;
+ if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ SetClassLong( fHandle, GCL_STYLE, Value );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetStyle( Value: DWord );
+begin
+ if fStyle.Value = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fStyle.Value := Value;
+ if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ SetWindowLong( fHandle, GWL_STYLE, Value );
+
+ SetWindowPos( fHandle, 0, 0, 0, 0, 0,
+ SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or
+ SWP_NOZORDER or SWP_FRAMECHANGED );
+ Invalidate;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF GRAPHCTL_XPSTYLES}
+function TControl.GetEdgeStyle: TEdgeStyle;
+begin
+ Result := esRaised;
+ if Style and WS_DLGFRAME = 0 then
+ begin
+ if Style and SS_SUNKEN <> 0 then
+ Result := esLowered
+ else
+ Result := esNone;
+ end;
+end;
+
+procedure TControl.SetEdgeStyle( Value: TEdgeStyle );
+begin
+ {$IFDEF STORE_EDGESTYLE}
+ if fedgeStyle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fedgeStyle := Value;
+ {$ENDIF}
+ if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ case Value of
+ esRaised:
+ begin
+ Style := Style and (not SS_SUNKEN);
+ ExStyle := ExStyle and (not WS_EX_STATICEDGE);
+ ExStyle := ExStyle or WS_EX_WINDOWEDGE;
+ Style := Style or WS_DLGFRAME;
+ end;
+ esLowered:
+ begin
+ Style := Style and (not WS_DLGFRAME);
+ ExStyle := ExStyle or WS_EX_WINDOWEDGE;
+ ExStyle := ExStyle or WS_EX_STATICEDGE;
+ Style := Style or SS_SUNKEN;
+ end;
+ else
+ Style := Style and (not SS_SUNKEN) and (not WS_DLGFRAME);
+ ExStyle := ExStyle and (not WS_EX_STATICEDGE) or WS_EX_WINDOWEDGE;
+ end;
+
+ Invalidate;
+end;
+{$ENDIF}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetExStyle( Value: DWord );
+begin
+ if fExStyle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fExStyle := Value;
+ if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ SetWindowLong( fHandle, GWL_EXSTYLE, Value );
+
+ SetWindowPos( fHandle, 0, 0, 0, 0, 0,
+ SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or
+ SWP_NOZORDER or SWP_FRAMECHANGED );
+ Invalidate;
+end;
+{$ENDIF PAS_VERSION}
+
+function WndProcSetCursor( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var Cur: HCursor;
+begin
+ Result := FALSE;
+ if Msg.message = WM_SETCURSOR then
+ begin
+ if (GetCapture = 0) and
+ (LOWORD( Msg.lParam ) = HTCLIENT) then
+ begin
+ if ScreenCursor <> 0 then //YS
+ Cur := ScreenCursor //YS
+ else Cur := Self_.fCursor; //YS
+ if Cur <> 0 then //YS
+ begin //YS
+ Windows.SetCursor( Cur ); //YS
+ Rslt := 1; //YS
+ Result := TRUE;
+ end;
+ end;
+ end;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetCursor( Value: HCursor );
+var P: TPoint;
+begin
+ AttachProc( WndProcSetCursor );
+ if fCursor = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fCursor := Value;
+ if (fHandle = 0) or (fCursor = 0) then Exit; //YS {>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if ScreenCursor <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ GetCursorPos( P );
+ P := Screen2Client( P );
+ if PointInRect( P, ClientRect ) then
+ Windows.SetCursor( Value );
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.CursorLoad(Inst: Integer; ResName: PKOLChar);
+begin
+ Cursor := LoadCursor( Inst, ResName );
+ //{$IFDEF USE_FLAGS} include( fFlagsG1, G1_CursorShared );
+ //{$ELSE} fCursorShared := TRUE; {$ENDIF}
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetIcon( Value: HIcon );
+var OldIco: HIcon;
+begin
+ if DF.fIcon = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ DF.fIcon := Value;
+ if Value = THandle(-1) then
+ Value := 0;
+ OldIco := Perform( WM_SETICON, 1 {ICON_BIG}, Value );
+ if OldIco <> 0 then
+ DestroyIcon( OldIco );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+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
+ DestroyMenu( fMenu );
+ fMenu := Value;
+ if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Windows.SetMenu( fHandle, Value );
+end;
+{$ENDIF PAS_VERSION}
+
+procedure CallWinHelp( Context: Integer; CtxCtl: PControl );
+var Cmd: Integer;
+ Form: PControl;
+ Popup: Boolean;
+begin
+ Cmd := HELP_CONTEXT;
+ if CtxCtl <> nil then
+ begin
+ Form := CtxCtl.ParentForm;
+ if Form <> nil then
+ if Assigned( Form.EV.fOnHelp ) then
+ begin
+ Popup := FALSE;
+ Form.EV.fOnHelp( CtxCtl, Context, Popup );
+ if Popup then
+ Cmd := HELP_CONTEXTPOPUP;
+ if CtxCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end
+ else
+ if Context = 0 then
+ Cmd := HELP_CONTENTS;
+ WinHelp( Applet.Handle, PKOLChar( Applet.GetHelpPath ), Cmd, Context );
+end;
+
+var HHCtrl: THandle;
+ HtmlHelp: procedure( Wnd: HWnd; Path: PKOLChar; Cmd, Data: Integer ); stdcall;
+
+procedure HtmlHelpCommand( Wnd: HWnd; const HelpFilePath: KOLString; Cmd, Data: Integer );
+begin
+ if HHCtrl = 0 then
+ HHCtrl := LoadLibrary( 'HHCTRL.OCX' );
+ if HHCtrl = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if not Assigned( HtmlHelp ) then
+ HtmlHelp := GetProcAddress( HHCtrl,
+ {$IFDEF UNICODE_CTRLS} 'HtmlHelpW' {$ELSE} 'HtmlHelpA' {$ENDIF} );
+ if not Assigned( HtmlHelp ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ HtmlHelp( Wnd, PKOLChar( HelpFilePath ), Cmd, Data );
+end;
+
+procedure CallHtmlHelp( Context: Integer; CtxCtl: PControl );
+var Cmd: Integer;
+ Form: PControl;
+ Popup: Boolean;
+ Ids: array[ 0..2 ] of DWORD;
+begin
+
+ Cmd := $F; // HH_HELP_CONTEXT;
+ if CtxCtl <> nil then
+ begin
+ Form := CtxCtl.ParentForm;
+ if Form <> nil then
+ if Assigned( Form.EV.fOnHelp ) then
+ begin
+ Popup := FALSE;
+ Form.EV.fOnHelp( CtxCtl, Context, Popup );
+ if Popup then
+ begin
+ Cmd := $10; //HH_TP_HELPCONTEXTMENU;
+ Ids[ 0 ] := CtxCtl.fMenu;
+ Ids[ 1 ] := Context;
+ Ids[ 2 ] := 0;
+ Context := Integer( @ Ids );
+ end;
+ if CtxCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end
+ else
+ if Context = 0 then
+ Cmd := 1; // HH_DISPLAY_TOC;
+ HtmlHelpCommand( {$IFDEF HTMLHELP_NOTOP} 0 {$ELSE} Applet.Handle {$ENDIF},
+ HelpFilePath, Cmd, Context );
+end;
+
+var
+ Global_HelpProc: procedure( Context: Integer; CtxCtl: PControl ) = CallWinHelp;
+
+function WndProcHelp( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var HI: PHelpInfo;
+ Ctx: Integer;
+ Ctl: PControl;
+begin
+ Result := FALSE;
+ if Msg.message = WM_HELP then
+ begin
+ Ctx := 0;
+ Ctl := nil;
+ HI := Pointer( Msg.lParam );
+ if HI.iContextType = HELPINFO_WINDOW then
+ begin
+ {$IFDEF USE_PROP}
+ Ctl := Pointer( GetProp( HI.hItemHandle, ID_SELF ) );
+ {$ELSE}
+ Ctl := Pointer( GetWindowLong( HI.hItemHandle, GWL_USERDATA ) );
+ {$ENDIF}
+ while Ctl <> nil do
+ begin
+ Ctx := Ctl.HelpContext;
+ if Ctx <> 0 then break;
+ Ctl := Ctl.Parent;
+ end;
+ end
+ else
+ Ctx := GetMenuContextHelpID( HI.hItemHandle );
+ Applet.CallHelp( Ctx, Ctl );
+ Rslt := 1;
+ Result := TRUE;
+ end
+ {$IFDEF AUTO_CONTEXT_HELP}
+ else
+ if (Msg.message = WM_CONTEXTMENU) then
+ begin
+ {$IFDEF USE_PROP}
+ Ctl := Pointer( GetProp( Msg.wParam, ID_SELF ) );
+ {$ELSE}
+ Ctl := Pointer( GetWindowLong( Msg.wParam, GWL_USERDATA ) );
+ {$ENDIF}
+ if (Ctl <> nil) and (Ctl.HelpContext <> 0) then
+ begin
+ Applet.CallHelp( Ctl.HelpContext, Ctl );
+ Rslt := 1;
+ Result := TRUE;
+ end;
+ end
+ {$ENDIF};
+end;
+
+procedure TControl.SetHelpContext(Value: Integer);
+var F: PControl;
+begin
+ F := ParentForm;
+ if F = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ F.AttachProc( WndProcHelp );
+ SetWindowContextHelpId( GetWindowHandle, Value );
+end;
+
+function TControl.AssignHelpContext(Context: Integer): PControl;
+begin
+ SetHelpContext( Context );
+ Result := @ Self;
+end;
+
+procedure AssignHtmlHelp( const HtmlHelpPath: KOLString );
+var Lbytes: Integer;
+begin
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( (HtmlHelpPath <> '') and (Applet <> nil), 'Error parameters' );
+ {$ENDIF KOL_ASSERTIONS}
+ if HelpFilePath <> '' then
+ FreeMem( HelpFilePath );
+ Lbytes := (Length( HtmlHelpPath ) + 1) * Sizeof( KOLChar );
+ GetMem( HelpFilePath, Lbytes );
+ Move( HtmlHelpPath[ 1 ], HelpFilePath^, Lbytes );
+ Global_HelpProc := CallHtmlHelp;
+ Applet.AttachProc( WndProcHelp );
+end;
+
+procedure TControl.CallHelp(Context: Integer; CtxCtl: PControl {; CtlID: Integer} );
+begin
+ Global_HelpProc( Context, CtxCtl {, CtlID} );
+end;
+
+function TControl.GetHelpPath: KOLString;
+begin
+ Result := KOLString(HelpFilePath);
+ if Result = '' then
+ begin
+ Result := ParamStr( 0 );
+ Result := ReplaceFileExt( Result, '.hlp' );
+ end;
+end;
+
+procedure TControl.SetHelpPath(const Value: KOLString);
+var Lbytes: Integer;
+begin
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( Value <> '', 'Error parameter' );
+ {$ENDIF KOL_ASSERTIONS}
+ if HelpFilePath <> '' then
+ FreeMem( HelpFilePath );
+ Lbytes := (Length( Value ) + 1)*Sizeof( KOLChar );
+ GetMem( HelpFilePath, Lbytes );
+ Move( Value[ 1 ], HelpFilePath^, Lbytes );
+end;
+{$ENDIF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE}
+procedure TControl.DoAutoSize;
+begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( PP.fAutoSize ) then
+ {$ENDIF}
+ PP.fAutoSize( @Self );
+end;
+{$ENDIF}
+
+{$IFDEF GDI}
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetCaption: KOLString;
+var Sz: Integer;
+begin
+ if {$IFDEF USE_FLAGS} not(G1_IgnoreWndCaption in fFlagsG1)
+ {$ELSE} not fIgnoreWndCaption {$ENDIF}
+ and (FHandle <> 0) then
+ begin
+ Sz := GetWindowTextLength( FHandle );
+ SetLength( fCaption, Sz );
+ if Sz > 0 then
+ begin
+ {$IFNDEF UNICODE_CTRLS}
+ GetWindowText( FHandle, @ fCaption[ 1 ], Sz + 1 );
+ {$ELSE}
+ GetWindowTextW( FHandle, @ fCaption[ 1 ], Sz + 1 );
+ {$ENDIF}
+ end;
+ end;
+ Result := FCaption;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION TControl.GetCaption: KOLString;
+BEGIN
+ if {$IFDEF USE_FLAGS} not (G1_IgnoreWndCaption in fFlagsG1)
+ {$ELSE} fIgnoreWndCaption {$ENDIF} then
+ FCaption := fGetCaption(@Self);
+ Result := FCaption;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetCaption( const Value: KOLString );
+begin
+ fCaption := Value;
+ if fHandle <> 0 then
+ SendMessage( fHandle, WM_SETTEXT,
+ 0, Integer( PKOLChar( Value ) ) );
+ if {$IFDEF USE_FLAGS} (G1_IsStaticControl in fFlagsG1)
+ {$ELSE} fIsStaticControl <> 1 {$ENDIF} then
+ Invalidate;
+ DoAutoSize;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TControl.SetCaption( CONST Value: KOLString );
+BEGIN
+ fCaption := Value;
+ if Assigned( fSetCaption ) THEN
+ fSetCaption( @Self, Value );
+ DoAutoSize;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+{$IFDEF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+function TControl.GetVisible: Boolean;
+begin
+ //UpdateWndStyles;
+ {$IFDEF USE_FLAGS}
+ {if (fHandle <> 0) then
+ Result := //IsWindowVisible( fHandle ) -- incorrectly is false in OnShow !
+ GetWindowLong( fHandle, GWL_STYLE ) and WS_VISIBLE <> 0
+ else}
+ Result := F3_Visible in fStyle.f3_Style;
+ {$ELSE}
+ {if (fHandle <> 0) then
+ fVisible := IsWindowVisible( fHandle )
+ else}
+ fVisible := (FStyle.Value and WS_VISIBLE) <> 0;
+ Result := fVisible;
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // Pascal
+function TControl.Get_Visible: Boolean;
+begin
+ {$IFDEF USE_FLAGS}
+ Result := GetVisible;
+ {$ELSE}
+ if (fHandle <> 0) and not fIsControl then
+ fVisible := IsWindowVisible( fHandle );
+ Result := fVisible;
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // Pascal
+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;
+ {$IFDEF USE_FLAGS}
+ {$ELSE}
+ fVisible := Value;
+ {$ENDIF}
+ if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Value then
+ begin
+ Global_Align( @Self );
+ ShowWindow( fHandle, SW_SHOW );
+ end else
+ begin
+ {$IFDEF CREATE_HIDDEN}
+ {$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_CreateHidden );
+ {$ELSE} fCreateHidden := FALSE; {$ENDIF} // { +++ }
+ {$ENDIF CREATE_HIDDEN}
+ ShowWindow( fHandle, SW_HIDE );
+ Global_Align( @Self );
+ end;
+{$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure TControl.SetVisible( Value: Boolean );
+begin
+ {$IFDEF USE_FLAGS} include( fFlagsG4, G4_CreateVisible );
+ {$ELSE} fCreateVisible := TRUE; {$ENDIF}
+ Set_Visible( Value );
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF WIN_GDI}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetBoundsRect: TRect;
+var W: HWnd;
+ P: TPoint;
+begin
+ Result := fBoundsRect;
+ if fHandle <> 0 then
+ begin
+ GetWindowRect( fHandle, Result );
+ if {$IFDEF USE_FLAGS} ([G3_IsControl, G3_IsMDIChild] * fFlagsG3 <> [])
+ {$ELSE} fIsControl or fIsMDIChild {$ENDIF}
+ then
+ begin
+ W := ParentWindow;
+ if W <> 0 then
+ begin
+ P.x := 0; P.y := 0;
+ Windows.ClientToScreen( W, P );
+ OffsetRect( Result, -P.x, -P.y );
+ end;
+ end;
+ {$IFDEF TEST_BOUNDSRECT}
+ if not CompareMem( @ fBoundsRect, @ Result, Sizeof( TRect ) ) then
+ {$ENDIF}
+ fBoundsRect := Result;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION TControl.GetBoundsRect: TRect;
+VAR R: TRect;
+ window: PGtkWindow;
+ requisition: TGtkRequisition;
+BEGIN
+ //if fHandle <> nil then
+ BEGIN
+ IF fIsControl THEN
+ BEGIN
+ R.Left := fBoundsRect.Left;
+ R.Top := fBoundsRect.Top;
+ gtk_widget_get_size_request( fEventboxHandle, @ R.Right, @ R.Bottom );
+ gtk_widget_size_request( fHandle, @ requisition );
+ IF R.Right < 0 THEN R.Right := requisition.width;
+ IF R.Bottom < 0 THEN R.Bottom := requisition.height;
+ END ELSE
+ BEGIN
+ window := GTK_WINDOW( fHandle );
+ gtk_window_get_position(window, @ R.Left, @ R.Top);
+ gtk_window_get_size(window, @ R.Right, @ R.Bottom);
+ END;
+ inc( R.Right, R.Left );
+ inc( R.Bottom, R.Top );
+ fBoundsRect := R;
+ END;
+ Result := fBoundsRect;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetBoundsRect( const Value: TRect );
+var Rect: TRect;
+begin
+ Rect := GetBoundsRect;
+ if RectsEqual( Value, Rect ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF USE_FLAGS}
+ if (Value.Left <> fBoundsRect.Left) or (Value.Top <> fBoundsRect.Top) then
+ include( fFlagsG2, G2_ChangedPos );
+ {$ELSE}
+ if Value.Left <> fBoundsRect.Left then fChangedPosSz := fChangedPosSz or 1;
+ if Value.Top <> fBoundsRect.Top then fChangedPosSz := fChangedPosSz or 2;
+ {$ENDIF}
+ {$IFDEF USE_GRAPHCTLS}
+ if {$IFDEF USE_FLAGS} (G6_GraphicCtl in fFlagsG6)
+ {$ELSE} not fWindowed {$ENDIF} then
+ Invalidate;
+ {$ENDIF}
+
+ fBoundsRect := Value;
+ Rect := Value;
+
+ if fHandle <> 0 then
+ begin
+ SetWindowPos( fHandle, 0, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
+ Rect.Bottom - Rect.Top, SWP_NOZORDER or SWP_NOACTIVATE );
+ end;
+ if {$IFDEF USE_FLAGS} (G1_SizeRedraw in fFlagsG1)
+ {$ELSE} fSizeRedraw {$ENDIF} then
+ Invalidate;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TControl.SetBoundsRect( const Value: TRect );
+VAR Rect: TRect;
+ window: PGtkWindow;
+BEGIN
+ Rect := GetBoundsRect;
+ if RectsEqual( Value, Rect ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF USE_FLAGS}
+ if (Value.Left <> fBoundsRect.Left) or (Value.Top <> fBoundsRect.Top) then
+ include( fFlagsG2, G2_ChangedPos );
+ {$ELSE}
+ if Value.Left <> fBoundsRect.Left then fChangedPosSz := fChangedPosSz or 1;
+ if Value.Top <> fBoundsRect.Top then fChangedPosSz := fChangedPosSz or 2;
+ {$ENDIF}
+ fBoundsRect := Value;
+ Rect := Value;
+
+ IF fIsControl then
+ BEGIN
+ //gtk_widget_set_uposition( fHandle, Rect.Left, Rect.Top );
+ IF fParent <> nil then
+ fParent.fChildSetPos( fParent, @ Self, Rect.Left, Rect.Top );
+ IF (Rect.Right > Rect.Left) and (Rect.Bottom > Rect.Top) then
+ gtk_widget_set_size_request( fEventboxHandle,
+ Rect.Right - Rect.Left, Rect.Bottom - Rect.Top );
+ END ELSE
+ BEGIN
+ window := GTK_WINDOW( fHandle );
+ gtk_window_move( window, Rect.Left, Rect.Top );
+ gtk_window_resize( window, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top );
+ END;
+ //if fSizeRedraw then
+ // Invalidate;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+const
+ WindowStateShowCommands: array[TWindowState] of Byte =
+ (SW_SHOWNOACTIVATE, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetWindowState( Value: TWindowState );
+begin
+ if WindowState <> Value then
+ begin
+ DF.fWindowState := Value;
+ if fHandle <> 0 then
+ ShowWindow(fHandle, WindowStateShowCommands[Value]);
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.Show;
+begin
+ CreateWindow;
+ SetVisible( True );
+ SetForegroundWindow( Handle );
+ DoSetFocus;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.Hide;
+begin
+ SetVisible( False );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.Client2Screen( const P: TPoint ): TPoint;
+begin
+ Result := P;
+ if fHandle <> 0 then
+ Windows.ClientToScreen( fHandle, Result );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.Screen2Client( const P: TPoint ): TPoint;
+begin
+ Result := P;
+ if Handle <> 0 then
+ Windows.ScreenToClient( Handle, Result );
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF WIN_GDI}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.ClientRect: TRect;
+const BorderParams: array[ 0..5 ] of DWORD =
+ ( SM_CXBORDER, SM_CXFRAME, SM_CXSIZEFRAME, SM_CYBORDER, SM_CYFRAME, SM_CYSIZEFRAME );
+begin
+ Result := fBoundsRect;
+ GetWindowHandle;
+ if (fHandle <> 0) then
+ GetClientRect( fHandle, Result );
+ Inc( Result.Top, fClientTop );
+ Dec( Result.Bottom, fClientBottom );
+ Inc( Result.Left, fClientLeft );
+ Dec( Result.Right, fClientRight );
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION TControl.ClientRect: TRect; //todo: implement exact, now for PaintBox only
+BEGIN
+ Result := fBoundsRect;
+ OffsetRect( Result, -Result.Left, -Result.Top );
+ Inc( Result.Top, fClientTop );
+ Dec( Result.Bottom, fClientBottom );
+ Inc( Result.Left, fClientLeft );
+ Dec( Result.Right, fClientRight );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+procedure TControl.Invalidate;
+begin
+ {$IFDEF USE_GRAPHCTLS}
+ PP.fDoInvalidate( @Self );
+ {$ELSE}
+ if fHandle <> 0 then
+ InvalidateRect( fHandle, nil, TRUE );
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TControl.Invalidate;
+BEGIN
+ gtk_widget_queue_draw_area( fHandle, 0, 0, Width, Height );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+{$IFDEF USE_GRAPHCTLS}
+procedure InvalidateNonWindowed( Sender: PObj );
+var R: TRect;
+begin
+ R := PControl( Sender ).BoundsRect;
+ if PControl( Sender ).fParent.fHandle <> 0 then
+ InvalidateRect( PControl( Sender ).fParent.fHandle, @ R, TRUE );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+procedure InvalidateWindowed( Sender: PObj );
+begin
+ if PControl( Sender ).fHandle <> 0 then
+ InvalidateRect( PControl( Sender ).fHandle, nil, TRUE );
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF USE_GRAPHCTLS}
+
+{$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;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.IconLoad(Inst: Integer; ResName: PKOLChar);
+begin
+ Icon := LoadIcon( Inst, ResName );
+ {$IFDEF USE_FLAGS} include( fFlagsG1, G1_IconShared );
+ {$ELSE} fIconShared := TRUE; {$ENDIF}
+end;
+
+procedure TControl.IconLoadCursor(Inst: Integer; ResName: PKOLChar);
+begin
+ Icon := LoadCursor( Inst, ResName );
+ {$IFDEF USE_FLAGS} include( fFlagsG1, G1_IconShared );
+ {$ELSE} fIconShared := TRUE; {$ENDIF}
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.CallDefWndProc(var Msg: TMsg): Integer;
+begin
+ {$IFDEF INPACKAGE}
+ Result := 0;
+ Log( '->TControl.CallDefWndProc FHandle = ' + Int2Str( FHandle ) +
+ ', Msg.hwd = ' + Int2Str( Msg.hwnd ) );
+ TRY
+ {$ENDIF INPACKAGE}
+ if FDefWndProc <> nil then
+ begin
+ {$IFDEF INPACKAGE}
+ Log( '//// CallWindowProc, FDefWndProc = ' + Int2Hex( DWORD( FDefWndProc ), 6 ) );
+ TRY
+ TRY
+ {$ENDIF INPACKAGE}
+ Result := CallWindowProc(
+ FDefWndProc, FHandle, Msg.message, Msg.wParam, Msg.lParam );
+ {$IFDEF INPACKAGE}
+ EXCEPT on E: Exception do
+ Log( '*** Exception in CallWindowProc, msg = ' + E.Message );
+ END;
+ EXCEPT
+ Log( '*** Exception handled' );
+ END;
+ {$ENDIF INPACKAGE}
+ end
+ else
+ begin
+ {$IFDEF INPACKAGE}
+ Log( '//// DefWindowProc' );
+ {$ENDIF INPACKAGE}
+ Result := DefWindowProc( Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam );
+ end;
+ {$IFDEF INPACKAGE}
+ LogOK;
+ FINALLY
+ Log( '<-TControl.CallDefWndProc' );
+ END;
+ {$ENDIF INPACKAGE}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetWindowState: TWindowState;
+begin
+ Result := DF.fWindowState;
+ if Handle <> 0 then
+ begin
+ if IsIconic( Handle ) then
+ Result := wsMinimized
+ else
+ if IsZoomed( Handle ) then
+ Result := wsMaximized
+ else
+ Result := wsNormal;
+ //DF.fWindowState := Result;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.DoSetFocus: Boolean;
+begin
+ Result := False;
+ //if Enabled and (
+ // {$IFDEF USE_FLAGS}{$ELSE} fTabstop or {$ENDIF}
+ // (F2_Tabstop in fStyle.f2_Style)) then
+ if Enabled then
+ begin
+ Inc( fClickDisabled );
+ SetFocus( fHandle );
+ Dec( fClickDisabled );
+ Result := True;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function TControl.HandleAllocated: Boolean;
+begin
+ Result := FHandle <> 0;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetEnabled: Boolean;
+begin
+ if FHandle = 0 then
+ Result := (Style and WS_DISABLED) = 0
+ else Result := IsWindowEnabled( FHandle );
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.IsMainWindow: Boolean;
+begin
+ if Applet = nil then
+ Result := not IsControl
+ else if not AppButtonUsed then
+ Result := @ Self = Applet
+ else
+ Result := Applet.Children[ 0 ] = @ Self;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TControl.get_ClassName: KOLString;
+begin
+ Result := fControlClassName;
+ if {$IFDEF USE_FLAGS} not(G6_CtlClassNameChg in fFlagsG6)
+ {$ELSE} not fCtlClsNameChg {$ENDIF} then
+ Result := KOLString('obj_') + Result;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.set_ClassName(const Value: KOLString);
+begin
+ if {$IFDEF USE_FLAGS} G6_CtlClassNameChg in fFlagsG6
+ {$ELSE} fCtlClsNameChg {$ENDIF} then
+ FreeMem( fControlClassName );
+ GetMem( fControlClassName, (Length( Value ) + 1) * Sizeof( KOLChar ) );
+ {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
+ ( fControlClassName, @ Value[ 1 ] );
+ {$IFDEF USE_FLAGS} include( fFlagsG6, G6_CtlClassNameChg );
+ {$ELSE} fCtlClsNameChg := TRUE; {$ENDIF}
+end;
+
+function WndProcQueryEndSession( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var Accept: Boolean;
+begin
+ Result := FALSE;
+ if Msg.message = WM_QUERYENDSESSION then
+ begin
+ {$IFDEF DEBUG_ENDSESSION}
+ LogFileOutput( GetStartDir + 'end_session.txt', '!' );
+ {$ENDIF}
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnQueryEndSession ) then
+ {$ENDIF}
+ begin
+ Accept := TRUE;
+ Sender.DF.fCloseQueryReason := qShutdown;
+ if LongBool(Msg.lParam and {ENDSESSION_LOGOFF} DWORD($80000000)) then
+ Sender.DF.fCloseQueryReason := qLogoff;
+ Sender.EV.fOnQueryEndSession( Sender, Accept );
+ Sender.DF.fCloseQueryReason := qClose;
+ Rslt := Integer( Accept );
+ // Добавить. Нужно для того, чтобы отменилось завершение сеанса,
+ // если Accept установлен в False и сеанс завершился при Accept = True
+ // Add (YS). To cancel ending session if Accept=FALSE but allow ending
+ // session if Accept=TRUE.
+ Result := True; // {YS}: no further processing
+ end;
+ end;
+end;
+
+procedure TControl.SetOnQueryEndSession(const Value: TOnEventAccept);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnQueryEndSession := Value;
+ AttachProc( WndProcQueryEndSession );
+end;
+
+function WndProcMinMaxRestore( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := FALSE;
+ if Msg.message = WM_SYSCOMMAND then
+ begin
+ case Msg.wParam and not 15 of
+ SC_MINIMIZE: {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnMinimize ) then
+ {$ENDIF}
+ Sender.EV.fOnMinimize( Sender );
+ SC_MAXIMIZE: {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnMaximize ) then
+ {$ENDIF}
+ Sender.EV.fOnMaximize( Sender );
+ SC_RESTORE: {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnRestore ) then
+ {$ENDIF}
+ Sender.EV.fOnRestore( Sender );
+ end;
+ end;
+end;
+
+procedure TControl.SetOnMinMaxRestore(const Index: Integer;
+ const Value: TOnEvent);
+type POnEvent = ^TOnEvent;
+{$IFDEF F_P}
+var Ptr1: Pointer;
+{$ELSE DELPHI}
+var Evt: POnEvent;
+{$ENDIF F_P/DELPHI}
+begin
+ {$IFDEF F_P}
+ Ptr1 := Self;
+ asm
+ MOV EAX, [Ptr1]
+ LEA EAX, [EAX].TControl.fOnMinimize
+ ADD EAX, [Index]
+ MOV EDX, [Value]
+ MOV [EAX], EDX
+ MOV EDX, [Value+4]
+ MOV [EAX+4], EDX
+ end [ 'EAX', 'EDX' ];
+ {$ELSE DELPHI}
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents; {$ENDIF}
+ Evt := Pointer( Integer( @ TMethod( EV.fOnMinimize ).Code ) + Index );
+ Evt^ := Value;
+ {$ENDIF}
+ AttachProc( WndProcMinMaxRestore );
+end;
+
+procedure TControl.SetOnMinimize(const Value: TOnEvent);
+begin
+ SetOnMinMaxRestore( 0, Value );
+end;
+
+procedure TControl.SetOnMaximize(const Value: TOnEvent);
+begin
+ SetOnMinMaxRestore( 8, Value );
+end;
+
+procedure TControl.SetOnRestore(const Value: TOnEvent);
+begin
+ SetOnMinMaxRestore( 16, Value );
+end;
+
+function TControl.GetOnMinMaxRestore(const Index: Integer): TOnEvent;
+begin
+ CASE Index OF
+ 0: Result := EV.fOnMinimize;
+ 8: Result := EV.fOnMaximize;
+ 16: Result := EV.fOnRestore;
+ END;
+end;
+
+{$IFDEF INPACKAGE}
+ {$IFDEF ASM_LOCAL}
+ {$UNDEF ASM_LOCAL}
+ {$ENDIF}
+{$ELSE}
+ {$IFDEF ASM_VERSION}
+ {$DEFINE ASM_LOCAL}
+ {$ENDIF}
+{$ENDIF}
+
+{$ENDIF WIN_GDI}
+
+{$IFDEF GDI}
+{$IFDEF ASM_LOCAL}
+{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetParent( Value: PControl );
+begin
+ if Value = fParent then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if fParent <> nil then
+ begin
+ {$IFDEF USE_GRAPHCTLS}
+ Invalidate; // necessary for graphic controls
+ {$ENDIF}
+ {$IFDEF DEBUG_MCK}
+ if ( fParent.fChildren <> nil ) then
+ begin
+ mck_Log( 'remove from old parent children 1st' );
+ fParent.fChildren.Remove( @Self );
+ mck_Log( 'removed ok' );
+ end;
+ {$ELSE not DEBUG_MCK}
+ fParent.fChildren.Remove( @Self );
+ {$IFDEF NOT_USE_AUTOFREE4CONTROLS}
+ {$ELSE}
+ fParent.RemoveFromAutoFree( @Self );
+ {$ENDIF}
+
+ {$IFDEF NIL_EVENTS}
+ if Assigned( fParent.PP.fNotifyChild ) then
+ {$ENDIF}
+ fParent.PP.fNotifyChild( fParent, nil );
+ {$ENDIF not DEBUG_MCK}
+ end;
+ fParent := Value;
+ if fParent <> nil then
+ begin
+ fParent.fChildren.Add( @Self );
+ {$IFDEF USE_AUTOFREE4CHILDREN}
+ fParent.Add2AutoFree( @ Self );
+ {$ENDIF}
+ {$IFNDEF INPACKAGE} //-----------------------------------------------------
+ if FHandle <> 0 then
+ Windows.SetParent( FHandle, Value.GetWindowHandle );
+ {$ENDIF not INPACKAGE} //--------------------------------------------------
+ {$IFDEF NIL_EVENTS}
+ if Assigned( fParent.PP.fNotifyChild ) then
+ {$ENDIF}
+ fParent.PP.fNotifyChild( fParent, @ Self );
+ {$IFDEF NIL_EVENTS}
+ if Assigned( PP.fNotifyChild ) then
+ {$ENDIF}
+ PP.fNotifyChild( fParent, @ Self );
+ {$IFDEF USE_GRAPHCTLS}
+ Invalidate; // necessary for graphic controls
+ {$ENDIF}
+ end;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TControl.SetParent( Value: PControl );
+BEGIN
+ IF Value = fParent THEN Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ IF fParent <> nil THEN
+ begin
+ fParent.fChildren.Remove( @Self );
+
+ {$IFDEF NOT_USE_AUTOFREE4CONTROLS}
+ {$ELSE}
+ fParent.RemoveFromAutoFree( @Self );
+ {$ENDIF}
+ END;
+ fParent := Value;
+ IF fParent <> nil THEN
+ BEGIN
+ fParent.fChildren.Add( @Self );
+ {$IFDEF USE_AUTOFREE4CHILDREN}
+ fParent.Add2AutoFree( @ Self );
+ {$ENDIF}
+ END;
+ fParent.fGetClientArea( fParent );
+ fParent.fChildPut( fParent, @ Self, fBoundsRect.Left, fBoundsRect.Top );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+function TControl.ChildIndex(Child: PControl): Integer;
+begin
+ Result := fChildren.IndexOf( Child );
+end;
+
+procedure TControl.MoveChild(Child: PControl; NewIdx: Integer);
+var I: Integer;
+begin
+ I := ChildIndex( Child );
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( I>=0, 'TControl.MoveChild: index out of bounds' );
+ {$ENDIF KOL_ASSERTIONS}
+ fChildren.MoveItem( I, NewIdx );
+end;
+
+{$IFDEF WIN_GDI}
+procedure TControl.EnableChildren(Enable, Recursive: Boolean);
+var I: Integer;
+ C: PControl;
+begin
+ for I := 0 to ChildCount-1 do
+ begin
+ C := Children[ I ];
+ C.Enabled := Enable;
+ if Recursive then
+ C.EnableChildren( Enable, TRUE );
+ end;
+end;
+
+{$ENDIF WIN_GDI}
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+constructor TControl.CreateParented(AParent: PControl);
+begin
+ InitParented( AParent ); // because InitParented is virtual, but CreateParented
+end; // can not be virtual (as an _object_ - not a class - constructor)
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+CONSTRUCTOR TControl.CreateParented(AParent: PControl; widget: PGtkWidget;
+ need_eventbox: Boolean);
+BEGIN
+ InitParented( AParent, widget, need_eventbox );
+ // because InitParented is virtual, but CreateParented
+END; // can not be virtual (as an _object_ - not a class - constructor)
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+constructor TControl.CreateOrthaned( AParentWnd: HWnd );
+begin
+ InitOrthaned( AParentWnd );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetLeft: Integer;
+begin
+ Result := BoundsRect.Left;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetLeft( Value: Integer );
+var R: TRect;
+begin
+ R := BoundsRect;
+ R.Left := Value;
+ R.Right := Value + Width;
+ SetBoundsRect( R );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetTop: Integer;
+begin
+ Result := BoundsRect.Top;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetTop( Value: Integer );
+var R: TRect;
+begin
+ R := BoundsRect;
+ R.Top := Value;
+ R.Bottom := Value + Height;
+ SetBoundsRect( R );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetWidth: Integer;
+begin
+ with BoundsRect do
+ Result := Right - Left;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetWidth( Value: Integer );
+var R: TRect;
+begin
+ R := BoundsRect;
+ with R do
+ Right := Left + Value;
+ SetBoundsRect( R );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetHeight: Integer;
+begin
+ with BoundsRect do
+ Result := Bottom - Top;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetHeight( Value: Integer );
+var R: TRect;
+begin
+ R := BoundsRect;
+ with R do
+ Bottom := Top + Value;
+ SetBoundsRect( R );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetPosition: TPoint;
+begin
+ Result.x := BoundsRect.Left;
+ Result.y := BoundsRect.Top;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.Set_Position( Value: TPoint );
+var R: TRect;
+begin
+ R.Top := Value.y;
+ R.Left := Value.x;
+ R.Right := R.Left + Width;
+ R.Bottom := R.Top + Height;
+ BoundsRect := R;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF WIN_GDI}
+function WndProcConstraints( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var MMI: PMinMaxInfo;
+begin
+ Result := FALSE;
+ if Msg.message = WM_GETMINMAXINFO then
+ begin
+ Rslt := Sender.CallDefWndProc( Msg );
+ MMI := Pointer( Msg.lParam );
+ if Sender.FMaxWidth > 0 then
+ begin
+ MMI.ptMaxSize.x := Sender.FMaxWidth;
+ MMI.ptMaxTrackSize.x := Sender.FMaxWidth;
+ end;
+ if Sender.FMaxHeight > 0 then
+ begin
+ MMI.ptMaxSize.y := Sender.FMaxHeight;
+ MMI.ptMaxTrackSize.y := Sender.FMaxHeight;
+ end;
+ MMI.ptMinTrackSize := MakePoint( Sender.FMinWidth, Sender.FMinHeight );
+ Rslt := 0;
+ Result := TRUE;
+ end;
+end;
+
+{$IFDEF USE_MHTOOLTIP}
+{$DEFINE implementation_part}
+{$I KOLMHToolTip_implem.inc}
+{$UNDEF implementation_part}
+{$ENDIF}
+
+procedure TControl.SetConstraint(const Index: Integer; Value: SmallInt);
+begin
+ AttachProc( WndProcConstraints );
+ case Index of
+ 0: FMinWidth := Value;
+ 1: FMinHeight := Value;
+ 2: FMaxWidth := Value;
+ 3: FMaxHeight := Value;
+ end;
+end;
+
+function TControl.GetConstraint(const Index: Integer): Integer;
+begin
+ CASE Index OF
+ 0: Result := FMinWidth;
+ 1: Result := FMinHeight;
+ 2: Result := FMaxWidth;
+ else Result := FMaxHeight;
+ END;
+end;
+
+function TControl.ControlRect: TRect;
+var C: PControl;
+ R: TRect;
+begin
+ Result := BoundsRect;
+ C := Parent;
+ if C <> nil then
+ begin
+ if {$IFDEF USE_FLAGS} not(G3_IsControl in C.fFlagsG3)
+ {$ELSE} not C.fIsControl {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>}
+
+ R := C.ControlRect;
+ OffsetRect( Result, R.Left, R.Top );
+
+ if C.fChildren <> nil then
+ if C.FChildren.IndexOf( @Self ) >= 0 then
+ begin
+ R := C.ClientRect;
+ Dec( R.Top, C.fClientTop );
+ Dec( R.Left, C.fClientLeft );
+ OffsetRect( Result, R.Left, R.Top );
+ end;
+ end;
+end;
+
+function TControl.ControlAtPos( X, Y: Integer; IgnoreDisabled: Boolean ): PControl;
+var I: Integer;
+ C: PControl;
+ CR, VR: TRect;
+begin
+ Result := nil;
+ CR := ControlRect; // относительные координаты в системе РОДИТЕЛЬСКОГО КОНТРОЛА
+ if {$IFDEF USE_FLAGS} not(G6_GraphicCtl in fFlagsG6)
+ {$ELSE} fWindowed {$ENDIF} then CR := MakeRect( 0, 0, 0, 0 );
+ X := X + CR.Left; // - R.Left;
+ Y := Y + CR.Top; // - R.Top;
+ for I := ChildCount - 1 downto 0 do
+ begin
+ C := Children[ I ]; //Members[ I ];
+ if C.Visible then
+ if (not IgnoreDisabled) or IgnoreDisabled and C.Enabled then
+ begin
+ VR := C.ControlRect;
+ if (X >= VR.Left) and (X < VR.Right) and
+ (Y >= VR.Top) and (Y < VR.Bottom) then
+ begin
+ Result := C; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end;
+end;
+{$ENDIF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect );
+{$IFDEF GDI} var B: HBrush; {$ENDIF GDI}
+begin
+ {$IFDEF GDI}
+ B := CreateSolidBrush( Color2Rgb( Sender.Color ) );
+ Windows.FillRect( DC, Rect^, B );
+ DeleteObject( B );
+ {$ENDIF GDI}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF WIN_GDI}
+procedure TControl.PaintBackground( DC: HDC; Rect: PRect );
+begin
+ Global_OnPaintBkgnd( @Self, DC, Rect );
+end;
+{$ENDIF WIN_GDI}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetCtlColor( Value: TColor );
+begin
+ {$IFNDEF INPACKAGE}
+ if GetWindowHandle <> 0 then
+ {$ELSE}
+ if fHandle <> 0 then
+ {$ENDIF}
+ if fCommandActions.aSetBkColor <> 0 then
+ Perform( fCommandActions.aSetBkColor, 0, Color2RGB( Value ) );
+ if fColor = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fColor := Value;
+ if fTmpBrush <> 0 then
+ begin
+ DeleteObject( fTmpBrush );
+ fTmpBrush := 0;
+ end;
+ if fBrush <> nil then
+ fBrush.Color := Value;
+ Invalidate;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TControl.SetCtlColor( Value: TColor );
+VAR gcolor: TGdkColor;
+ i: Integer;
+BEGIN
+ if fColor = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fColor := Value;
+ gcolor := Color2GdkColor( Value );
+ FOR i := 0 to 4 do
+ BEGIN
+ gtk_widget_modify_bg( fEventboxHandle, {GTK_STATE_NORMAL} i, @ gcolor );
+ gtk_widget_modify_base( fEventboxHandle, {GTK_STATE_NORMAL} i, @ gcolor );
+ END;
+ //if Assigned( _Self.fFont ) then
+ {begin
+ _Self.fHandle.style.font_desc :=
+ pango_font_description_copy( _Self.fFont.GetPangoFontDesc );
+ if oldfontdesc <> nil then
+ pango_font_description_free( oldfontdesc );
+ end;}
+
+ //Invalidate;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetParentWnd( NeedHandle: Boolean ): HWnd;
+var C: PControl;
+begin
+ Result := FParentWnd;
+ C := fParent; // WindowedParent;
+ if C <> nil then
+ begin
+ if NeedHandle then
+ C.GetWindowHandle;
+ Result := C.fHandle;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+procedure TControl.CreateChildWindows;
+asm
+ PUSH ESI
+ MOV ESI, [EAX].TControl.fChildren
+ MOV ECX, [ESI].TList.fCount
+ MOV ESI, [ESI].TList.fItems
+ JECXZ @@exit
+
+@@loop: PUSH ECX
+ LODSD
+ CALL CallTControlCreateWindow
+ POP ECX
+ LOOP @@loop
+
+@@exit: POP ESI
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure TControl.CreateChildWindows;
+var I: Integer;
+ C: PControl;
+begin
+ {$IFDEF INPACKAGE}
+ Log( '->TControl.CreateChildWindows' );
+ TRY
+ {$ENDIF INPACKAGE}
+ for I := 0 to fChildren.Count - 1 do
+ begin
+ {$IFDEF INPACKAGE}
+ Log( Int2Str( I ) );
+ {$ENDIF INPACKAGE}
+ C := fChildren.Items[ I ];
+ C.CreateWindow; //virtual!!!
+ end;
+ {$IFDEF INPACKAGE}
+ LogOK;
+ FINALLY
+ Log( '<-TControl.CreateChildWindows' );
+ END;
+ {$ENDIF INPACKAGE}
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF WIN_GDI}
+function TControl.GetMembers(Idx: Integer): PControl;
+begin
+ Result := fChildren.Items[ Idx ];
+ // Important: .Items but not .fItems - when fChildren.Count=0, nil is returned
+end;
+{$IFDEF WIN_GDI}
+
+{$IFDEF ASM_TLIST}
+procedure TControl.DestroyChildren;
+asm
+ PUSH ESI
+
+ MOV EAX, [EAX].fChildren
+ PUSH EAX
+ MOV ECX, [EAX].TList.fCount
+ JECXZ @@clear
+ MOV ESI, [EAX].TList.fItems
+ LEA ESI, [ESI + ECX*4 - 4] // is order really important ?
+
+@@loop: STD //
+ LODSD
+ CLD //
+
+ PUSH ECX
+ CALL TObj.RefDec
+ POP ECX
+
+ LOOP @@loop
+
+@@clear:
+ POP EAX
+ CALL TList.Clear
+
+ POP ESI
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure TControl.DestroyChildren;
+var I: Integer;
+ W: PControl;
+begin
+ for I := fChildren.fCount - 1 downto 0 do
+ begin
+ W := fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ];
+ W.Free;
+ end;
+ fChildren.Clear;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.ProcessMessage: Boolean;
+var Msg: TMsg;
+ P: Windows.PMsg;
+begin
+ Result := False;
+ if PeekMessage( Msg, 0, 0, 0, PM_REMOVE ) then
+ 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}
+ PP.fExMsgProc( @Self, Msg )) then
+ begin
+ P := Pointer( @Msg );
+ TranslateMessage( P^ );
+ DispatchMessage( Msg );
+ {$IFDEF PSEUDO_THREADS}
+ if Assigned( MainThread ) then
+ MainThread.NextThread;
+ {$ENDIF}
+ end;
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.ProcessMessages;
+begin
+ while ProcessMessage do ;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.ProcessMessagesEx;
+begin
+ PostMessage( GetWindowHandle, CM_PROCESS, 0, 0 );
+ ProcessMessages;
+end;
+
+procedure TControl.ProcessPendingMessages;
+var Msg: TMsg;
+begin
+ if LOWORD( GetQueueStatus( QS_ALLINPUT ) ) <> 0 then
+ if PeekMessage( Msg, 0, 0, 0, PM_NOREMOVE {or PM_NOYIELD} )
+ or PeekMessage( Msg, HWnd(-1), 0, 0, PM_NOREMOVE {or PM_NOYIELD} )
+ then
+ Applet.ProcessMessages;
+end;
+
+procedure TControl.ProcessPaintMessages;
+var Msg: TMsg;
+begin
+ while PeekMessage( Msg, Handle, 15, 15, PM_NOREMOVE ) do
+ Applet.ProcessMessage;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function WndProcForm(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+{$IFDEF ENDSESSION_HALT}
+var App: PControl;
+{$ENDIF}
+begin
+ Result := True;
+ case Msg.message of
+ {$IFDEF ENDSESSION_HALT}
+ WM_ENDSESSION:
+ begin
+ if Msg.wParam <> 0 then
+ begin
+ Self_.RefDec;
+ { Normally, WM_ENDSESSION is sent to a main form, not to Applet.
+ Since we do not plan further working after handling this message,
+ we decrease RefCount for the form (in was increased in EnumDynHandlers
+ to prevent object destroying while its message processing is not
+ finished). }
+ App := Applet;
+ //Rslt := 0; { We will not return any result at all. }
+ {$IFDEF DEBUG_ENDSESSION}
+ EndSession_Initiated := TRUE;
+ LogFileOutput( GetStartDir + 'es_debug.txt',
+ 'Self_=' + Int2Hex( DWORD( Self_ ), 8 ) +
+ ' Self_.Handle=' + Int2Str( Self_.FHandle ) );
+ {$ENDIF}
+ AppletTerminated := TRUE;
+ AppletRunning := FALSE;
+ Applet := nil;
+ App.Free; { We provide OnDestroy handlers to be called for any objects here }
+ Halt; { Stop further executing. }
+ end else Result := FALSE;
+ end;
+ {$ENDIF ENDSESSION_HALT}
+ WM_SETFOCUS:
+ begin
+ {$IFDEF NEW_MODAL}
+ if Self_.DF.fModalForm <> nil then
+ SetFocus( Self_.DF.fModalForm.fHandle )
+ else if ( Self_.DF.FCurrentControl <> nil ) and
+ {$IFDEF USE_FLAGS} not( (G3_IsForm in Self_.DF.fCurrentControl.fFlagsG3)
+ xor(G3_IsApplet in Self_.fFlagsG3) )
+ {$ELSE} not(Self_.DF.FCurrentControl.fIsForm xor Self_.fIsApplet)
+ {$ENDIF} then
+ {$ELSE not NEW_MODAL}
+ if Self_.DF.FCurrentControl <> nil then
+ {$ENDIF}
+ begin
+ if Self_.DF.FCurrentControl.CreateWindow then
+ SetFocus( Self_.DF.FCurrentControl.fHandle );
+ end
+ else
+ Result := False;
+ if assigned( Applet ) and (Applet <> Self_) then
+ Applet.DF.FCurrentControl := Self_;
+ end;
+ //WM_NCDESTROY:
+ // Self_.RefDec;
+ else Result := False;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function GetPrevCtrlBoundsRect( P: PControl; var R: TRect ): Boolean;
+var Idx: Integer;
+begin
+ Result := False;
+ if P.FParent = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Idx := P.FParent.ChildIndex( P ) - 1;
+ if Idx < 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := True;
+ R := P.FParent.Children[ Idx ].BoundsRect;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.PlaceUnder: PControl;
+var R: TRect;
+begin
+ Result := @Self;
+ if not GetPrevCtrlBoundsRect( @Self, R ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>}
+ Top := R.Bottom + fParent.fMargin;
+ Left := R.Left;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.PlaceDown: PControl;
+var R: TRect;
+begin
+ Result := @Self;
+ if not GetPrevCtrlBoundsRect( @Self, R ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>}
+ Top := R.Bottom + fParent.fMargin;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.PlaceRight: PControl;
+var R: TRect;
+begin
+ Result := @Self;
+ if not GetPrevCtrlBoundsRect( @Self, R ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>}
+ Top := R.Top;
+ Left := R.Right + fParent.fMargin;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.SetSize(W, H: Integer): PControl;
+var R: TRect;
+begin
+ R := BoundsRect;
+ if W > 0 then R.Right := R.Left + W;
+ if H > 0 then R.Bottom := R.Top + H;
+ SetBoundsRect( R );
+ Result := @Self;
+end;
+{$ENDIF PAS_VERSION}
+{$IFDEF WIN_GDI}
+
+function TControl.SetClientSize(W, H: Integer): PControl;
+begin
+ if W > 0 then ClientWidth := W;
+ if H > 0 then ClientHeight := H;
+ Result := @Self;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.AlignLeft(P: PControl): PControl;
+begin
+ Result := @Self;
+ Left := P.Left;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.AlignTop(P: PControl): PControl;
+begin
+ Result := @Self;
+ Top := P.Top;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF KEY_PREVIEW}
+ {$DEFINE KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
+{$ENDIF}
+{$IFDEF ESC_CLOSE_DIALOGS}
+ {$IFNDEF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
+ {$DEFINE KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF ASM_VERSION} // see addition for combobox in pas version
+{$ELSE PAS_VERSION} //Pascal
+function WndProcCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
+var F: PControl;
+ Cmd : DWORD;
+begin
+ Result := FALSE;
+ with Self_^ do
+ case Msg.message of
+ CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:
+ begin
+ SetTextColor(Msg.WParam, Color2RGB(fTextColor));
+ if {$IFDEF USE_FLAGS} G2_Transparent in fFlagsG2
+ {$ELSE} fTransparent {$ENDIF} then
+ begin
+ SetBkMode( Msg.wParam, Windows.TRANSPARENT );
+ Rslt := GetStockObject( NULL_BRUSH );
+ end else
+ begin
+ SetBkMode( Msg.wParam, Windows.OPAQUE );
+ SetBkColor(Msg.WParam, Color2RGB( fColor ) );
+ Rslt := Global_GetCtlBrushHandle( Self_ );
+ end;
+ Result := TRUE;
+ end;
+ CM_COMMAND:
+ begin
+ Result := True;
+ Cmd := HiWord( Msg.wParam );
+ if Cmd = fCommandActions.aClick then
+ begin
+ if Integer( fClickDisabled ) <= 0 then
+ begin
+ Focused := TRUE;
+ DoClick;
+ end;
+ end else
+ if Cmd = fCommandActions.aEnter then
+ begin
+ if Assigned( EV.fOnEnter ) then EV.fOnEnter( Self_ );
+ end else
+ if Cmd = fCommandActions.aLeave then
+ begin
+ if Assigned( EV.fOnLeave ) then EV.fOnLeave( Self_ );
+ end else
+ if Integer(Cmd) = fCommandActions.aChange then
+ begin
+ if Assigned( EV.fOnChangeCtl ) then EV.fOnChangeCtl( Self_ );
+ end else
+ if Integer(Cmd) = fCommandActions.aSelChange then
+ begin
+ DoSelChange;
+ end
+ else Result := False;
+
+ if Result then
+ Rslt := CallDefWndProc( Msg );
+
+ end;
+
+ WM_SETFOCUS:
+ begin
+ Rslt := 0;
+ Result := TRUE;
+ F := ParentForm;
+ if F <> nil then
+ begin
+ if (F.DF.fCurrentControl <> nil) and (F.DF.fCurrentControl <> Self_)
+ {$IFDEF NIL_EVENTS}
+ and Assigned( F.DF.fCurrentControl.EV.fLeave )
+ {$ENDIF}
+ then
+ F.DF.fCurrentControl.EV.fLeave( F.DF.fCurrentControl );
+ F.DF.fCurrentControl := Self_;
+ Result := False; // go further handling
+ end;
+ end;
+ {$IFDEF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
+ WM_KEYDOWN:
+ begin
+ {$IFDEF KEY_PREVIEW}
+ //--------------------------------Truf-------------------------------------
+ F := ParentForm;
+ if F <> Self_ then
+ begin
+ if {$IFDEF USE_FLAGS} G6_KeyPreview in F.fFlagsG6
+ {$ELSE} F.fKeyPreview {$ENDIF} then
+ begin
+ {$IFDEF USE_FLAGS}
+ include( F.fFlagsG4, G4_Pushed );
+ {$ELSE} F.fKeyPreviewing := TRUE; {$ENDIF}
+ inc( F.DF.fKeyPreviewCount );
+ F.Perform(WM_KEYDOWN,msg.wParam,msg.lParam);
+ dec( F.DF.fKeyPreviewCount );
+ end;
+ end;
+ //--------------------------------Truf-------------------------------------
+ {$ENDIF KEY_PREVIEW}
+ {$IFDEF ESC_CLOSE_DIALOGS}
+ //---------------------------------Babenko Alexey--------------------------
+ begin
+ F := ParentForm;
+ if (F.fExStyle and WS_EX_DLGMODALFRAME) <> 0 then
+ if Msg.wParam = 27 then
+ F.Perform(WM_CLOSE, 0, 0);
+ end;
+ //---------------------------------Babenko Alexey--------------------------
+ {$ENDIF ESC_CLOSE_DIALOGS}
+ end;
+ {$IFDEF KEY_PREVIEW}
+ WM_KEYUP..WM_SYSDEADCHAR:
+ begin
+ F := ParentForm;
+ if F <> Self_ then
+ begin
+ if {$IFDEF USE_FLAGS} G6_KeyPreview in F.fFlagsG6
+ {$ELSE} F.fKeyPreview {$ENDIF} then
+ begin
+ {$IFDEF USE_FLAGS}
+ include( F.fFlagsG4, G4_Pushed );
+ {$ELSE} F.fKeyPreviewing := TRUE; {$ENDIF}
+ inc( F.DF.fKeyPreviewCount );
+ F.Perform(Msg.message,msg.wParam,msg.lParam);
+ dec( F.DF.fKeyPreviewCount );
+ end;
+ end;
+ end;
+ {$ENDIF KEY_PREVIEW}
+ {$ENDIF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF OLD_TRANSPARENT}
+function WndProcTransparent( Sender: PControl; var Msg: TMsg;
+ var Rslt: Integer ): Boolean;
+var DC, PDC, BLTDC: HDC;
+ Save: integer;
+ OLDp: THANDLE;
+ L, T: SmallInt;
+ TP, ParentClient: TPoint;
+ TR, Margins: TRect;
+ Wnd: HWND;
+ tRgn: HRgn;
+ C: PControl;
+begin
+ Result := FALSE;
+ {$IFDEF STOP_WNDPROCTRANSPARENT_AFTER_APPLETTERMINATED}
+ if AppletTerminated or not Sender.ToBeVisible then
+ 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 Sender.fTransparent then
+ Result := TRUE;
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ if Sender.fTransparent and (
+ {$IFDEF USE_FLAGS} not(G2_DoubleBuffered in Sender.FParent.fFlagsG2)
+ {$ELSE} not Sender.fParent.fDoubleBuffered {$ENDIF} ) then
+ Sender.fTransparent := FALSE;
+ 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 (Sender.fTransparent)
+ 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( GetWindowLong( Wnd, GWL_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
+function WndProcTransparent( Sender: PControl; var Msg: TMsg;
+ var Rslt: Integer ): Boolean;
+
+ function SetRectRgnInderect(tRgn: HRGN; const TR: TRect): BOOL;
+ begin
+ Result := SetRectRgn(tRgn, TR.Left, TR.Top, TR.Right, TR.Bottom);
+ end;
+
+var
+ DC, PDC, BLTDC: HDC;
+ Save: integer;
+ OLDp: THANDLE;
+ L, T: SmallInt;
+ TP: TPoint;
+ TR, Margins: TRect;
+ Wnd: HWND;
+ C: PControl;
+ ChildRgn: HRGN;
+ PS: TPaintStruct;
+
+begin
+ Result := FALSE;
+
+ {$IFDEF STOP_WNDPROCTRANSPARENT_AFTER_APPLETTERMINATED}
+ if AppletTerminated or not Sender.ToBeVisible then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$ENDIF}
+
+ 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; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+
+ 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_PAINT,
+ WM_ERASEBKGND:;
+ WM_NCPAINT:
+ if {$IFDEF USE_FLAGS} not(G2_Transparent in Sender.fFlagsG2)
+ {$ELSE} not Sender.fTransparent {$ENDIF} then
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ else exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if Sender.fAnchors and SELF_REQ_PAINT <> 0 then exit; {>>>>>>>>>>>>>>>>>>>>>}
+ Result := TRUE;
+ if Assigned(Sender.fParent)
+ and {$IFDEF USE_FLAGS} not(G3_IsForm in Sender.fFlagsG3)
+ {$ELSE} (not Sender.fIsForm) {$ENDIF}
+ and {$IFDEF USE_FLAGS} (G2_DoubleBuffered in Sender.FParent.fFlagsG2)
+ {$ELSE} Sender.FParent.fDoubleBuffered {$ENDIF}
+ and (Sender.fAnchors and PARENT_REQ_PAINT = 0) then
+ begin
+ TR := Sender.BoundsRect;
+ InvalidateRect(Sender.fParent.fHandle, @TR, true);
+ ValidateRect(Sender.fHandle, nil); //???--brandys???+
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+
+ if Msg.message = WM_PAINT then begin
+ OLDp := 0;
+ if Sender.fAnchors and PARENT_REQ_PAINT = 0 then
+ begin
+ Sender.fDblExcludeRgn := CreateRectRgn(0, 0, 0, 0);
+ if Integer( GetUpdateRgn(Sender.fHandle, Sender.fDblExcludeRgn, TRUE) ) <= NULLREGION then
+ begin
+ DeleteObject(Sender.fDblExcludeRgn);
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+
+ DC := BeginPaint(Sender.fHandle, PS);
+ PDC := CreateCompatibleDC( DC );
+ GetClientRect(Msg.hwnd, Margins);
+ OLDp := SelectObject(PDC, CreateCompatibleBitmap(DC, Margins.Right, Margins.Bottom) );
+ Sender.fParentCoordX := 0;
+ Sender.fParentCoordy := 0;
+ end else
+ begin
+ PDC := Msg.wParam;
+ Sender.fDblExcludeRgn := Sender.fParent.fDblExcludeRgn;
+ end;
+
+ Sender.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
+ ChildRgn := CreateRectRgn(0, 0, 0, 0);
+ if Integer( GetWindowRgn(WND, ChildRgn) ) <= NULLREGION then begin
+ GetWindowRect(WND, TR);
+ TP.X := 0; TP.Y := 0;
+ ClientToScreen(Sender.fHandle, TP);
+ OffsetRect(TR, -TP.X , -TP.Y);
+ SetRectRgnInderect(ChildRgn, TR);
+ end;
+ OffsetRgn(ChildRgn, Sender.fParentCoordX, Sender.fParentCoordY);
+
+ {$IFDEF USE_PROP}
+ C := Pointer( GetProp( Wnd, ID_SELF ) );
+ {$ELSE}
+ C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
+ {$ENDIF}
+ if CombineRgn(ChildRgn, ChildRgn, Sender.fDblExcludeRgn, RGN_AND) >= SIMPLEREGION then begin
+ with C^ do begin
+ if (C <> nil) and
+ {$IFDEF USE_FLAGS} ( [G2_DoubleBuffered, G2_Transparent] * fFlagsG2 <> [] )
+ {$ELSE} (fTransparent or fDoubleBuffered) {$ENDIF} then
+ begin
+ Save := SaveDC( PDC );
+ fAnchors := fAnchors or 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);
+ fAnchors := fAnchors and not PARENT_REQ_PAINT;
+ RestoreDC( PDC, Save );
+ end else begin
+ CombineRgn(Sender.fDblExcludeRgn, Sender.fDblExcludeRgn, ChildRgn, RGN_DIFF);
+ end;
+ end;
+ end; // if Save >= SIMPLEREGION then begin
+ DeleteObject(ChildRgn);
+ end;
+ Wnd := GetWindow( Wnd, GW_HWNDPREV );
+ end;
+ Sender.fPaintDC := 0;
+ Sender.fAnchors := Sender.fAnchors and not SELF_REQ_PAINT;
+
+ if Sender.fAnchors and PARENT_REQ_PAINT = 0 then
+ begin
+ BLTDC := GetDCEx(Sender.fHandle, 0, DCX_CACHE or DCX_CLIPSIBLINGS);
+ ExtSelectClipRgn(BLTDC, Sender.fDblExcludeRgn, RGN_AND);
+
+ BitBlt(BLTDC, 0, 0, Margins.Right, Margins.Bottom, PDC, 0, 0, SRCCOPY );
+
+ ReleaseDC(Sender.fHandle, BLTDC);
+ DeleteObject(SelectObject( PDC, OLDp ));
+ DeleteObject(Sender.fDblExcludeRgn);
+ DeleteDC( PDC );
+ EndPaint(Sender.fHandle, PS);
+ end;
+ end;
+end;
+{$ENDIF}
+
+{$IFDEF ASM_noVERSION}
+function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+const szPaintStruct = sizeof(TPaintStruct);
+asm
+ CMP word ptr [EDX].TMsg.message, WM_PRINT
+ JE @@print
+ CMP word ptr [EDX].TMsg.message, WM_PAINT
+ JNE @@ret_false
+@@print:
+ CMP word ptr [EAX].TControl.fOnPaint.TMethod.Code+2, 0
+ JE @@ret_false
+ PUSH EBX
+ PUSH ESI
+
+ XCHG EBX, EAX
+ MOV ESI, EDX
+ XOR EAX, EAX
+ PUSH ECX
+ PUSH EAX
+ PUSH EAX
+ PUSH EAX
+ PUSH EAX
+ CALL CreateRectRgn
+ MOV [EBX].TControl.fUpdRgn, EAX
+
+ MOVSX EDX, [EBX].TControl.fEraseUpdRgn
+ PUSH EDX
+ PUSH EAX
+ PUSH [EBX].TControl.fHandle
+ CALL GetUpdateRgn
+
+ CMP EAX, 1
+ JA @@collectUpdRgn
+
+ XOR EAX, EAX
+ XCHG EAX, [EBX].TControl.fUpdRgn
+ PUSH EAX
+ CALL DeleteObject
+
+@@collectUpdRgn:
+ MOV ECX, [EBX].TControl.fCollectUpdRgn
+ JECXZ @@asg_fPaintDC
+ XCHG EAX, ECX
+ MOV ECX, [EBX].TControl.fUpdRgn
+ JECXZ @@asg_fPaintDC
+
+ PUSH RGN_OR
+ PUSH ECX
+ PUSH EAX
+ PUSH EAX
+ CALL CombineRgn
+
+ DEC EAX
+ JNZ @@invalidateRgn
+
+ ADD ESP, -16
+ PUSH ESP
+ PUSH [EBX].TControl.fHandle
+ CALL Windows.GetClientRect
+
+ PUSH [EBX].TControl.fCollectUpdRgn
+ CALL DeleteObject
+ CALL CreateRectRgn
+ MOV [EBX].TControl.fCollectUpdRgn, EAX
+
+@@invalidateRgn:
+ MOVSX EDX, [EBX].TControl.fEraseUpdRgn
+ PUSH EDX
+ PUSH [EBX].TControl.fCollectUpdRgn
+ PUSH [EBX].TControl.fHandle
+ CALL InvalidateRgn
+
+@@asg_fPaintDC:
+ MOV ECX, [ESI].TMsg.wParam
+ INC ECX
+ LOOP @@storePaintDC
+
+ ADD ESP, -szPaintStruct
+ PUSH ESP
+ PUSH [EBX].TControl.fHandle
+ CALL BeginPaint
+ XCHG ECX, EAX
+@@storePaintDC:
+ MOV [EBX].TControl.fPaintDC, ECX
+ XCHG EAX, ECX
+
+ MOV ECX, [EBX].TControl.fCollectUpdRgn
+ JECXZ @@doOnPaint
+
+ PUSH ECX
+ PUSH EAX
+ CALL SelectClipRgn
+
+@@doOnPaint:
+ MOV ECX, [EBX].TControl.fPaintDC
+ MOV EDX, EBX
+
+ MOV EAX, [EBX].TControl.fOnPaint.TMethod.Data
+ CALL dword ptr [EBX].TControl.fOnPaint.TMethod.Code
+
+ MOV ECX, [EBX].TControl.fCanvas
+ JECXZ @@e_paint
+
+ XCHG EAX, ECX
+ XOR EDX, EDX
+ CALL TCanvas.SetHandle
+
+@@e_paint:
+ MOV ECX, [ESI].TMsg.wParam
+ INC ECX
+ LOOP @@zero_fPaintDC
+
+ PUSH ESP
+ PUSH [EBX].TControl.fHandle
+ CALL EndPaint
+ ADD ESP, szPaintStruct
+
+@@zero_fPaintDC:
+ XOR ECX, ECX
+ MOV [EBX].TControl.fPaintDC, ECX
+
+ POP EAX
+ MOV [EAX], ECX
+
+ XCHG ECX, [EBX].TControl.fUpdRgn
+ JECXZ @@exit_True
+
+ PUSH ECX
+ CALL DeleteObject
+
+@@exit_True:
+ POP ESI
+ POP EBX
+ MOV AL, 1
+ RET
+
+@@ret_false:
+ XOR EAX, EAX
+end;
+{$ELSE PAS_VERSION} //Pascal
+function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var PaintStruct: TPaintStruct;
+ Cplxity: Integer;
+ OldPaintDC: HDC;
+begin
+ with Self_^ do
+ case Msg.message of
+ //WM_PRINT,
+ WM_PAINT: if assigned( EV.fOnPaint ) then
+ begin
+ fUpdRgn := CreateRectRgn( 0, 0, 0, 0 );
+ Cplxity := Integer( GetUpdateRgn( fHandle, fUpdRgn,
+ {$IFDEF USE_FLAGS} G5_EraseBkgnd in fFlagsG5
+ {$ELSE} fEraseUpdRgn {$ENDIF} ) );
+ if (Cplxity = NULLREGION) or (Cplxity = ERROR) then
+ begin
+ DeleteObject( fUpdRgn );
+ fUpdRgn := 0;
+ end;
+
+ OldPaintDC := fPaintDC;
+ fPaintDC := Msg.wParam;
+ if fPaintDC = 0 then
+ fPaintDC := BeginPaint( fHandle, PaintStruct );
+
+ EV.fOnPaint( Self_, fPaintDC );
+
+ if assigned( Self_.fCanvas ) then
+ Self_.fCanvas.SetHandle( 0 );
+
+ if Msg.wParam = 0 then
+ EndPaint( fHandle, PaintStruct );
+ fPaintDC := OldPaintDC;
+
+ Rslt := 0;
+
+ Result := True;
+ if fUpdRgn <> 0 then
+ DeleteObject( fUpdRgn );
+ fUpdRgn := 0;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ Result := FALSE;
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF WIN_GDI}
+{$IFDEF GDI}
+procedure TControl.SetOnPaint( const Value: TOnPaint );
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnPaint := Value;
+ AttachProc( WndProcPaint );
+end;
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION expose_widget( Widget: PGtkWidget; Event: PGdkEventExpose;
+ Sender: PControl ): Boolean; cdecl;
+BEGIN
+ IF not Assigned( Sender.fOnPaint ) THEN Result := FALSE
+ ELSE
+ BEGIN
+ Sender.Canvas.SaveState;
+ Sender.fOnPaint( Sender, Sender.Canvas.Handle );
+ Sender.Canvas.RestoreState;
+ Result := TRUE;
+ END;
+END;
+
+PROCEDURE TControl.SetOnPaint( const Value: TOnPaint );
+BEGIN
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnPaint := Value;
+ {$IFNDEF SMALLER_CODE} // it is actually not necessary to disconnect, event
+ // still will be fired but fOnPaint is not assigned
+ // so FALSE will be returned to GTK.
+ IF NOT Assigned( Value ) THEN
+ gtk_signal_disconnect( fHandle, fExposeEvent )
+ ELSE
+ {$ENDIF}
+ fExposeEvent := gtk_signal_connect( GTK_OBJECT( fHandle ), 'expose_event',
+ @ expose_widget, @ Self );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+{$IFDEF WIN_GDI}
+
+function WndProcEraseBkgnd( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var PaintStruct: TPaintStruct;
+ OldPaintDC: HDC;
+begin
+ Result := FALSE;
+ if Msg.message = WM_ERASEBKGND then
+ begin
+ if Assigned( Sender.OnEraseBkgnd ) then
+ begin
+ OldPaintDC := Sender.fPaintDC;
+ Sender.fPaintDC := Msg.wParam;
+ if Sender.fPaintDC = 0 then
+ Sender.fPaintDC := BeginPaint( Sender.fHandle, PaintStruct );
+ Sender.OnEraseBkgnd( Sender, Msg.wParam );
+ if Msg.wParam = 0 then
+ EndPaint( Sender.fHandle, PaintStruct );
+ if Assigned( Sender.fCanvas ) then
+ Sender.fCanvas.SetHandle( 0 );
+ Sender.fPaintDC := OldPaintDC;
+ Rslt := 0;
+ Result := TRUE;
+ end
+ else
+ Rslt := 0;
+ end;
+end;
+
+procedure TControl.SetOnEraseBkgnd(const Value: TOnPaint);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnEraseBkgnd := Value;
+ AttachProc( WndProcEraseBkgnd );
+end;
+
+procedure DummyPaintClear( Self_: PControl; Sender: PControl; DC: HDC );
+begin
+ Sender.Canvas.FillRect( Sender.ClientRect );
+end;
+
+{$IFDEF NEW_GRADIENT}
+function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var PaintStruct: TPaintStruct;
+ Bmp: PBitmap;
+ CR: TRect;
+ I: Integer;
+ R, G, B: Integer;
+ R1, G1, B1: Integer;
+ C: TColor;
+ W, H, WH: Integer;
+ OldPaintDC: HDC;
+ Pattern: PBitmap;
+ pdc: HDC;
+ pw: integer;
+
+begin
+ case Msg.message of
+ WM_PAINT, WM_PRINTCLIENT:
+ begin
+ result := false;
+ CR := Self_.ClientRect;
+ case Self_.DF.fGradientStyle of
+ gsHorizontal: begin
+ W := CR.Right;
+ H := 1;
+ WH := W;
+ pw := 32;
+ end;
+ gsVertical: begin
+ W := 1;
+ H := CR.Bottom;
+ WH := H;
+ pw := 32
+ end;
+ gsTopToBottom,
+ gsBottomToTop: begin
+ W := CR.Bottom + CR.Right;
+ H := 1;
+ WH := W;
+ pw := 1 + (CR.Bottom div 16);
+ if pw > 6 then
+ pw := 6;
+ end;
+ else exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ // <-- impartant if user change GradientStyle to not supported by this object
+ end;
+ OldPaintDC := Self_.fPaintDC;
+ Self_.fPaintDC := Msg.wParam;
+ if Self_.fPaintDC = 0 then
+ Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct );
+ Bmp := NewDIBBitmap( W, H, pf24bit );
+ C := Color2RGB( Self_.DF.fColor1 );
+ R := C shr 16;
+ G := (C shr 8) and $FF;
+ B := C and $FF;
+ C := Color2RGB( Self_.DF.fColor2 );
+ R1 := C shr 16;
+ G1 := (C shr 8) and $FF;
+ B1 := C and $FF;
+ for I := 0 to WH-1 do begin
+ C := (( R + (R1 - R) * I div WH ) shl 16) or
+ (( G + (G1 - G) * I div WH ) shl 8) or
+ ( B + (B1 - B) * I div WH );
+ if Self_.DF.fGradientStyle = gsVertical then
+ Bmp.DIBPixels[ 0, I ] := C
+ else
+ Bmp.DIBPixels[ I, 0 ] := C;
+ end;
+ if Self_.DF.fGradientStyle = gsVertical then
+ Pattern := NewBitMap(pw, H)
+ else
+ Pattern := NewBitMap(W, pw);
+ pdc := Pattern.Canvas.Handle;
+ SetStretchBltMode( pdc, HALFTONE);
+ SetBrushOrgEx( pdc, 0, 0, nil );
+ StretchBlt( pdc, 0, 0, Pattern.Width, Pattern.Height, Bmp.Canvas.Handle,
+ 0, 0, W, H, SRCCOPY );
+
+ case Self_.DF.fGradientStyle of
+ gsHorizontal: for i := 0 to (CR.Bottom div pw) do
+ Pattern.Draw(Self_.fPaintDC, 0, i*pw);
+ gsVertical: for i := 0 to (CR.Right div pw) do
+ Pattern.Draw(Self_.fPaintDC, i*pw, 0);
+ gsTopToBottom: for i := 0 to ((CR.Bottom + pw -1) div pw)-1 do
+ Pattern.Draw(Self_.fPaintDC, -i*pw, i*pw);
+ gsBottomToTop: for i := 0 to ((CR.Bottom + pw -1) div pw)-1 do
+ Pattern.Draw(Self_.fPaintDC, -CR.Bottom + i*pw, i*pw);
+ end;
+ Bmp.Free;
+ Pattern.Free;
+
+ if TMethod( Self_.EV.fOnPaint2 ).Code = @ DummyPaintClear then
+ {$IFDEF MAKE_METHOD}
+ Self_.EV.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyObjProc ) );
+ {$ELSE}
+ TMethod( Self_.EV.fOnPaint2 ).Code := @DummyObjProc;
+ {$ENDIF}
+ if Assigned( Self_.EV.fOnPaint ) then
+ Self_.EV.fOnPaint( Self_, Self_.fPaintDC );
+
+ if Msg.wParam = 0 then
+ EndPaint( Self_.fHandle, PaintStruct );
+ Self_.fPaintDC := OldPaintDC;
+ Rslt := 0;
+ Result := True;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ Result := False;
+end;
+{$ELSE OLD_GRADIENT}
+function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var PaintStruct: TPaintStruct;
+ Bmp: PBitmap;
+ CR: TRect;
+ I, R, G, B, R1, G1, B1, W, H, WH: Integer;
+ C: TColor;
+ W9x: Boolean;
+ Br: HBrush;
+ OldPaintDC: HDC;
+begin
+ case Msg.message of
+ WM_PAINT, WM_PRINTCLIENT:
+ begin
+ OldPaintDC := Self_.fPaintDC;
+ Self_.fPaintDC := Msg.wParam;
+ if Self_.fPaintDC = 0 then
+ Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct );
+ CR := Self_.ClientRect;
+ W9x := WinVer < wvNT;
+ W := 1;
+ H := CR.Bottom;
+ WH := H;
+ Bmp := nil;
+ if Self_.DF.fGradientStyle = gsHorizontal then
+ begin
+ W := CR.Right;
+ H := 1;
+ WH := W;
+ end;
+ if not W9x then
+ Bmp := NewDIBBitmap( W, H, pf32bit );
+ C := Color2RGB( Self_.DF.fColor1 );
+ R := C shr 16;
+ G := (C shr 8) and $FF;
+ B := C and $FF;
+ C := Color2RGB( Self_.DF.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 W9x then
+ begin
+ if Self_.DF.fGradientStyle <> gsHorizontal then
+ CR.Bottom := CR.Top + 1
+ else
+ CR.Right := CR.Left + 1;
+ Br := CreateSolidBrush( C );
+ Windows.FillRect( Self_.fPaintDC, CR, Br );
+ DeleteObject( Br );
+ if Self_.DF.fGradientStyle <> gsHorizontal then
+ Inc( CR.Top )
+ else
+ Inc( CR.Left );
+ end
+ else
+ begin
+ if Self_.DF.fGradientStyle <> gsHorizontal then
+ Bmp.DIBPixels[ 0, I ] := C
+ else
+ Bmp.DIBPixels[ I, 0 ] := C;
+ end;
+ end;
+ if not W9x then
+ begin
+ SetStretchBltMode( Self_.fPaintDC, HALFTONE );
+ SetBrushOrgEx( Self_.fPaintDC, 0, 0, nil );
+ StretchBlt( Self_.fPaintDC, 0, 0, CR.Right, CR.Bottom, Bmp.Canvas.Handle,
+ 0, 0, W, H, SRCCOPY );
+ Bmp.Free;
+ end;
+
+ if TMethod( Self_.EV.fOnPaint2 ).Code = @ DummyPaintClear then
+ {$IFDEF MAKE_METHOD}
+ Self_.EV.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyObjProc ) );
+ {$ELSE}
+ TMethod( Self_.EV.fOnPaint2 ).Code := @DummyObjProc;
+ {$ENDIF}
+ if Assigned( Self_.EV.fOnPaint ) then
+ Self_.EV.fOnPaint( Self_, Self_.fPaintDC );
+
+ if Msg.wParam = 0 then
+ EndPaint( Self_.fHandle, PaintStruct );
+ Self_.fPaintDC := OldPaintDC;
+ Rslt := 0;
+ Result := True;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ Result := False;
+end;
+{$ENDIF OLD_GRADIENT}
+
+function WndProcGradientEx( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+ function Ceil( X: Double ): Integer;
+ begin
+ Result := Round( X ) {+ 1};
+ //if X > 0 then dec( Result ) else inc( Result );
+ end;
+const
+ SQRT2 = 1.4142135623730950488016887242097;
+var
+ RC, R0: TRect;
+ C, C2: TColor;
+ R1, G1, B1: Integer;
+ R2, G2, B2: Integer;
+ DX1, DX2, DY1, DY2, DR, DG, DB, K: Double;
+ PaintStruct: TPaintStruct;
+ I: Integer;
+ Br: HBrush;
+ Rgn: HRgn;
+ Poly: array[ 0..3 ] of TPoint;
+ OldPaintDC: HDC;
+ fX1, fX2, fY1, fY2: Double;
+
+ procedure OffsetF( DX, DY: Double );
+ begin
+ fX1 := fX1 + DX;
+ fX2 := fX2 + DX;
+ fY1 := fY1 + DY;
+ fY2 := fY2 + DY;
+ end;
+begin
+ Result := FALSE;
+ if (Msg.message <> WM_PAINT) and (Msg.message <> WM_PRINTCLIENT) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Self_.DF.fGradientStyle in [ gsHorizontal, gsVertical ] then
+ begin
+ Result := WndProcGradient( Self_, Msg, Rslt );
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ C := Color2RGB( Self_.DF.fColor2 );
+ R2 := C and $FF;
+ G2 := (C shr 8) and $FF;
+ B2 := (C shr 16) and $FF;
+ C := Color2RGB( Self_.DF.fColor1 );
+ R1 := C and $FF;
+ G1 := (C shr 8) and $FF;
+ B1 := (C shr 16) and $FF;
+ DR := (R2 - R1) / 256;
+ DG := (G2 - G1) / 256;
+ DB := (B2 - B1) / 256;
+ OldPaintDC := Self_.fPaintDC;
+ Self_.fPaintDC := Msg.wParam;
+ if Self_.fPaintDC = 0 then
+ Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct );
+ RC := Self_.ClientRect;
+ fX1 := 0;
+ fY1 := 0;
+ case Self_.DF.fGradientStyle of
+ gsRombic:
+ begin
+ fX2 := RC.Right / 128;
+ fY2 := RC.Bottom / 128;
+ end;
+ gsElliptic:
+ begin
+ fX2 := RC.Right / 256 * SQRT2;
+ fY2 := RC.Bottom / 256 * SQRT2;
+ end;
+ else
+ begin
+ fX2 := RC.Right / 256;
+ fY2 := RC.Bottom / 256;
+ end;
+ end;
+ case Self_.DF.fGradientStyle of
+ gsRectangle, gsRombic, gsElliptic:
+ begin
+ case Self_.DF.fGradientLayout of
+ glCenter, glTop, glBottom:
+ OffsetF( (RC.Right - fX2) / 2, 0 );
+ glTopRight, glBottomRight, glRight:
+ OffsetF( RC.Right - fX2 / 2, 0 );
+ glTopLeft, glBottomLeft, glLeft:
+ OffsetF( -fX2 / 2, 0 );
+ end;
+ case Self_.DF.fGradientLayout of
+ glCenter, glLeft, glRight:
+ OffsetF( 0, (RC.Bottom - fY2) / 2 );
+ glBottom, glBottomLeft, glBottomRight:
+ OffsetF( 0, RC.Bottom - fY2 / 2 );
+ glTop, glTopLeft, glTopRight:
+ OffsetF( 0, -fY2 / 2 )
+ end;
+ end;
+ end;
+ DX1 := -fX1 / 255; //(-RF.Left) / 255;
+ DY1 := -fY1 / 255; // (-RF.Top) / 255;
+ DX2 := (RC.Right - fX2) / 255; //(RC.Right - RF.Right) / 255;
+ DY2 := (RC.Bottom - fY2) / 255;
+ case Self_.DF.fGradientStyle of
+ gsRombic, gsElliptic:
+ begin
+ if DX2 < -DX1 then DX2 := -DX1;
+ if DY2 < -DY1 then DY2 := -DY1;
+ K := 2;
+ if Self_.DF.fGradientStyle = gsElliptic then K := SQRT2;
+ DX2 := DX2 * K;
+ DY2 := DY2 * K;
+ DX1 := -DX2;
+ DY1 := -DY2;
+ end;
+ end;
+ C2 := C;
+ for I := 0 to 255 do
+ begin
+ if (I < 255) then
+ begin
+ C2 := TColor( (( Ceil( B1 + DB * (I+1) ) and $FF) shl 16) or
+ (( Ceil( G1 + DG * (I+1) ) and $FF) shl 8) or
+ Ceil( R1 + DR * (I+1) ) and $FF );
+ if (Self_.DF.fGradientStyle in [gsRombic,gsElliptic,gsRectangle]) and
+ (C2 = C) then continue;
+ end;
+ Br := CreateSolidBrush( C );
+ R0 := MakeRect( Ceil( fX1 + DX1 * I ),
+ Ceil( fY1 + DY1 * I ),
+ Ceil( fX2 + DX2 * I ) + 1,
+ Ceil( fY2 + DY2 * I ) + 1 );
+ Rgn := 0;
+ case Self_.DF.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( Self_.fPaintDC, Rgn, Br );
+ ExtSelectClipRgn( Self_.fPaintDC, Rgn, RGN_DIFF );
+ end;
+ DeleteObject( Rgn );
+ end;
+ DeleteObject( Br );
+ C := C2;
+ end;
+ if TMethod( Self_.EV.fOnPaint2 ).Code = @ DummyPaintClear then
+ {$IFDEF MAKE_METHOD}
+ Self_.EV.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyObjProc ) );
+ {$ELSE}
+ TMethod( Self_.EV.fOnPaint2 ).Code := @DummyObjProc;
+ {$ENDIF}
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnPaint ) then
+ {$ENDIF}
+ Self_.EV.fOnPaint( Self_, Self_.fPaintDC );
+ if Self_.fPaintDC <> HDC( Msg.wParam ) then
+ EndPaint( Self_.fHandle, PaintStruct );
+ Self_.fPaintDC := OldPaintDC;
+ Rslt := 0;
+ Result := True;
+end;
+
+function WndProcLabelEffect( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var
+ Sz: TSize;
+ P0: TPoint;
+ CR: TRect;
+ B : Boolean;
+ CShadow: TColor;
+ Target: PCanvas;
+ Txt: KOLString;
+ //LCaption: PKOLChar;
+ OldPaintDC: HDC;
+
+ procedure doTextOut( shfx, shfy: Integer; col: TColor );
+ begin
+ SetTextColor( Target.fHandle, col );
+ {$IFDEF UNICODE_CTRLS}
+ Windows.ExtTextOutW( Target.fHandle, P0.x + shfx, P0.y + shfy,
+ ETO_CLIPPED, @CR,
+ PWideChar(Txt), Length(Txt), nil ); // KOL_ANSI
+ {$ELSE}
+ Windows.ExtTextOutA( Target.fHandle, P0.x + shfx, P0.y + shfy,
+ ETO_CLIPPED, @CR,
+ PAnsiChar(Txt), Length(Txt), nil ); // KOL_ANSI
+ {$ENDIF}
+ //GDIFlush; // for test only
+ end;
+
+var I, J, Istp : Integer;
+ PS: TPaintStruct;
+ //DoEndPaint: Boolean;
+begin
+ Result := False;
+ case Msg.message of
+ WM_SETTEXT:
+ begin
+ Self_.fCaption := PKOLChar( Msg.lParam );
+ Result := True;
+ Rslt := 1;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ WM_PRINTCLIENT, WM_PAINT:
+ begin
+ OldPaintDC := Self_.fPaintDC;
+ Self_.fPaintDC := Msg.wParam;
+ if Self_.fPaintDC = 0 then
+ Self_.fPaintDC := BeginPaint( Self_.fHandle, PS );
+ begin
+ Target := Self_.Canvas;
+ Txt := Self_.fCaption;
+ Target.{$IFDEF UNICODE_CTRLS}WTextArea{$ELSE}TextArea{$ENDIF}( Txt, Sz, P0 );
+ if Self_.DF.fShadowDeep <> 0 then
+ begin
+ for B := False to Self_.fCtl3D_child and 1 <> 0 do
+ begin
+ Inc( Sz.cx, Abs( Self_.DF.fShadowDeep ) );
+ Inc( Sz.cy, Abs( Self_.DF.fShadowDeep ) );
+ end;
+ end;
+ CR := Self_.ClientRect;
+ case Self_.fTextAlign of
+ taCenter: P0.x := P0.x + (CR.Right - Sz.cx) div 2;
+ taRight: P0.x := P0.x + (CR.Right - Sz.cx);
+ end;
+ case Self_.fVerticalAlign of
+ vaCenter: P0.y := P0.y + (CR.Bottom - Sz.cy) div 2;
+ vaBottom: P0.y := P0.y + (CR.Bottom - Sz.cy);
+ end;
+ if Self_.DF.fShadowDeep <> 0 then
+ begin
+ if Self_.DF.fColor2 = clNone then
+ CShadow := ColorsMix(Color2RGB(Self_.fTextColor),Color2RGB(Self_.DF.fColor2))
+ else
+ CShadow := Color2RGB( Self_.DF.fColor2 );
+ if {$IFDEF USE_FLAGS} not(G2_Transparent in Self_.fFlagsG2)
+ {$ELSE} not Self_.fTransparent {$ENDIF} then
+ Target.FillRect( CR ); // GDIFlush; for test only
+ Target.RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ SetBkMode( Target.fHandle, Windows.TRANSPARENT );
+ if Self_.fCtl3D_child and 1 <> 0 then
+ begin
+ I := - Self_.DF.fShadowDeep;
+ Istp := 1;
+ if Self_.DF.fShadowDeep > 0 then Istp := -1;
+ repeat
+ J := - Self_.DF.fShadowDeep;
+ repeat
+ if not ( (I=0) and (J=0) ) then
+ begin
+ if (I * Istp < 0) and (J * Istp < 0) then
+ doTextOut( I, J, CShadow );
+ end;
+ J := J - Istp;
+ until J = Self_.DF.fShadowDeep - IStp;
+ I := I - Istp;
+ until I = Self_.DF.fShadowDeep - IStp;
+ end
+ else
+ doTextout( Self_.DF.fShadowDeep, Self_.DF.fShadowdeep, CShadow );
+ doTextout( 0, 0, Color2RGB(Self_.fTextColor) );
+ end
+ else
+ begin
+ Target.RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
+ SetBkMode( Target.fHandle, Windows.TRANSPARENT );
+ doTextout( 0, 0, Color2RGB(Self_.fTextColor) );
+ end;
+ end;
+ if Self_.fCanvas <> nil then
+ Self_.fCanvas.SetHandle( 0 );
+ if Msg.wParam = 0 then
+ EndPaint( Self_.fHandle, PS );
+ Self_.fPaintDC := OldPaintDC;
+ Rslt := 0;
+ Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.DoClick;
+begin
+ PP.fControlClick( @Self );
+ {$IFDEF NIL_EVENTS}
+ if Assigned( EV.fOnClick ) then
+ {$ENDIF}
+ EV.fOnClick( @Self );
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.ParentForm: PControl;
+begin
+ Result := @Self;
+ if {$IFDEF USE_FLAGS} G3_IsControl in Result.fFlagsG3
+ {$ELSE} Result.fIsControl {$ENDIF} then
+ repeat
+ Result := Result.fParent;
+ until (Result = nil) or
+ {$IFDEF USE_FLAGS} not(G3_IsControl in Result.fFlagsG3)
+ {$ELSE} not Result.fIsControl {$ENDIF};
+end;
+{$ENDIF PAS_VERSION}
+{$IFDEF WIN_GDI}
+
+function TControl.FormParentForm: PControl;
+begin
+ Result := @Self;
+ while ( {$IFDEF USE_FLAGS} G3_IsControl in Result.fFlagsG3
+ {$ELSE} Result.fIsControl {$ENDIF} )
+ and not( {$IFDEF USE_FLAGS}
+ [G5_IsButton, G5_IsBitBtn] * Result.fFlagsG5 = [G5_IsBitBtn]
+ {$ELSE}
+ Result.fIsBitBtn and not Result.fIsButton
+ {$ENDIF} ) do
+ Result := Result.fParent;
+end;
+
+function TControl.MarkPanelAsForm: PControl;
+begin
+ Result := @ Self;
+ {$IFDEF USE_FLAGS}
+ Include( fFlagsG5, G5_IsBitBtn );
+ {$ELSE}
+ fIsBitBtn := TRUE;
+ {$ENDIF}
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetProgressColor(const Value: TColor);
+begin
+ if Perform( PBM_SETBARCOLOR, 0, Color2RGB(Value) ) <> 0 then
+ fTextColor := Value;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.SetShadowDeep(const Value: Integer);
+begin
+ DF.fShadowDeep := Value;
+ Invalidate;
+end;
+{$ENDIF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetFont: PGraphicTool;
+begin
+ if FFont = nil then
+ begin
+ FFont := NewFont;
+ {$IFDEF USE_AUTOFREE4CONTROLS}
+ Add2AutoFree( FFont );
+ {$ENDIF}
+ FFont.fData.Color := fTextColor;
+ FFont.OnChange := FontChanged;
+ end;
+ Result := FFont;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetBrush: PGraphicTool;
+begin
+ if FBrush = nil then
+ begin
+ FBrush := NewBrush;
+ FBrush.fData.Color := fColor;
+ FBrush.OnChange := BrushChanged;
+ {$IFDEF USE_AUTOFREE4CONTROLS}
+ Add2AutoFree( FBrush );
+ {$ENDIF}
+ end;
+ Result := FBrush;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN_GDI}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.FontChanged(Sender: PGraphicTool);
+begin
+ fTextColor := Sender.fData.Color;
+ ApplyFont2Wnd_Proc(@Self);
+ Invalidate;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.BrushChanged(Sender: PGraphicTool);
+begin
+ fColor := Sender.fData.Color;
+ if fTmpBrush <> 0 then
+ begin
+ DeleteObject( fTmpBrush );
+ fTmpBrush := 0;
+ end;
+ if fPaintDC = 0 then
+ // only if not in painting already :
+ Invalidate;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN_GDI}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure DoApplyFont2Wnd( _Self: PControl );
+begin
+ if _Self.fFont <> nil then
+ begin
+ if _Self.fHandle <> 0 then
+ begin
+ _Self.fTextColor := _Self.fFont.fData.Color;
+ _Self.Perform( WM_SETFONT, _Self.FFont.Handle, 1 );
+ end;
+
+ if _Self.fCanvas <> nil then
+ begin
+ _Self.fCanvas.Free;
+ _Self.fCanvas := nil;
+ end;
+
+ _Self.DoAutoSize;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE DoApplyFont2Wnd( _Self: PControl );
+VAR oldfontdesc: PPangoFontDescription;
+ rcstyle: PGtkRcStyle;
+ gcolor: TGdkColor;
+ i: Integer;
+BEGIN
+ IF ( _Self.fFont <> nil ) THEN
+ BEGIN
+ gcolor := Color2GdkColor( _Self.fFont.Color );
+
+ rcstyle := gtk_widget_get_modifier_style( _Self.fHandle );
+ oldfontdesc := rcstyle.font_desc;
+ rcstyle.font_desc :=
+ pango_font_description_copy( _Self.fFont.GetPangoFontDesc );
+ gtk_widget_modify_style( _Self.fHandle, rcstyle );
+
+ IF oldfontdesc <> nil THEN
+ pango_font_description_free( oldfontdesc );
+
+ FOR i := 0 TO 4 DO
+ gtk_widget_modify_fg( _Self.fCaptionHandle, {GTK_STATE_NORMAL} i, @ gcolor );
+ END;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.ResizeParent: PControl;
+begin
+ ResizeParentBottom;
+ ResizeParentRight;
+ // Once again, to fix Windows (or my???) bug with
+ // incorrect calculating of GetClientRect after
+ // SetWindowLong( GWL_[EX}STYLE,... )
+ Result := ResizeParentBottom;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.ResizeParentBottom: PControl;
+var NewCH: Integer;
+begin
+ Result := @Self;
+ if fParent <> nil then
+ begin
+ NewCH := BoundsRect.Bottom + fParent.fMargin;
+ if {$IFDEF USE_FLAGS} G2_ChangedH in fParent.fFlagsG2
+ {$ELSE} (fParent.fChangedPosSz and $20) <> 0 {$ENDIF} then
+ if NewCH <> fParent.ClientHeight then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fParent.ClientHeight := NewCH;
+ {$IFDEF USE_FLAGS} include( fParent.fFlagsG2, G2_ChangedH );
+ {$ELSE} fParent.fChangedPosSz := fParent.fChangedPosSz or $20; {$ENDIF}
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.ResizeParentRight: PControl;
+var NewCW: Integer;
+begin
+ Result := @Self;
+ if fParent <> nil then
+ begin
+ NewCW := fBoundsRect.Right + fParent.fMargin;
+ if {$IFDEF USE_FLAGS} G2_ChangedW in fParent.fFlagsG2
+ {$ELSE} (fParent.fChangedPosSz and $10) <> 0 {$ENDIF} then
+ if NewCW < fParent.ClientWidth then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fParent.ClientWidth := NewCW;
+ {$IFDEF USE_FLAGS} include( fParent.fFlagsG2, G2_ChangedW );
+ {$ELSE} fParent.fChangedPosSz := fParent.fChangedPosSz or $10; {$ENDIF}
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetClientHeight: Integer;
+begin
+ with ClientRect do
+ Result := Bottom - Top;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetClientWidth: Integer;
+begin
+ with ClientRect do
+ Result := Right - Left;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetClientHeight(const Value: Integer);
+var Delta: Integer;
+begin
+ Delta := ClientHeight;
+ Delta := Height - Delta;
+ Height := Value + Delta;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetClientWidth(const Value: Integer);
+var Delta: Integer;
+begin
+ Delta := ClientWidth;
+ Delta := Width - Delta;
+ Width := Value + Delta;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.CenterOnParent: PControl;
+var PCR: TRect;
+begin
+ Result := @Self;
+ if (fParent = nil) or
+ {$IFDEF USE_FLAGS} not(G3_IsControl in fFlagsG3)
+ {$ELSE} not fIsControl {$ENDIF} then
+ PCR := MakeRect( 0, 0, GetSystemMetrics( SM_CXSCREEN ), GetSystemMetrics( SM_CYSCREEN ) )
+ else
+ PCR := fParent.ClientRect;
+ GetWindowHandle;
+ Left := (PCR.Right - PCR.Left - Width) div 2;
+ Top := (PCR.Bottom - PCR.Top - Height) div 2;
+end;
+{$ENDIF PAS_VERSION}
+
+function TControl.CenterOnForm( Form1: PControl ): PControl;
+var PCR, DR: TRect;
+begin
+ Result := @Self;
+ if (Form1 = nil) then
+ PCR := MakeRect( 0, 0, GetSystemMetrics( SM_CXSCREEN ), GetSystemMetrics( SM_CYSCREEN ) )
+ else
+ PCR := Form1.BoundsRect;
+ GetWindowHandle;
+ Left := PCR.Left + (PCR.Right - PCR.Left - Width) div 2;
+ Top := PCR.Top + (PCR.Bottom - PCR.Top - Height) div 2;
+ PCR := BoundsRect;
+ DR := GetDesktopRect;
+ if PCR.Right > DR.Right then
+ OffsetRect( PCR, DR.Right - PCR.Right, 0 );
+ if PCR.Bottom > DR.Bottom then
+ OffsetRect( PCR, 0, DR.Bottom - PCR.Bottom );
+ if PCR.Left < DR.Left then
+ OffsetRect( PCR, DR.Left - PCR.Left, 0 );
+ if PCR.Top < DR.Top then
+ OffsetRect( PCR, 0, DR.Top - PCR.Top );
+ BoundsRect := PCR;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetHasBorder: Boolean;
+begin
+ UpdateWndStyles;
+ Result := LongBool( fStyle.Value and (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME))
+ or LongBool( fExStyle and WS_EX_CLIENTEDGE );
+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
+ if Value = GetHasBorder then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Value then
+ begin
+ if {$IFDEF USE_FLAGS} not(G3_IsControl in fFlagsG3)
+ {$ELSE} not fIsControl {$ENDIF} then
+ Style := fStyle.Value or WS_THICKFRAME or WS_BORDER or
+ WS_DLGFRAME or WS_CAPTION or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or
+ WS_SYSMENU
+ else
+ if fCtl3D_child and 1 <> 0 then
+ ExStyle := fExStyle or WS_EX_CLIENTEDGE
+ else
+ Style := fStyle.Value or WS_BORDER;
+ end
+ else
+ begin
+ NewStyle := fStyle.Value and not (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION
+ or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU);
+ if {$IFDEF USE_FLAGS} not(G3_IsControl in fFlagsG3)
+ {$ELSE} not fIsControl {$ENDIF} then
+ NewStyle := NewStyle or WS_POPUP;
+ Style := NewStyle;
+ ExStyle := fExStyle and not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME
+ or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE);
+ end;
+ {$IFDEF USE_FLAGS}
+ {$ELSE} //+MTsv DN
+ if fIsControl then
+ if fTabStop then
+ Style := fStyle.Value or WS_TABSTOP
+ 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;
+begin
+ UpdateWndStyles;
+ Result := not LongBool( fStyle.Value and (WS_POPUP or WS_DLGFRAME))
+ or LongBool( fStyle.Value and WS_CAPTION);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetHasCaption(const Value: Boolean);
+begin
+ if Value = GetHasCaption then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Value then
+ begin
+ Style := fStyle.Value and not (WS_POPUP or WS_DLGFRAME) or WS_CAPTION;
+ end
+ else
+ begin
+ if {$IFDEF USE_FLAGS} G3_IsControl in fFlagsG3
+ {$ELSE} fIsControl {$ENDIF} then
+ Style := fStyle.Value and not WS_CAPTION or WS_DLGFRAME
+ else
+ Style := fStyle.Value and not (WS_CAPTION or WS_SYSMENU) or WS_POPUP;
+ ExStyle := fExStyle or WS_EX_DLGMODALFRAME;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetCanResize: Boolean;
+begin
+ {$IFDEF USE_FLAGS}
+ Result := not(G1_PreventResize in fFlagsG1);
+ {$ELSE}
+ Result := not fPreventResize;
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+function WndProcCanResize( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean;
+var W, H: Integer;
+ P: PMinMaxInfo;
+begin
+ if not Sender.CanResize then
+ if M.message = WM_GETMINMAXINFO then
+ begin
+ Rslt := Sender.CallDefWndProc( M );
+ {$IFDEF FIX_WIDTH_HEIGHT}
+ W := Sender.FFixWidth;
+ H := Sender.FFixHeight;
+ {$ELSE}
+ W := Sender.fBoundsRect.Right - Sender.fBoundsRect.Left;
+ H := Sender.fBoundsRect.Bottom - Sender.fBoundsRect.Top;
+ {$ENDIF}
+ P := Pointer( M.lParam );
+ P.ptMinTrackSize.x := W;
+ P.ptMinTrackSize.y := H;
+ P.ptMaxTrackSize := P.ptMinTrackSize;
+ Result := True; // stop further processing (prevent resizing)
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end
+ else
+ if M.message = WM_NCHITTEST then
+ begin
+ Rslt := Sender.CallDefWndProc( M );
+ if (Rslt >= 10) and (Rslt <= 17) then
+ begin
+ {$IFDEF CANRESIZE_THICKFRAME}
+ Rslt := HTBORDER;
+ {$ELSE}
+ Rslt := HTNOWHERE;
+ {$ENDIF}
+ Result := True;
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end else
+ if M.message = WM_INITMENU then
+ begin
+ if not Sender.CanResize then
+ EnableMenuItem( GetSystemMenu( Sender.fHandle, FALSE ),
+ SC_SIZE, MF_GRAYED );
+ end;
+ Result := False; // continue message processing
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetCanResize( const Value: Boolean );
+begin
+ if Value = CanResize then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF USE_FLAGS}
+ if Value then exclude( fFlagsG1, G1_PreventResize )
+ else include( fFlagsG1, G1_PreventResize );
+ {$ELSE}
+ fPreventResize := not Value;
+ {$ENDIF}
+ {$IFDEF CANRESIZE_THICKFRAME}
+ if Value then
+ Style := Style or WS_THICKFRAME
+ else
+ Style := Style and not WS_THICKFRAME;
+ {$ENDIF}
+ {$IFDEF FIX_WIDTH_HEIGHT}
+ GetWindowHandle;
+ FFixWidth := Width;
+ FFixHeight := Height;
+ {$ENDIF FIX_WIDTH_HEIGHT}
+ AttachProc( WndProcCanResize );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetStayOnTop: Boolean;
+begin
+ UpdateWndStyles;
+ Result := LongBool( fExStyle and WS_EX_TOPMOST);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetStayOnTop(const Value: Boolean);
+begin
+ if Value = GetStayOnTop then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if fHandle <> 0 then
+ if Value then
+ SetWindowPos( fHandle, HWND_TOPMOST, 0,0,0,0,
+ SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE )
+ else
+ SetWindowPos( fHandle, HWND_NOTOPMOST, 0,0,0,0,
+ SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE )
+ else
+ if Value then fExStyle := fExStyle or WS_EX_TOPMOST
+ else fExStyle := fExStyle and not WS_EX_TOPMOST;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.UpdateWndStyles: PControl;
+begin
+ Result := @Self;
+ if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fStyle.Value := GetWindowLong( fHandle, GWL_STYLE );
+ fExStyle := GetWindowLong( fHandle, GWL_EXSTYLE );
+ fClsStyle := GetClassLong( fHandle, GCL_STYLE );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetChecked: Boolean;
+begin
+ if bboFixed in DF.fBitBtnOptions then
+ Result := {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4
+ {$ELSE} fChecked {$ENDIF}
+ else
+ Result := LongBool( Perform( BM_GETCHECK, 0, 0 ) ) ; //= BST_CHECKED;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.Set_Checked(const Value: Boolean);
+begin
+ if bboFixed in DF.fBitBtnOptions then
+ begin
+ {$IFDEF USE_FLAGS} include( fFlagsG4, G4_Checked );
+ {$ELSE} fChecked := Value; {$ENDIF}
+ Invalidate;
+ end
+ else
+ Perform( BM_SETCHECK, Integer( Value ), 0 );
+end;
+{$ENDIF PAS_VERSION}
+
+function TControl.SetChecked(const Value: Boolean): PControl;
+begin
+ Perform( BM_SETCHECK, Integer( Value ), 0 );
+ Result := @Self;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+function TControl.SetRadioChecked: PControl;
+{$IFDEF USE_FLAGS}
+var WasStyle: DWORD;
+{$ELSE}
+var WasTabStop: Boolean;
+{$ENDIF}
+begin
+ {$IFDEF USE_FLAGS}
+ WasStyle := fStyle.Value;
+ exclude( fStyle.f2_Style, F2_Tabstop );
+ DoClick;
+ fStyle.Value := WasStyle;
+ {$ELSE}
+ WasTabStop := fTabStop;
+ fTabStop := FALSE;
+ DoClick;
+ fTabStop := WasTabStop;
+ {$ENDIF}
+ Result := @Self;
+end;
+{$ENDIF PAS_VERSION}
+
+function TControl.GetCheck3: TTriStateCheck;
+begin
+ Result := TTriStateCheck(Perform(BM_GETCHECK, 0, 0) and 3);
+end;
+
+procedure TControl.SetCheck3(value: TTriStateCheck);
+var
+ wp: WPARAM;
+begin
+ wp := Perform(BM_GETCHECK, 0, 0) and not 3;
+ wp := wp or byte(value);
+ Perform(BM_SETCHECK, wp, 0);
+end;
+
+procedure TControl.Click;
+begin
+ if (fCommandActions.aClick <> 0) or
+ (fCommandActions.aEnter = BN_SETFOCUS) then
+ Perform( WM_COMMAND, (fCommandActions.aClick shl 16) or fMenu,
+ GetWindowHandle )
+ else
+ begin
+ Perform( WM_LBUTTONDOWN, MK_LBUTTON, 0 );
+ Perform( WM_LBUTTONUP, MK_LBUTTON, 0 );
+ end;
+end;
+
+type
+ TCharRange = record
+ cpMin: Longint;
+ cpMax: LongInt;
+ end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetSelStart: Integer;
+begin
+ Result := 0;
+ if fCommandActions.aGetSelRange <> 0 then
+ Perform( fCommandActions.aGetSelRange, Integer( @ Result ), 0 );
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.SetSelStart(const Value: Integer);
+begin
+ ItemSelected[ Value ] := True;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetSelLength: Integer;
+var Start, Finish: Integer;
+begin
+ Result := 0;
+ if fCommandActions.aGetSelCount <> 0 then
+ begin
+ if fCommandActions.aGetSelCount = EM_GETSEL then
+ begin
+ Perform( fCommandActions.aGetSelCount, Integer( @ Start ), Integer( @ Finish ) );
+ Result := Finish - Start;
+ end
+ else
+ begin
+ Result := Perform( fCommandActions.aGetSelCount {and $7FFF}, 0, 0 );
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetSelLength(const Value: Integer);
+var SR: TCharRange;
+begin
+ SR.cpMin := GetSelStart;
+ SR.cpMax := SR.cpMin + Value;
+ if Value < 0 then
+ SR.cpMax := -1;
+ if fCommandActions.aSetSelRange <> 0 then
+ Perform( fCommandActions.aSetSelRange, SR.cpMin, SR.cpMax )
+ else
+ if fCommandActions.aExSetSelRange <> 0 then
+ Perform( fCommandActions.aExSetSelRange, 0, Integer( @SR ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetItems(Idx: Integer): KOLString;
+var L, Pos: Integer;
+ Buf: PKOLChar;
+begin
+ Result := '';
+ Pos := Item2Pos( Idx );
+ Idx := Pos2Item( Pos );
+ if fCommandActions.aGetItemLength <> 0 then
+ L := Perform( fCommandActions.aGetItemLength, Pos, 0 )
+ else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if L = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ GetMem( Buf, (L + 4) * SizeOf( KOLChar ) );
+ PDWORD( Buf )^ := L + 1;
+ if fCommandActions.aGetItemText <> 0 then
+ Perform( fCommandActions.aGetItemText, Idx, Integer( Buf ) );
+ Buf[ L ] := #0;
+ Result := Buf;
+ FreeMem( Buf );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetItems(Idx: Integer; const Value: KOLString);
+var Strt, L : DWORD;
+ {$IFNDEF NOT_FIX_CURINDEX}
+ TmpCurIdx: Integer; // AK - Andrzey Kubasek
+ TmpData: DWORD;
+ {$ENDIF NOT_FIX_CURINDEX}
+begin
+ if fCommandActions.aSetItemText <> 0 then
+ begin
+ Strt := Item2Pos( Idx );
+ L := Item2Pos( Idx + 1 ) - Strt;
+ SelStart := Strt;
+ SelLength := L;
+ Perform( fCommandActions.aSetItemText, 0, Integer( PKOLChar( Value ) ) );
+ end
+ else
+ if fCommandActions.aDeleteItem <> 0 then
+ begin
+ {$IFNDEF NOT_FIX_CURINDEX}
+ TmpCurIdx := CurIndex; // +AK
+ TmpData := ItemData[ Idx ];
+ {$ENDIF}
+ Delete( Idx );
+ Insert( Idx, Value );
+ {$IFNDEF NOT_FIX_CURINDEX}
+ CurIndex := TmpCurIdx; //+AK
+ ItemData[ Idx ] := TmpData;
+ {$ENDIF}
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetItemsCount: Integer;
+begin
+ Result := 0;
+ {$IFDEF DEBUG_ANY}
+ try
+ if fCommandActions.aGetCount = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := Perform( fCommandActions.aGetCount, 0, 0 );
+ except
+ asm
+ int 3
+ end;
+ end;
+ {$ELSE}
+ if fCommandActions.aGetCount = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := Perform( fCommandActions.aGetCount, 0, 0 );
+ {$ENDIF DEBUG_ANY}
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.SetItemsCount(const Value: Integer);
+begin
+ if fCommandActions.aSetCount = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Perform( fCommandActions.aSetCount, Value, 0 );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.Item2Pos(ItemIdx: Integer): DWORD;
+begin
+ Result := ItemIdx;
+ if Byte( fCommandActions.bItem2Pos ) <> 0 then
+ Result := Perform( fCommandActions.bItem2Pos, ItemIdx, 0 );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.Pos2Item(Pos: Integer): DWORD;
+begin
+ Result := Pos;
+ if Byte( fCommandActions.bPos2Item ) <> 0 then
+ Result := Perform( fCommandActions.bPos2Item, Pos, 0 );
+end;
+{$ENDIF PAS_VERSION}
+
+function TControl.SavePosition: TEditPositions;
+var {$IFNDEF NOT_USE_RICHEDIT}
+ p: TPoint;
+ {$ENDIF USE_RICHEDIT}
+ i: Integer;
+begin
+ Result.SelStart := SelStart;
+ Result.SelLength := SelLength;
+ {$IFNDEF NOT_USE_RICHEDIT}
+ if {$IFDEF USE_FLAGS} (G1_CanNotDoublebuf in fFlagsG1)
+ {$ELSE} fCannotDoubleBuf {$ENDIF}
+ { TRUE for rich edit, FALSE for edit } then
+ begin
+ P.X := 0;
+ P.Y := 0;
+ i := Perform( EM_CHARFROMPOS, 0, Integer( @ P ) );
+ Result.TopLine := Pos2Item( i );
+ Result.TopColumn := i - Integer( Item2Pos( Result.TopLine ) );
+ Perform( EM_GETSCROLLPOS, 0, Integer( @ Result.ScrollPos ) );
+ end
+ else
+ {$ENDIF USE_RICHEDIT}
+ begin
+ i := 0;
+ i := Perform( EM_CHARFROMPOS, 0, i );
+ Result.TopLine := HiWord( i );
+ Result.TopColumn := LoWord( i ) - Item2Pos( Result.TopLine );
+ Result.ScrollPos.Y := GetScrollPos( Handle, SB_VERT );
+ Result.ScrollPos.X := GetScrollPos( Handle, SB_HORZ );
+ end;
+ Result.RestoreScroll := TRUE;
+end;
+
+procedure TControl.RestorePosition( const P: TEditPositions );
+var Cur: TEditPositions;
+begin
+ SelStart := P.SelStart;
+ SelLength := P.SelLength;
+ if P.RestoreScroll then
+ begin
+ Perform( EM_SCROLLCARET, 0, 0 );
+ Cur := SavePosition;
+ {$IFNDEF NOT_USE_RICHEDIT}
+ if {$IFDEF USE_FLAGS} (G1_CanNotDoublebuf in fFlagsG1)
+ {$ELSE} fCannotDoubleBuf {$ENDIF} then
+ begin // RichEdit
+ if P.TopLine <> Cur.TopLine then
+ Perform( EM_LINESCROLL, 0, P.TopLine - Cur.TopLine );
+ Perform( EM_SETSCROLLPOS, 0, Integer( @ P.ScrollPos ) );
+ end else // Edit
+ {$ENDIF USE_RICHEDIT}
+ begin
+ if (P.TopLine <> Cur.TopLine) or
+ (P.TopColumn <> Cur.TopColumn) then
+ Perform( EM_LINESCROLL, P.TopColumn - Cur.TopColumn,
+ P.TopLine - Cur.TopLine );
+ SetScrollPos( Handle, SB_VERT, P.ScrollPos.Y, TRUE );
+ SetScrollPos( Handle, SB_HORZ, P.ScrollPos.X, TRUE );
+ end;
+ end;
+end;
+
+procedure TControl.UpdatePosition( var p: TEditPositions; FromPos,
+ CountInsertDelChars, CountInsertDelLines: Integer );
+var d: Integer;
+begin
+ if (FromPos <= p.SelStart) and (CountInsertDelChars >= 0) or
+ (CountInsertDelChars < 0) and
+ ((FromPos + Abs( CountInsertDelChars ) <= p.SelStart)
+ ) then
+ begin
+ p.SelStart := p.SelStart + CountInsertDelChars;
+ end else
+ if FromPos >= p.SelStart + p.SelLength then
+ begin
+ // nothing to do
+ end else
+ if CountInsertDelChars < 0 then // deleting
+ begin
+ if FromPos - CountInsertDelChars > p.SelStart + p.SelLength then
+ CountInsertDelChars := -( p.SelStart + p.SelLength - FromPos );
+ if FromPos - CountInsertDelChars >= p.SelStart then
+ begin
+ d := FromPos - CountInsertDelChars - p.SelStart;
+ p.SelLength := p.SelLength - d;
+ //inc( CountInsertDelChars, d );
+ end;
+ inc( p.SelStart, CountInsertDelChars );
+ end else // inserting
+ begin
+ if (FromPos > p.SelStart) and (FromPos < p.SelStart + p.SelLength) then
+ inc( p.SelLength, CountInsertDelChars )
+ else
+ if FromPos <= p.SelStart then
+ inc( p.SelStart, CountInsertDelChars );
+ end;
+ p.TopLine := p.TopLine + CountInsertDelLines;
+end;
+
+function WndProcTabChar( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean;
+begin
+ if M.message = WM_CHAR then
+ begin
+ if M.wParam = 9 then
+ Sender.ReplaceSelection( #9, TRUE );
+ end;
+ Result := FALSE;
+end;
+
+function TControl.EditTabChar: PControl;
+begin
+ AttachProc( WndProcTabChar );
+ Result := @Self;
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TControl.Add(const S: KOLString): Integer;
+begin
+ if fCommandActions.aAddItem <> 0 then
+ begin
+ Result := Perform( fCommandActions.aAddItem, 0, Integer( PKOLChar( S ) ) );
+ if Count = 1 then
+ ItemSelected[ 0 ] := True;
+ end
+ else
+ begin
+ if Assigned( fCommandActions.aAddText ) then
+ fCommandActions.aAddText( @Self, S )
+ else
+ Text := Text + S;
+ Result := 0;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.Delete(Idx: Integer);
+begin
+ if fCommandActions.aDeleteItem <> 0 then
+ Perform( fCommandActions.aDeleteItem, Idx, 0 );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TControl.Insert(Idx: Integer; const S: KOLString): Integer;
+begin
+ if fCommandActions.aInsertItem <> 0 then
+ Result := Perform( fCommandActions.aInsertItem, Idx, Integer( PKOLChar( S ) ) )
+ else
+ Result := -1;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetItemSelected(ItemIdx: Integer): Boolean;
+var SS: Integer;
+begin
+ if fCommandActions.aGetSelected <> 0 then
+ begin
+ SS := Perform( fCommandActions.aGetSelected, ItemIdx, LVIS_SELECTED );
+ { Though it is written in docs that for combobox lParam for CB_GETCURSEL
+ is not used and _must_ be 0, therefore this code is working for
+ combobox too. }
+ if fCommandActions.aGetSelected <> CB_GETCURSEL then
+ ItemIdx := 1;
+ Result := SS = ItemIdx;
+ end
+ else
+ begin
+ SS := SelStart;
+ Result := (ItemIdx >= SS) and (ItemIdx < SS + SelLength);
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetItemSelected(ItemIdx: Integer; const Value: Boolean);
+var SR: TCharRange;
+begin
+ if fCommandActions.aSetSelected <> 0 then
+ Perform( fCommandActions.aSetSelected, Integer( Value ), ItemIdx )
+ else
+ if fCommandActions.aSetCurrent <> 0 then
+ Perform( fCommandActions.aSetCurrent, ItemIdx, 0 )
+ else
+ if fCommandActions.aSetSelRange <> 0 then
+ Perform( fCommandActions.aSetSelRange, ItemIdx, ItemIdx )
+ else
+ if fCommandActions.aExSetSelRange <> 0 then
+ begin
+ SR.cpMin := ItemIdx;
+ SR.cpMax := ItemIdx;
+ Perform( fCommandActions.aExSetSelRange, 0, Integer( @SR ) );
+ end
+ else
+ begin // for ImageShow: set the index and invalidate the control
+ FCurIndex := ItemIdx;
+ Invalidate;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetCtl3D(const Value: Boolean);
+begin
+ fCtl3D_child := fCtl3D_child and not 1 or Integer( Value ) and 1;
+ UpdateWndStyles;
+ if Value then
+ begin
+ Style := fStyle.Value and not WS_BORDER;
+ ExStyle := fExStyle or WS_EX_CLIENTEDGE;
+ end else
+ begin
+ Style := fStyle.Value or WS_BORDER;
+ ExStyle := fExStyle and not WS_EX_CLIENTEDGE;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.Shift(dX, dY: Integer): PControl;
+begin
+ Left := fBoundsRect.Left + dX;
+ Top := fBoundsRect.Top + dY;
+ Result := @Self;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure SetKeyEvent( Self_: PControl );
+begin
+ Self_.PP.fWndProcKeybd := WndProcKeybd;
+end;
+
+procedure TControl.SetOnChar(const Value: TOnChar);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnChar := Value;
+ SetKeyEvent( @Self );
+end;
+
+{$IFDEF SUPPORT_ONDEADCHAR}
+procedure TControl.SetOnDeadChar(const Value: TOnChar);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnDeadChar := Value;
+ SetKeyEvent( @Self );
+end;
+{$ENDIF SUPPORT_ONDEADCHAR}
+
+procedure TControl.SetOnKeyDown(const Value: TOnKey);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnKeyDown := Value;
+ SetKeyEvent( @Self );
+end;
+
+procedure TControl.SetOnKeyUp(const Value: TOnKey);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnKeyUp := Value;
+ SetKeyEvent( @Self );
+end;
+
+{$IFDEF ASM_TLIST}
+function CollectTabControls( Form: PControl ): PList;
+asm
+ PUSH EDI
+ PUSH EAX
+ CALL NewList
+ XCHG EDI, EAX
+ POP EAX
+ CALL @@collecttab
+ XCHG EAX, EDI
+ POP EDI
+ RET
+@@collecttab:
+ { <- EDI = Result:PList
+ EAX = Form (or Control)
+ }
+ PUSH EBP
+ XOR EBP, EBP // Result := FALSE;
+ PUSH ESI
+ PUSH EBX
+ MOV EDX, [EAX].TControl.fChildren
+ MOV ECX, [EDX].TList.fCount
+ MOV ESI, [EDX].TList.fItems
+ JECXZ @@e_loop
+@@loo: PUSH ECX
+ LODSD
+
+ PUSH EAX
+
+ TEST byte ptr [EAX].TControl.fStyle+2, WS_TABSTOP shr 16
+ JZ @@call_recur
+
+ {$IFDEF USE_FLAGS}
+ MOV EDX, dword ptr [EAX].TControl.fStyle.f2_Style
+ OR DL, DH
+ AND DL, (1 shl F3_Disabled) or (1 shl F2_Tabstop)
+ CMP DL, (1 shl F2_Tabstop)
+ JNZ @@call_recur
+ {$ELSE}
+ MOV DL, [EAX].TControl.fTabStop
+ AND DL, [EAX].TControl.fEnabled
+ JZ @@call_recur
+ {$ENDIF}
+
+ CALL TControl.GetToBeVisible
+ TEST AL, AL
+ POP EAX
+ JZ @@next
+ PUSH EAX
+
+ XCHG EDX, EAX
+ PUSH ESI
+ MOV ECX, [EDI].TList.fCount
+ MOV ESI, [EDI].TList.fItems
+ XOR EBX, EBX
+ JECXZ @@e_loo2
+@@loo2: LODSD
+ MOV AX, [EAX].TControl.fTabOrder
+ CMP AX, [EDX].TControl.fTabOrder
+ JLE @@next2
+ POP ESI
+ MOV ECX, EDX
+ MOV EDX, EBX
+ MOV EAX, EDI
+ CALL TList.Insert
+ JMP @@call_recur
+
+@@next2: INC EBX
+ LOOP @@loo2
+@@e_loo2:
+ POP ESI
+ MOV EAX, EDI
+ CALL TList.Add
+
+@@call_recur:
+ //OR EBP, 1 // Result := TRUE;
+ INC EBP
+ POP EAX
+ {$IFDEF USE_FLAGS}
+ TEST [EAX].TControl.fStyle.f3_Style, (1 shl F3_Disabled)
+ JNZ @@next
+ {$ELSE}
+ MOVZX ECX, [EAX].TControl.fEnabled
+ JECXZ @@next
+ {$ENDIF USE_FLAGS}
+ PUSH EAX
+ CALL @@collecttab
+ POP EDX
+ JZ @@next
+
+ MOV EAX, EDI
+ CALL TList.Remove
+
+@@next: POP ECX
+ LOOP @@loo
+
+@@e_loop:
+ POP EBX
+ POP ESI
+ TEST EBP, EBP
+ POP EBP
+end;
+{$ELSE PAS_VERSION} //Pascal
+function CollectTabControls( Form: PControl ): PList;
+var R: PList;
+ function CollectTab( P: PControl ): Boolean;
+ var I, J: Integer;
+ C, D: PControl;
+ begin
+ Result := FALSE;
+ for I := 0 to P.fChildren.fCount - 1 do
+ begin
+ C := P.fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ];
+ if {$IFDEF USE_FLAGS} (TRUE)
+ {$ELSE} C.fTabstop {$ENDIF}
+ and {$IFDEF USE_FLAGS} not(F3_Disabled in C.fStyle.f3_Style)
+ {$ELSE} C.fEnabled {$ENDIF}
+ and C.ToBeVisible and
+ (F2_Tabstop in C.fStyle.f2_Style) then
+ begin
+ D := nil;
+ for J := 0 to R.fCount - 1 do
+ begin
+ D := R.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ J ];
+ if D.fTabOrder > C.fTabOrder then
+ begin
+ Result := TRUE;
+ R.Insert( J, C );
+ break;
+ end
+ else
+ D := nil;
+ end;
+ if D = nil then
+ begin
+ R.Add( C );
+ Result := TRUE;
+ end;
+ end;
+ if {$IFDEF USE_FLAGS} not (F3_Disabled in C.fStyle.f3_Style)
+ {$ELSE} C.fEnabled {$ENDIF} then
+ begin
+ if CollectTab( C ) then
+ R.Remove( C );
+ end;
+ end;
+ end;
+ {$IFDEF DEBUG_COLLECTTABCONTROLS}
+ var SL: PStrList;
+ i: Integer;
+ C: PControl;
+ {$ENDIF}
+begin
+ R := NewList;
+ CollectTab( Form );
+ {$IFDEF DEBUG_COLLECTTABCONTROLS}
+ SL := NewStrList;
+ for i := 0 to R.Count-1 do
+ begin
+ C := R.Items[ i ];
+ SL.Add( Int2Str( C.fTabOrder ) + ' ' + Int2Str( C.fTag ) + ' ' + C.fCaption );
+ end;
+ SL.SaveToFile( GetStartDir + 'debug_collecttabcontrols.txt' );
+ SL.Free;
+ {$ENDIF}
+
+ Result := R;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+procedure Tabulate2Next( Form: PControl; Dir: Integer );
+asm
+ PUSHAD
+ PUSH EAX // save Form
+ MOV EBX, EAX
+ MOV EBP, EDX // EBP = Dir (direction <0 or >0)
+ CALL CollectTabControls
+ XCHG EDI, EAX // EDI = CL (list of controls)
+
+ MOV ECX, [EBX].TControl.DF.fCurrentControl // C := Form.fCurrentControl
+ XOR EBX, EBX // I = 0
+ JECXZ @@1
+ MOV BX, [ECX].TControl.fTabOrder // I = C.fTabOrder
+@@1:
+ MOV ECX, [EDI].TList.fCount
+ MOV ESI, [EDI].TList.fItems
+ XOR EDX, EDX
+ PUSH EDX // Ctrl1 = nil
+ PUSH EDX // Ctrl2 = nil
+ TEST ECX, ECX
+ JZ @@e_loop
+
+@@loop: PUSH ECX
+ LODSD
+ CMP [EAX].TControl.fTabOrder, BX
+ JZ @@next
+
+ MOV ECX, [ESP+8] // ECX = Ctrl1
+ JECXZ @@c1nil
+ MOV CX, [ECX].TControl.fTabOrder // ECX = Ctrl1.fTabOrder
+ TEST EBP, EBP
+ JGE @@c1ge
+
+ CMP [EAX].TControl.fTabOrder, BX
+ JGE @@2
+ CMP [EAX].TControl.fTabOrder, CX
+ JLE @@2
+
+@@c1new:
+ MOV [ESP+8], EAX // Ctrl1 := C
+ JMP @@2
+
+@@c1ge: CMP [EAX].TControl.fTabOrder, BX
+ JLE @@2
+ CMP [EAX].TControl.fTabOrder, CX
+ JL @@c1new
+ JMP @@2
+
+@@c1nil:
+ TEST EBP, EBP
+ JL @@c1nil_dirL
+ CMP [EAX].TControl.fTabOrder, BX
+ JG @@c1new
+ JMP @@2
+
+@@c1nil_dirL:
+ CMP [EAX].TControl.fTabOrder, BX
+ JL @@c1new
+
+@@2:
+ MOV ECX, [ESP+4] // ECX = Ctrl2
+ JECXZ @@c2new
+ MOV CX, [ECX].TControl.fTabOrder
+
+ TEST EBP, EBP
+ JL @@c2dirL
+ CMP [EAX].TControl.fTabOrder, CX
+ JGE @@next
+ JMP @@c2new
+
+@@c2dirL:
+ CMP [EAX].TControl.fTabOrder, CX
+ JLE @@next
+@@c2new:
+ MOV [ESP+4], EAX
+
+@@next: POP ECX
+ DEC ECX
+ JNZ @@loop
+ //LOOP @@loop
+@@e_loop:
+
+ POP EDX // Ctrl2
+ POP ECX // Ctrl1
+ INC ECX
+ LOOP @@3
+ MOV ECX, EDX
+@@3:
+ POP EBX // EBX = Form
+ JECXZ @@exit
+
+ XCHG EAX, ECX
+ {$IFDEF USE_GRAPHCTLS}
+ {$IFDEF USE_FLAGS}
+ TEST [EAX].TControl.fFlagsG6, 1 shl G6_GraphicCtl
+ JNZ @@4
+ {$ELSE}
+ CMP [EAX].TControl.fWindowed, 0
+ JZ @@4
+ {$ENDIF}
+ {$ENDIF}
+ MOV ECX, [EAX].TControl.fHandle
+ JECXZ @@no_handle
+@@4:
+ INC [EAX].TControl.fClickDisabled
+
+ PUSH EAX
+ MOV DL, 1
+ CALL TControl.SetFocused
+ POP EAX
+
+ DEC [EAX].TControl.fClickDisabled
+
+@@no_handle:
+ MOV [EBX].TControl.DF.fCurrentControl, EAX
+
+@@exit:
+ XCHG EAX, EDI
+ CALL TObj.RefDec
+ POPAD
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure Tabulate2Next( Form: PControl; Dir: Integer );
+var CL : PList;
+ I, J : Integer;
+ Ctrl1, Ctrl2, C : PControl;
+begin
+ CL := CollectTabControls( Form );
+
+ I := 0;
+ C := Form.DF.fCurrentControl;
+ if C <> nil then
+ I := C.fTabOrder;
+ Ctrl2 := nil;
+ Ctrl1 := nil;
+ for J := 0 to CL.fCount - 1 do
+ begin
+ C := CL.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ J ];
+ if C.fTabOrder = I then continue;
+ if (Ctrl1 = nil)
+ and ( (Dir >= 0) and (C.fTabOrder > I)
+ or (Dir < 0) and (C.fTabOrder < I) )
+ or (Dir >= 0)
+ and (C.fTabOrder > I) and (C.fTabOrder < Ctrl1.fTabOrder)
+ or (Dir < 0)
+ and (C.fTabOrder < I) and (C.fTabOrder > Ctrl1.fTabOrder)
+ then Ctrl1 := C;
+ if (Ctrl2 = nil)
+ or (Dir >= 0) and (C.fTabOrder < Ctrl2.fTabOrder)
+ or (Dir < 0) and (C.fTabOrder > Ctrl2.fTabOrder)
+ then Ctrl2 := C;
+ end;
+ if Ctrl1 = nil then
+ Ctrl1 := Ctrl2;
+ if Ctrl1 <> nil then
+ begin
+ if (Ctrl1.fHandle <> 0) {$IFDEF USE_GRAPHCTLS} or
+ {$IFDEF USE_FLAGS} (G6_GraphicCtl in Ctrl1.fFlagsG6)
+ {$ELSE} not Ctrl1.fWindowed {$ENDIF} {$ENDIF} then
+ begin
+ Inc( Ctrl1.fClickDisabled );
+ Ctrl1.Focused := TRUE;
+ Dec( Ctrl1.fClickDisabled );
+ end;
+ Form.DF.fCurrentControl := Ctrl1;
+ end;
+ CL.Free;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function Tabulate2Control( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
+var Form: PControl;
+begin
+ Result := False;
+ case Key of
+ VK_TAB: if not (tkTab in Self_.fLookTabKeys) then exit; {>>>>>>>>>>>>>>>>>>>>}
+ VK_LEFT, VK_RIGHT: if not (tkLeftRight in Self_.fLookTabKeys) then exit; {>>>}
+ VK_UP, VK_DOWN: if not (tkUpDown in Self_.fLookTabKeys) then exit; {>>>>>>>>>}
+ VK_NEXT, VK_PRIOR: if not (tkPageUpPageDn in Self_.fLookTabKeys) then
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := True;
+ if checkOnly then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Form := Self_.ParentForm;
+ case Key of
+ VK_TAB:
+ if GetKeyState( VK_SHIFT ) < 0 then
+ Tabulate2Next( Form, -1 )
+ else
+ Tabulate2Next( Form, 1 );
+ VK_RIGHT, VK_DOWN, VK_NEXT: Tabulate2Next( Form, 1 );
+ VK_LEFT, VK_UP, VK_PRIOR: Tabulate2Next( Form, -1 );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
+asm
+ PUSH EDI
+ MOVZX EDI, CL
+ TEST byte ptr [EAX].TControl.fLookTabKeys, 1
+ JZ @@1
+@@0:
+ MOV ECX, EDX
+ AND CL, 7Fh
+ CMP CL, VK_TAB
+ JNE @@1
+
+ PUSH EDX
+ CALL TControl.ParentForm
+ POP EDX
+ MOVSX EDX, DL
+ TEST EDX, EDX
+ JS @@tab
+
+ PUSH EAX
+
+ PUSH VK_SHIFT
+ CALL GetAsyncKeyState
+ SAR EAX, 31
+ {$IFDEF PARANOIA} DB $0C, $01 {$ELSE} OR AL, 1 {$ENDIF}
+ MOV EDX, EAX
+
+ POP EAX
+@@tab:
+ TEST EDI, EDI
+ POP EDI
+ JNZ @@no_tab
+ CALL Tabulate2Next
+@@no_tab:
+ MOV AL, 1
+ RET
+
+@@data: DB VK_LEFT, VK_LEFT
+ DD offset[@@left]
+ DB VK_UP, 2
+ DB VK_RIGHT, VK_RIGHT
+ DD offset[@@right]
+ DB VK_DOWN, 2
+ DB VK_UP, VK_PRIOR
+ DD offset[@@up]
+ DB VK_TAB or 80h, $C
+ DB VK_DOWN, VK_NEXT
+ DD offset[@@down]
+ DB VK_TAB, $C
+
+@@1:
+ // EAX <- Self_:PControl
+ // DL <- Key
+ PUSH ESI
+ MOV ESI, offset[@@data]-6
+ MOV DH, 9
+ PUSH EAX
+@@loop:
+ ADD DH, DH
+ JNB @@l1
+ JMP @@abort
+@@fault1:
+ POP EDI
+ POPAD
+ PUSH EAX
+@@abort:
+ POP EAX
+@@abort1:
+ POP ESI
+ POP EDI
+ XOR EAX, EAX
+ RET
+
+@@right:
+ MOV EAX, [ESP].TRect.Left
+ SUB EAX, [ESP+16].TRect.Left
+@@left_right:
+ JL @@next1
+ MOV EDX, [ESP].TRect.Bottom
+ SUB EDX, [ESP+16].TRect.Top
+ JL @@next1
+ MOV EDX, [ESP].TRect.Top
+ SUB EDX, [ESP+16].TRect.Bottom
+ JGE @@next1
+@@chk_dist:
+ CMP EAX, EDI
+ JA @@next1
+ MOV EDI, EAX
+ MOV EAX, [EBX+ECX*4-4]
+ MOV [ESP+36], EAX // Found = Ctrl
+ JMP @@next1
+
+@@l1:
+ LODSD
+ LODSW
+ LODSW
+ CMP AL, DL
+ JE @@2
+ CMP AH, DL
+ JNE @@loop
+
+@@2:
+ PUSH ESI
+ LODSD
+ LODSW
+ POP ESI
+ XCHG EDX, EAX
+ POP EAX
+ TEST [EAX].TControl.fLookTabKeys, DH
+ JZ @@abort1
+
+ PUSHAD
+ PUSH EDI
+ CALL TControl.ParentForm
+ MOV ECX, [EAX].TControl.DF.fCurrentControl
+ JECXZ @@fault1
+ MOV EBP, ECX // EBP = CurCtrl
+
+ PUSH EAX // save Form
+ MOV EBX, EAX
+ CALL CollectTabControls
+ PUSH 0 // save Found = nil
+ PUSH EAX // save CollectedList
+ MOV EDI, EAX
+
+ MOV EBX, [EDI].TList.fItems
+ ADD ESP, -16
+ PUSH ESP
+ PUSH [EBP].TControl.fHandle
+ CALL GetWindowRect
+
+ MOV ECX, [EDI].TList.fCount
+ OR EDI, -1 // EDI = minDist
+@@loop1:
+ MOV EAX, [EBX+ECX*4-4]
+ CMP EAX, EBP
+ JE @@next
+ {}
+ {$IFDEF USE_FLAGS}
+ MOV DX, word ptr [EAX].TControl.fStyle.f2_Style
+ AND DX, ($100 shl F3_Disabled) or (1 shl F2_Tabstop)
+ XOR DH, (1 shl F3_Disabled)
+ {$ELSE}
+ MOV DL, [EAX].TControl.fEnabled
+ AND DL, [EAX].TControl.fTabstop
+ {$ENDIF USE_FLAGS}
+ JZ @@next
+ {}
+ ADD ESP, -16
+ MOV EDX, ESP
+ PUSH ECX
+ PUSH EDX
+ PUSH [EAX].TControl.fHandle
+ CALL GetWindowRect
+ POP ECX
+ JMP dword ptr [ESI]
+
+@@left:
+ MOV EAX, [ESP+16].TRect.Left
+ SUB EAX, [ESP].TRect.Left
+ JMP @@left_right
+
+@@not_found:
+ POP EDI
+ POPAD
+ MOV DL, [ESI+4]
+ POP ESI
+ JMP @@0
+
+@@up:
+ MOV EAX, [ESP+16].TRect.Top
+ SUB EAX, [ESP].TRect.Top
+ JMP @@up_down
+@@down:
+ MOV EAX, [ESP].TRect.Top
+ SUB EAX, [ESP+16].TRect.Top
+@@up_down:
+ JL @@next1
+ MOV EDX, [ESP].TRect.Right
+ SUB EDX, [ESP+16].TRect.Left
+ JL @@next1
+ MOV EDX, [ESP].TRect.Left
+ SUB EDX, [ESP+16].TRect.Right
+ JL @@chk_dist
+
+@@next1:
+ ADD ESP, 16
+@@next:
+ LOOP @@loop1
+ ADD ESP, 16
+ POP EAX // pop CollectedList
+ CALL TObj.RefDec
+ POP ECX // pop Found
+ POP EAX // pop Form
+ JECXZ @@not_found
+
+ POP EDI
+ TEST EDI, EDI
+ JNZ @@no_go
+
+ MOV [EAX].TControl.DF.fCurrentControl, ECX
+ INC [ECX].TControl.fClickDisabled
+ PUSH ECX
+ MOV ECX, [ECX].TControl.fHandle
+ JECXZ @@4
+ PUSH ECX
+ CALL Windows.SetFocus
+@@4: POP ECX
+ DEC [ECX].TControl.fClickDisabled
+@@no_go:
+ POPAD
+ POP ESI
+ POP EDI
+ MOV AL, 1 // Result = True
+end;
+{$ELSE PAS_VERSION} //Pascal
+function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
+label search_tabcontrol;
+var Form: PControl;
+ CL : PList;
+ I : Integer;
+ CurCtrl, Ctrl, Found : PControl;
+ MinDist, Dist: Integer;
+ R, R1 : TRect;
+begin
+ Result := False;
+ case Key of
+ VK_TAB: if not (tkTab in Self_.fLookTabKeys) then exit; {>>>>>>>>>>>>>>>>>>>>}
+ VK_LEFT, VK_RIGHT: if not (tkLeftRight in Self_.fLookTabKeys) then exit; {>>>}
+ VK_UP, VK_DOWN: if not (tkUpDown in Self_.fLookTabKeys) then exit; {>>>>>>>>>}
+ VK_NEXT, VK_PRIOR: if not (tkPageUpPageDn in Self_.fLookTabKeys) then
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ else exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := True;
+ if checkOnly then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Form := Self_.ParentForm;
+ if Key = VK_TAB then
+ if GetKeyState( VK_SHIFT ) < 0 then
+ Tabulate2Next( Form, -1 )
+ else
+ Tabulate2Next( Form, 1 )
+ else
+ begin
+ CL := CollectTabControls( Form );
+ I := CL.IndexOf( Form.DF.fCurrentControl );
+ Found := nil;
+ if I >= 0 then
+ begin
+ CurCtrl := CL.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ];
+ GetWindowRect( CurCtrl.Handle, R );
+ search_tabcontrol:
+ MinDist := MaxInt;
+ for I := CL.fCount - 1 downto 0 do
+ begin
+ Ctrl := CL.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ];
+ if Ctrl = CurCtrl then continue;
+ if not ({$IFDEF USE_FLAGS} not(F3_Disabled in Ctrl.fStyle.f3_Style)
+ {$ELSE} Ctrl.fEnabled {$ENDIF}
+ and
+ {$IFDEF USE_FLAGS} (F2_Tabstop in Ctrl.fStyle.f2_Style)
+ {$ELSE} Ctrl.fTabstop {$ENDIF}
+ ) then continue;
+ GetWindowRect( Ctrl.Handle, R1 );
+ Dist := MaxInt;
+ case Key of
+ VK_LEFT:
+ begin
+ if (R1.Bottom < R.Top)
+ or (R1.Top >= R.Bottom)
+ or (R1.Left > R.Left) then continue;
+ Dist := R.Left - R1.Left;
+ end;
+ VK_RIGHT:
+ begin
+ if (R1.Bottom < R.Top)
+ or (R1.Top >= R.Bottom)
+ or (R1.Left < R.Left) then continue;
+ Dist := R1.Left - R.Left;
+ end;
+ VK_UP, VK_PRIOR:
+ begin
+ if (R1.Right < R.Left)
+ or (R1.Left >= R.Right)
+ or (R1.Top > R.Top) then continue;
+ Dist := R.Top - R1.Top;
+ end;
+ VK_DOWN, VK_NEXT:
+ begin
+ if (R1.Right < R.Left)
+ or (R1.Left >= R.Right)
+ or (R1.Top < R.Bottom) then continue;
+ Dist := R1.Top - R.Top;
+ end;
+ end;
+ if Dist < MinDist then
+ begin
+ Found := Ctrl;
+ MinDist := Dist;
+ end;
+ end;
+ if Found = nil then
+ begin
+ case Key of
+ VK_LEFT:
+ begin
+ Key := VK_UP; goto search_tabcontrol;
+ end;
+ VK_RIGHT:
+ begin
+ Key := VK_DOWN; goto search_tabcontrol;
+ end;
+ VK_UP, VK_PRIOR:
+ Tabulate2Next( Form, -1 );
+ VK_DOWN, VK_NEXT:
+ Tabulate2Next( Form, 1 );
+ end;
+ end
+ else
+ begin
+ if Found.fHandle <> 0 then
+ begin
+ Inc( Found.fClickDisabled );
+ SetFocus( Found.fHandle );
+ Dec( Found.fClickDisabled );
+ end;
+ Form.DF.fCurrentControl := Found;
+ end;
+ end;
+ CL.Free;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.Tabulate: PControl;
+var F : PControl;
+begin
+ Result := @Self;
+ F := ParentForm;
+ if F = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ F.PP.fGotoControl := Tabulate2Control;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.TabulateEx: PControl;
+var F : PControl;
+begin
+ Result := @Self;
+ F := ParentForm;
+ if F = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ F.PP.fGotoControl := Tabulate2ControlEx;
+end;
+{$ENDIF PAS_VERSION}
+
+function WndProcMouseTransparent( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := FALSE;
+ if Msg.message = WM_NCHITTEST then
+ begin
+ Rslt := HTTRANSPARENT;
+ Result := TRUE;
+ end;
+end;
+
+function TControl.MouseTransparent: PControl;
+begin
+ AttachProc( WndProcMouseTransparent );
+ Result := @ Self;
+end;
+
+procedure TControl.GotoControl(Key: DWORD);
+var Form: PControl;
+begin
+ Form := ParentForm;
+ if Form <> nil then
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Form.PP.fGotoControl ) then
+ {$ENDIF}
+ Form.PP.fGotoControl( Form.DF.fCurrentControl, Key, false );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetCurIndex: Integer;
+var I, J: Integer;
+begin
+ Result := fCurIndex;
+ if fCommandActions.aGetCurrent = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ I := 0;
+ if fCommandActions.aGetCurrent = EM_LINEINDEX then
+ Dec( I );
+ J := 0;
+ if fCommandActions.aGetCurrent = LVM_GETNEXTITEM then
+ begin
+ J := 2 {LVNI_SELECTED};
+ Dec( I );
+ end;
+ Result := Perform( fCommandActions.aGetCurrent, I, J );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetCurIndex(const Value: Integer);
+var NMHdr: TNMHdr; idx: Integer;
+begin
+ if fCommandActions.aSetCurrent <> 0 then
+ begin
+ idx := Perform( fCommandActions.aSetCurrent, Value, 0 ); // fix AV
+ if fCommandActions.aSetCurrent = TCM_SETCURSEL then
+ begin
+ fCurIndex := idx; // fix AV
+ NMHdr.code := TCN_SELCHANGE;
+ NMHdr.hwndFrom := fHandle;
+ Perform( WM_NOTIFY, 0, Integer( @NMHdr ) );
+ end;
+ end
+ else
+ ItemSelected[ Value ] := True;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN_GDI}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetTextAlign: TTextAlign;
+begin
+ UpdateWndStyles;
+ if (fStyle.Value and fCommandActions.aTextAlignRight) = fCommandActions.aTextAlignRight then
+ Result := taRight
+ else
+ if (fStyle.Value and fCommandActions.aTextAlignCenter) = fCommandActions.aTextAlignCenter then
+ Result := taCenter
+ else
+ Result := fTextAlign;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION TControl.GetTextAlign: TTextAlign;
+BEGIN
+ Result := fTextAlign;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetTextAlign(const Value: TTextAlign);
+var NewStyle: DWORD;
+begin
+ fTextAlign := Value;
+ NewStyle := 0;
+ with fCommandActions{$IFDEF COMMANDACTIONS_OBJ}^{$ENDIF} do
+ case Value of
+ taLeft: NewStyle := fStyle.Value and not DWORD(aTextAlignCenter or aTextAlignRight)
+ or aTextAlignLeft;
+ taRight: NewStyle := fStyle.Value and not DWORD(aTextAlignLeft or aTextAlignCenter)
+ or aTextAlignRight;
+ taCenter: NewStyle := fStyle.Value and not DWORD(aTextAlignLeft or aTextAlignRight)
+ or aTextAlignCenter;
+ end;
+ NewStyle := NewStyle and not DWORD(fCommandActions.bTextAlignMask);
+ Style := NewStyle;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TControl.SetTextAlign(const Value: TTextAlign);
+BEGIN
+ IF fTextAlign = Value THEN Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fTextAlign := Value;
+ IF Assigned( fSetTextAlign ) THEN
+ fSetTextAlign( @ Self );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetVerticalAlign: TVerticalAlign;
+begin
+ UpdateWndStyles;
+ if (fStyle.Value and (Byte( fCommandActions.bVertAlignCenter ) shl 8))
+ = (Byte( fCommandActions.bVertAlignCenter ) shl 8) then
+ Result := vaCenter
+ else
+ if (fStyle.Value and (fCommandActions.bVertAlignBottom shl 8))
+ = (fCommandActions.bVertAlignBottom shl 8) then
+ Result := vaBottom
+ else
+ Result := fVerticalAlign;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION TControl.GetVerticalAlign: TVerticalAlign;
+BEGIN
+ Result := fVerticalAlign;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetVerticalAlign(const Value: TVerticalAlign);
+var NewStyle: DWORD;
+begin
+ fVerticalAlign := Value;
+ with fCommandActions{$IFDEF COMMANDACTIONS_OBJ}^{$ENDIF} do
+ begin
+ NewStyle := fStyle.Value and
+ not DWORD((bVertAlignTop or bVertAlignCenter or bVertAlignBottom) shl 8);
+ case Value of
+ vaCenter: NewStyle := NewStyle or (bVertAlignCenter shl 8);
+ vaTop: NewStyle := NewStyle or (bVertAlignTop shl 8);
+ vaBottom: NewStyle := NewStyle or (bVertAlignBottom shl 8);
+ end;
+ end;
+ Style := NewStyle;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE TControl.SetVerticalAlign(const Value: TVerticalAlign);
+BEGIN
+ if fVerticalAlign = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fVerticalAlign := Value;
+ if Assigned( fSetTextAlign ) then
+ fSetTextAlign( @ Self );
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.Dc2Canvas( Sender: PCanvas ): HDC;
+begin
+ if fPaintDC <> 0 then
+ begin
+ Result := fPaintDC;
+ Sender.SetHandle( Result );
+ Sender.fIsPaintDC := True;
+ end
+ else
+ begin
+ if Sender.fHandle <> 0 then
+ Result := Sender.fHandle
+ else
+ Result := GetDC( GetWindowHandle );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF WIN_GDI}
+
+{$IFDEF GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetCanvas: PCanvas;
+begin
+ {$IFDEF SAFE_CODE}
+ CreateWindow;
+ {$ENDIF}
+ if ( fCanvas = nil ) then
+ begin
+ fCanvas := NewCanvas( 0 );
+ fCanvas.fOnGetHandle := Dc2Canvas;
+ fCanvas.fOwnerControl := @Self;
+ if ( fFont <> nil ) then
+ fCanvas.fFont := fCanvas.fFont.Assign( fFont );
+ if ( fBrush <> nil ) then
+ fCanvas.fBrush := fCanvas.fBrush.Assign( fBrush );
+ end;
+ Result := fCanvas;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION TControl.ProvideCanvasHandle( Sender: PCanvas ): HDC;
+TYPE PPGdkGC = ^PGdkGC;
+VAR Array_gc: PPGdkGC;
+BEGIN
+ IF fInBkPaint THEN Array_gc := @ fEventboxHandle.style.bg_gc[ 0 ]
+ ELSE Array_gc := @ fEventboxHandle.style.fg_gc[ 0 ];
+ CASE fEventboxHandle.state OF
+ GTK_STATE_NORMAL,
+ GTK_STATE_ACTIVE,
+ GTK_STATE_PRELIGHT,
+ GTK_STATE_SELECTED,
+ GTK_STATE_INSENSITIVE: Result := PPGdkGC( Integer( Array_gc ) + fEventboxHandle.state * sizeof( Pointer ) )^;
+ ELSE Result := Array_gc^;
+ END;
+END;
+
+FUNCTION TControl.GetCanvas: PCanvas;
+BEGIN
+ {$IFDEF SAFE_CODE}
+ CreateWindow;
+ {$ENDIF}
+ IF ( fCanvas = nil ) then
+ BEGIN
+ fCanvas := NewCanvas( nil );
+ fCanvas.fOnGetHandle := ProvideCanvasHandle;
+ fCanvas.fOwnerControl := @Self;
+ fCanvas.fDrawable := Pointer( fEventboxHandle.window );
+ END;
+ fCanvas.GetHandle; // получим здесь тот контекст, который соответствует
+ // текущему состоянию контрола (если это контрол) и текущей
+ // стадии рисования
+ Result := fCanvas;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+{$IFDEF WIN_GDI}
+
+function TControl.DblBufTopParent: PControl;
+var Ctl: PControl;
+begin
+ Result := nil;
+ Ctl := @ Self;
+ while Ctl <> nil do
+ begin
+ if {$IFDEF USE_FLAGS} ( [G2_DoubleBuffered, G2_Transparent] * Ctl.fFlagsG2 <> [] )
+ {$ELSE} (Ctl.fDoubleBuffered) or (Ctl.fTransparent) {$ENDIF} then
+ Result := Ctl;
+ Ctl := Ctl.fParent;
+ end;
+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}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetTransparent(const Value: Boolean);
+begin
+ if fParent = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF USE_FLAGS}
+ if Value then
+ include( fFlagsG2, G2_Transparent )
+ else exclude( fFlagsG2, G2_Transparent );
+ {$ELSE} fTransparent := Value; {$ENDIF}
+
+{$IFDEF GRAPHCTL_XPSTYLES}
+ if not AppTheming then
+ begin
+ {$IFDEF USE_FLAGS}
+ if Value then
+ include( fFlagsG3, G3_ClassicTransparent )
+ else exclude( fFlagsG3, G3_ClassicTransparent );
+ {$ELSE} fClassicTransparent := Value; {$ENDIF}
+ end;
+{$ENDIF}
+
+ if Value then begin
+ AttachProc(WndProcTransparent);
+ fParent.DoubleBuffered := TRUE;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function TControl.SetBorder( Value: Integer ): PControl;
+begin
+ fMargin := Value;
+ Result := @ Self;
+end;
+
+{ TTrayIcon }
+
+var FTrayItems: PList;
+
+{$IFDEF ASM_noVERSION} // ASM_TLIST!
+function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
+asm
+ PUSH ECX
+ MOV ECX, [EDX].TMsg.message
+ CMP CX, CM_TRAYICON
+ JNE @@1
+
+ MOV ECX, [EDX].TMsg.lParam
+ MOV EDX, [EDX].TMsg.wParam
+ MOV EAX, [EDX].TTrayIcon.fOnMouse.TMethod.Data
+ CMP word ptr [EDX].TTrayIcon.fOnMouse.TMethod.Code+2, 0
+ JE @@no_on
+
+ CALL [EDX].TTrayIcon.fOnMouse.TMethod.Code
+@@no_on:
+ POP ECX
+ XOR EAX, EAX
+ MOV [ECX], EAX
+ INC EAX
+ RET
+
+@@1:
+ SUB ECX, WM_CLOSE
+ JNE @@exit_0
+@@2:
+
+ POP ECX
+ PUSH EBX
+ XCHG EBX, EAX
+
+ MOV EAX, [EBX].TControl.fHandle
+ CMP EAX, [EDX].TMsg.hwnd
+ JNE @@otherwin
+
+ MOV EDX, [FTrayItems]
+ MOV ECX, [EDX].TList.fCount
+ MOV EDX, [EDX].TList.fItems
+@@loop:
+ MOV EAX, [EDX + ECX*4 - 4]
+ CMP [EAX].TTray.FNoAutoDeactivate, 0
+ JNZ @@3
+ CMP [EAX].TTrayIcon.fControl, EBX
+ JNE @@3
+ PUSHAD
+ XOR EDX, EDX
+ CALL TTrayIcon.SetActive
+ POPAD
+@@3: LOOP @@loop
+
+@@otherwin:
+ POP EBX
+ PUSH ECX
+@@exit_0:
+ XOR EAX, EAX
+ POP ECX
+end;
+{$ELSE PAS_VERSION} //Pascal
+function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
+var Self_: PTrayIcon;
+ I : Integer;
+begin
+ Result := False;
+ case Msg.message of
+ CM_TRAYICON:
+ begin
+ Self_ := Pointer( Msg.wParam );
+ if Assigned( Self_.FOnMouse ) then
+ Self_.FOnMouse( @Self_, Msg.lParam );
+ Rslt := 0;
+ Result := True;
+ end;
+ WM_CLOSE:
+ if Msg.hwnd = Control.fHandle then
+ begin
+ if FTrayItems <> nil then // ?????????????????
+ for I := FTrayItems.Count - 1 downto 0 do
+ begin
+ Self_ := FTrayItems.Items[ I ];
+ if not Self_.FNoAutoDeactivate then
+ if Self_.FControl = Control then
+ Self_.Active := False;
+ end;
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function WndProcTrayIconWnd( Wnd: HWnd; Msg: DWORD; wParam, lParam: Integer ): Integer;
+ stdcall;
+var PrevProc: function ( Wnd: HWnd; Msg: DWORD;
+ wParam, lParam: Integer ): Integer; stdcall;
+var Tr: PTrayIcon;
+begin
+ PrevProc := Pointer( GetProp( Wnd, 'TRAYSAVEPROC' ) );
+ if Msg = CM_TRAYICON then
+ begin
+ Tr := Pointer( wParam );
+ if Assigned( Tr.FOnMouse ) then
+ Tr.FOnMouse( Tr, lParam );
+ Result := 0; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end
+ else
+ if Msg = WM_CLOSE then
+ begin
+ if Assigned( PrevProc ) then
+ begin
+ SetWindowLong( Wnd, GWL_WNDPROC, Integer( @ PrevProc ) );
+ RemoveProp( Wnd, 'TRAYSAVEPROC' );
+ PostMessage( Wnd, WM_CLOSE, wParam, lParam );
+ Result := 0; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ if (Wnd <> 0) and IsWindow( Wnd ) and Assigned( PrevProc ) then
+ Result := PrevProc( Wnd, Msg, wParam, lParam )
+ else Result := DefWindowProc( Wnd, Msg, wParam, lParam );
+end;
+
+procedure TTrayIcon.AttachProc2Wnd;
+begin
+ if FWnd = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if GetProp( FWnd, 'TRAYSAVEPROC' ) <> 0 then Exit; // already attached {>>>>>}
+ SetProp( FWnd, 'TRAYSAVEPROC', GetWindowLong( FWnd, GWL_WNDPROC ) );
+ SetWindowLong( FWnd, GWL_WNDPROC, Integer( @ WndProcTrayIconWnd ) );
+end;
+// [END TTrayIcon.AttachProc2Wnd]
+
+// [PROCEDURE TTrayIcon.DetachProc2Wnd]
+procedure TTrayIcon.DetachProc2Wnd;
+var OldProc: function ( Wnd: HWnd; Msg: DWORD;
+ wParam, lParam: Integer ): Integer; stdcall;
+begin
+ if FWnd = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ OldProc := Pointer( GetProp( FWnd, 'TRAYSAVEPROC' ) );
+ if not Assigned( OldProc ) then Exit; // not attached {>>>>>>>>>>>>>>>>>>>>}
+ SetWindowLong( FWnd, GWL_WNDPROC, Integer( @ OldProc ) );
+ RemoveProp( FWnd, 'TRAYSAVEPROC' );
+end;
+// [END TTrayIcon.DetachProc2Wnd]
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon;
+begin
+ if FTrayItems = nil then
+ FTrayItems := NewList;
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TTrayIcon';
+ {$ENDIF}
+ FTrayItems.Add( Result );
+ if Wnd <> nil then
+ Wnd.AttachProc( WndProcTray );
+ Result.FControl := Wnd;
+ Result.FIcon := Icon;
+ Result.Active := True;
+end;
+{$ENDIF PAS_VERSION}
+
+var fRecreateMsg: DWORD;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function WndProcRecreateTrayIcons( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var I: Integer;
+ TI: PTrayIcon;
+begin
+ if Msg.message = fRecreateMsg then
+ begin
+ for I := 0 to FTrayItems.fCount - 1 do
+ begin
+ TI := FTrayItems.Items[ I ];
+ if TI.fAutoRecreate then
+ if TI.fActive then
+ begin
+ TI.fActive := False;
+ TI.Active := True;
+ end;
+ end;
+ end;
+ Result := False;
+end;
+{$ENDIF PAS_VERSION}
+
+const
+ TaskbarCreatedMsg: array[ 0..14 ] of KOLChar = ('T','a','s','k','b','a','r',
+ 'C','r','e','a','t','e','d',#0);
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TTrayIcon.SetAutoRecreate(const Value: Boolean);
+begin
+ fAutoRecreate := Value;
+ FControl.ParentForm.AttachProc( WndProcRecreateTrayIcons );
+ fRecreateMsg := RegisterWindowMessage( TaskbarCreatedMsg );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TTrayIcon.Destroy;
+begin
+ Active := False;
+
+ if fIcon <> 0 then
+ DestroyIcon( fIcon );
+
+ FTrayItems.Remove( @ Self );
+ if FTrayItems.Count = 0 then
+ Free_And_Nil( FTrayItems );
+ FTooltip := '';
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TTrayIcon.SetActive(const Value: Boolean);
+begin
+ if FActive = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if FIcon = 0 then Exit;
+ if (Wnd = 0) and ((FControl = nil) or (FControl.GetWindowHandle = 0)) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FActive := Value;
+ if Value then
+ SetTrayIcon( NIM_ADD )
+ else
+ SetTrayIcon( NIM_DELETE );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TTrayIcon.SetIcon(const Value: HIcon);
+var Cmd : DWORD;
+begin
+ if FIcon = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ // Previous icon is not destroying. This is normal for icons, loaded from
+ // resources using LoadIcon. For icons, created using CreateIconIndirect, You
+ // have to call DestroyIcon manually.
+ Cmd := NIM_MODIFY;
+ if FIcon = 0 then
+ Cmd := NIM_ADD;
+ FIcon := Value;
+ if FActive then
+ SetTrayIcon( Cmd );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+procedure TTrayIcon.SetTooltip(const Value: KOLString);
+begin
+ if FTooltip = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FTooltip := Value;
+ if Active then
+ SetTrayIcon( NIM_MODIFY );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+procedure TTrayIcon.SetTrayIcon(const Value: DWORD);
+var NID : {$IFDEF UNICODE_CTRLS} TNotifyIconDataW {$ELSE} TNotifyIconData {$ENDIF};
+ L : Integer;
+ V : DWORD;
+begin
+ V := Value;
+ if AppletTerminated then
+ V := NIM_DELETE;
+ if Wnd <> 0 then
+ NID.Wnd := Wnd
+ else
+ NID.Wnd := FControl.fHandle;
+
+ NID.cbSize := Sizeof( NID );
+ NID.uID := DWORD( @Self );
+ NID.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
+ if V = NIM_DELETE then
+ NID.uFlags := 0;
+ NID.uCallbackMessage := CM_TRAYICON;
+ NID.hIcon := FIcon;
+ L := Length( FToolTip );
+ if L > 63 then L := 63;
+ Move( FTooltip[1], NID.szTip[0], Min( 63, L )*SizeOf(KOLChar) );
+ NID.szTip[ L ] := #0;
+
+ Shell_NotifyIcon( V, @NID );
+end;
+{$ENDIF PAS_VERSION}
+
+{ -- JustOne -- }
+
+var JustOneMutex: THandle;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
+begin
+ Result := False;
+ case Msg.message of
+ WM_CLOSE, WM_NCDESTROY:
+ if LongBool( JustOneMutex ) and (Control.Handle = Msg.hwnd) then
+ begin
+ CloseHandle( JustOneMutex );
+ JustOneMutex := 0;
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$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;
+begin
+ Result := False;
+ CritSecMutex := CreateMutex( nil, True, nil );
+ if CritSecMutex = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+
+ JustOneMutex := CreateMutex( nil, False, PKOLChar( Identifier ) );
+ if JustOneMutex <> 0 then
+ begin
+ DW := WaitForSingleObject( JustOneMutex, 0 );
+ Result := (DW <> WAIT_TIMEOUT);
+ end;
+ Wnd.AttachProc( WndProcJustOne );
+ CloseHandle( CritSecMutex );
+end;
+{$ENDIF PAS_VERSION}
+
+{ JustOneNotify }
+
+var
+ OnAnotherInstance: TOnAnotherInstance;
+ JustOneMsg: DWORD;
+
+{$IFDEF ASM_UNICODE}{$ELSE ASM_UNICODE} //Pascal
+function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
+var Buf : array[0..MAX_PATH] of KOLChar;
+begin
+ WndProcJustOne( Control, Msg, Rslt );
+ Result := False;
+ if Msg.message = JustOneMsg then
+ begin
+ Result := True;
+ if assigned( OnAnotherInstance ) then
+ begin
+ GetWindowText( Msg.lParam, Buf, MAX_PATH );
+ OnAnotherInstance( Buf );
+ end;
+ Rslt := 0;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+// Redefine here incorrectly declared BroadcastSystemMessage API function.
+// It should not refer to BroadcastSystemMessageA, which is not present in
+// earlier versions of Windows95, but to BroadcastSystemMessage, which is
+// present in all Windows95/98/Me and NT/2K/XP.
+function BroadcastSystemMessage(Flags: DWORD; Recipients: PDWORD;
+ uiMessage: UINT; wParam: WPARAM; lParam: LPARAM): Longint; stdcall;
+external user32 name 'BroadcastSystemMessage';
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function JustOneNotify( Wnd: PControl; const Identifier : KOLString;
+ const aOnAnotherInstance: TOnAnotherInstance ) : Boolean;
+var Recipients : DWord;
+ OldCap: KOLString;
+begin
+ Result := False;
+ JustOneMsg := RegisterWindowMessage( PKOLChar( 'Message.' + Identifier ) );
+ if JustOneMsg = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+
+ Result := JustOne( Wnd, Identifier );
+ if not Result then
+ begin
+ // Send a message to the first instance of applet
+ OldCap := Wnd.Caption;
+ Wnd.Caption := GetCommandLine;
+ if Wnd.GetWindowHandle <> 0 then
+ begin
+ Recipients := BSM_APPLICATIONS;
+ BroadcastSystemMessage( BSF_QUERY or BSF_IGNORECURRENTTASK, @Recipients,
+ JustOneMsg, 0, Wnd.fHandle );
+ end;
+ Wnd.Caption := OldCap;
+ end
+ else
+ begin
+ // Store event handler to notify this instance about another
+ // instance staring:
+ OnAnotherInstance := aOnAnotherInstance;
+ Wnd.AttachProc( WndProcJustOneNotify );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+///////////////////////////////////////// STRING LIST OBJECT /////////////////
+
+{$ENDIF WIN}
+{ TStrList }
+
+function NewStrList: PStrList;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TStrList';
+ {$ENDIF}
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TStrList.Destroy;
+begin
+ Clear;
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TStrList.Init;
+begin
+ {$IFDEF CALL_INHERITED}
+ inherited;
+ {$ENDIF}
+ fNameDelim := DefaultNameDelimiter;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TStrList.Add(const S: Ansistring): integer;
+begin
+ Result := fCount;
+ Insert( Result, S );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TStrList.AddStrings(Strings: PStrList);
+begin
+ SetText( Strings.Text, True );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TStrList.Assign(Strings: PStrList);
+begin
+ Clear;
+ AddStrings( Strings );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TStrList.Clear;
+var I: Integer;
+begin
+ if fCount > 0 then
+ for I := fList.Count - 1 downto 0 do
+ Delete( I );
+ fList.Free;
+ fList := nil;
+ fCount := 0;
+ if fTextBuf <> nil then
+ begin
+ FreeMem( fTextBuf );
+ fTextBuf := nil;
+ fTextSiz := 0;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION} {$DEFINE TStrList_Delete_ASM} {$ENDIF}
+{$IFDEF TLIST_FAST} {$UNDEF TStrList_Delete_ASM} {$ENDIF}
+
+{$IFDEF TStrList_Delete_ASM}
+{$ELSE PAS_VERSION} //Pascal
+procedure TStrList.Delete(Idx: integer);
+var P: DWORD;
+ El:Pointer;
+begin
+ P := DWORD( fList.Items[ Idx ] );
+ if (fTextBuf <> nil) and ( P >= DWORD( fTextBuf )) and
+ ( P < DWORD( fTextBuf ) + fTextSiz ) then
+ else
+ begin
+ El := FList.Items[ Idx ];
+ FreeMem( El );
+ end;
+ fList.Delete( Idx );
+ Dec( fCount );
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TStrList.DeleteLast;
+begin
+ Delete( Count-1 );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TStrList.Get(Idx: integer): Ansistring;
+begin
+ if fList <> nil then
+ Result := PAnsiChar( fList.Items[ Idx ] )
+ else Result := '';
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+function TStrList.GetPChars(Idx: Integer): PAnsiChar;
+asm
+ MOV EAX, [EAX].fList
+ MOV EAX, [EAX].TList.fItems
+ MOV EAX, [EAX+EDX*4]
+end;
+{$ELSE PAS_VERSION} //Pascal
+function TStrList.GetPChars(Idx: Integer): PAnsiChar;
+begin
+ Result := PAnsiChar( fList.{$IFDEF TLIST_FAST}Items{$ELSE}fItems{$ENDIF}[ Idx ] )
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+function TStrList.GetTextStr: Ansistring;
+asm
+ PUSH ESI
+ PUSH EDI
+ MOV ECX, [EAX].fCount
+ MOV EAX, [EAX].fList
+ PUSH ECX
+ JECXZ @@1
+ MOV ESI, [EAX].TList.fItems
+@@1: PUSH ESI
+ XCHG EAX, EDX
+ XOR EDX, EDX
+ JECXZ @@10
+ PUSH EAX
+@@loo1: PUSH ECX
+ PUSH EDX
+ LODSD
+ CALL StrLen
+ POP EDX
+ LEA EDX, [EDX+EAX+2]
+ POP ECX
+ LOOP @@loo1
+ POP EAX
+ POP ESI
+ XCHG ECX, EDX
+ PUSH EAX
+@@10: {$IFDEF _D2}
+ CALL _LStrFromPCharLen
+ {$ELSE}
+ {$IFDEF _D2009orHigher}
+ XOR ECX, ECX
+ {$ENDIF}
+ CALL System.@LStrFromPCharLen
+ {$ENDIF}
+ POP EDI
+ POP ECX
+ JECXZ @@exit
+ MOV EDI, [EDI]
+@@loo2: PUSH ECX
+ LODSD
+ PUSH EAX
+ CALL StrLen
+ XCHG ECX, EAX
+ POP EAX
+ XCHG EAX, ESI
+ REP MOVSB
+ XCHG ESI, EAX
+ MOV AX, $0A0D
+ STOSW
+ POP ECX
+ LOOP @@loo2
+ XCHG EAX, ECX
+ STOSB
+@@exit: POP EDI
+ POP ESI
+end;
+{$ELSE PAS_VERSION} //Pascal
+function TStrList.GetTextStr: Ansistring;
+var
+ I, Len, Size: integer;
+ P: PAnsiChar;
+begin
+ Size := 0;
+
+ for I := 0 to fCount - 1 do
+ Inc(Size, StrLen( PAnsiChar(fList.
+ {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF} [I]) ) +
+ {$IFDEF LIN} 1 {$ELSE} 2 {$ENDIF});
+
+ SetString(Result, nil, Size);
+
+ P := Pointer(Result);
+ for I := 0 to Count - 1 do
+ begin
+ Len := StrLen(PAnsiChar(fList.
+ {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF} [I]));
+ if (Len > 0) then
+ begin
+ System.Move(PAnsiChar(fList.
+ {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[I])^,
+ P^, Len);
+ Inc(P, Len);
+ end;
+ P^ := #13;
+ Inc(P);
+ {$IFDEF WIN}
+ P^ := #10;
+ Inc(P);
+ {$ENDIF WIN}
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+function TStrList.IndexOf(const S: Ansistring): integer;
+asm
+ PUSH EDI
+ PUSH ESI
+ PUSH EBX
+ OR EDI, -1
+ MOV ECX, [EAX].fCount
+ JECXZ @@exit
+ MOV ESI, [EAX].fList
+ MOV ESI, [ESI].TList.fItems
+ CALL EDX2PChar
+ MOVZX EBX, BYTE[EDX]
+@@loo: LODSD
+ INC EDI
+ CMP BL, BYTE[EAX]
+ JNE @@1
+ PUSH EDX
+ PUSH ECX
+ CALL StrComp
+ POP ECX
+ POP EDX
+ JE @@exit
+@@1: LOOP @@loo
+ OR EDI, -1
+@@exit: XCHG EAX, EDI
+ POP EBX
+ POP ESI
+ POP EDI
+end;
+{$ELSE PAS_VERSION} //Pascal
+function TStrList.IndexOf(const S: AnsiString): integer;
+var Word1: Word;
+begin
+ if S = '' then
+ begin
+ for Result := 0 to fCount - 1 do
+ if PAnsiChar(fList.Items[Result])^ = #0 then Exit; {>>>>>>>>>>>>>>>>>>}
+ end else
+ begin
+ Word1 := PWord(PAnsiChar( S ))^;
+ for Result := 0 to fCount - 1 do
+ if (PWord(fList.Items[Result])^ = Word1)
+ and (StrComp( fList.Items[Result], PAnsiChar( S ) ) = 0) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := -1;
+end;
+{$ENDIF PAS_VERSION}
+
+function TStrList.IndexOf_NoCase(const S: AnsiString): integer;
+var tmp: PAnsiChar;
+ c: AnsiChar;
+begin
+ if S = '' then
+ begin
+ for Result := 0 to fCount - 1 do
+ if PAnsiChar( fList.Items[Result] )^ = #0 then Exit; {>>>>>>>>>>}
+ end else
+ begin
+ if not Upper_initialized then
+ Init_Upper;
+ for Result := 0 to fCount - 1 do
+ begin
+ tmp := fList.Items[Result];
+ c := Upper[S[1]];
+ if (c = Upper[tmp^]) and
+ (_AnsiCompareStrNoCaseA( PAnsiChar( S ), tmp ) = 0) then Exit; {>>>}
+ end;
+ end;
+ Result := -1;
+end;
+
+function TStrList.IndexOfStrL_NoCase( Str: PAnsiChar; L: Integer ): integer;
+begin
+ if L = 0 then
+ Result := 0
+ else
+ begin
+ for Result := 0 to fCount - 1 do
+ if (StrLen( PAnsiChar( fList.
+ {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ Result ]
+ ) ) = DWORD( L )) and
+ (StrLComp_NoCase( Str, PAnsiChar(
+ fList.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ Result ]
+ ), L ) = 0) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := -1;
+ end;
+end;
+
+function CompareAnsiCase( const S1, S2: PAnsiChar ): Integer;
+begin
+ Result := _AnsiCompareStrA( S1, S2 );
+end;
+
+function CompareAnsiNoCase( const S1, S2: PAnsiChar ): Integer;
+begin
+ Result := _AnsiCompareStrNoCaseA( S1, S2 );
+end;
+
+function TStrList.Find(const S: AnsiString; var Index: Integer): Boolean;
+var
+ L, H, C: Integer;
+begin
+ Result := FALSE;
+ Index := 0;
+ L := 0;
+ H := FCount - 1;
+ if H < 0 then Exit; // === if FCount = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>}
+ if fAnsiSort then
+ begin
+ if fCaseSensitiveSort then
+ fCompareStrListFun := CompareAnsiCase
+ else
+ fCompareStrListFun := CompareAnsiNoCase;
+ end else
+ begin
+ if fCaseSensitiveSort then
+ fCompareStrListFun := StrComp
+ else
+ fCompareStrListFun := StrComp_NoCase;
+ end;
+ C := 0;
+ while L <= H do
+ begin
+ Index := (L + H) shr 1;
+ C := fCompareStrListFun( PAnsiChar( fList.Items[ Index ] ),
+ PAnsiChar( S ) );
+ if C < 0 then L := Index + 1 else
+ begin
+ H := Index - 1;
+ if C = 0 then
+ begin
+ Result := TRUE; {Index := I;} Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end;
+ if C < 0 then 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[ Index-1 ] ),
+ PAnsiChar( S )) = 0) do
+ dec( Index );
+ end;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TStrList.Insert(Idx: integer; const S: Ansistring);
+var Mem: PAnsiChar;
+ L: Integer;
+begin
+ if fList = nil then
+ fList := NewList;
+ L := Length( S ) + 1;
+ GetMem( Mem, L );
+ Mem[0] := #0;
+ if L > 1 then
+ System.Move( S[1], Mem[0], L );
+ fList.Insert( Idx, Mem );
+ Inc( fCount );
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TStrList.Move(CurIndex, NewIndex: integer);
+begin
+ fList.MoveItem( CurIndex, NewIndex );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TStrList.Put(Idx: integer; const Value: Ansistring);
+begin
+ Delete( Idx );
+ Insert( Idx, Value );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+procedure TStrList.SetText(const S: Ansistring; Append2List: boolean);
+asm
+ DEC CL
+ JZ @@1
+ PUSHAD
+ CALL Clear
+ POPAD
+@@1: CALL EDX2PChar
+ JZ @@exit
+ PUSH EBX
+ PUSH EDI
+ MOV EBX, EAX
+ MOV EDI, [EBX].fTextSiz
+ MOV EAX, [EDX-4] // EAX = Length(S)
+ INC EAX
+ PUSH EAX
+ // add S to text buffer
+ PUSH EDX
+ PUSH [EBX].fTextBuf
+ ADD EAX, [EBX].fTextSiz
+ CALL System.@GetMem
+ MOV [EBX].fTextBuf, EAX
+ MOV ECX, EDI
+ XCHG EDX, EAX
+ POP EAX
+ JECXZ @@atb_fin
+ PUSH EAX
+ CALL System.Move
+ POP EDX
+ PUSH EDX
+ PUSH ESI
+ MOV ESI, [EBX].fList
+ MOV ESI, [ESI].TList.fItems
+ MOV ECX, [EBX].fCount
+@@atb_loo:
+ LODSD
+ SUB EAX, EDX
+ CMP EAX, [EBX].fTextSiz
+ JAE @@atb_nxt
+ ADD EAX, [EBX].fTextBuf
+ MOV [ESI-4], EAX
+@@atb_nxt: LOOP @@atb_loo
+ POP ESI
+ POP EAX
+ CALL System.@FreeMem
+@@atb_fin:
+ POP EAX
+ MOV EDX, EDI
+ ADD EDX, [EBX].fTextBuf
+ POP ECX
+ PUSH ECX
+ ADD [EBX].fTextSiz, ECX
+ CALL System.Move
+@@eatb:
+ ADD EDI, [EBX].fTextBuf // EDI ~ P
+ MOV ECX, [EBX].fList
+ INC ECX
+ LOOP @@2
+ CALL NewList
+ MOV [EBX].fList, EAX
+@@2:
+ POP ECX
+ MOV EDX, [EBX].fCount
+ PUSH EDI
+ PUSH ECX
+ MOV AL, $0D
+@@loo1: CMP byte ptr [EDI], 0
+ JZ @@eloo1
+ INC EDX
+ REPNZ SCASB
+ JNZ @@eloo1
+ CMP byte ptr [EDI], $0A
+ JNZ @@loo1
+ INC EDI
+ LOOP @@loo1
+@@eloo1:
+ MOV [EBX].fCount, EDX
+ MOV EAX, [EBX].fList
+ {$IFNDEF TLIST_FAST}
+ PUSH EDX
+ PUSH EAX
+ CMP EDX, [EAX].TList.fCapacity
+ JLE @@3
+ CALL TList.SetCapacity
+@@3: POP EAX
+ POP ECX
+ {$ENDIF TLIST_FAST}
+ XCHG ECX, [EAX].TList.fCount
+ MOV EDX, [EAX].TList.fItems
+ LEA EDX, [EDX+ECX*4]
+ POP ECX
+ POP EDI
+ MOV EAX, $0D
+@@loo2: CMP byte ptr [EDI], AH
+ JZ @@eloo2
+ MOV [EDX], EDI
+ ADD EDX, 4
+ REPNZ SCASB
+ JNZ @@eloo2
+ MOV [EDI-1], AH
+ CMP byte ptr [EDI], $0A
+ JNZ @@loo2
+ INC EDI
+ LOOP @@loo2
+@@eloo2:
+ POP EDI
+ POP EBX
+@@exit:
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure TStrList.SetText(const S: Ansistring; Append2List: Boolean);
+var
+ P, TheLast : PAnsiChar;
+ L, I : Integer;
+
+ procedure AddTextBuf(Src: PAnsiChar; Len: DWORD);
+ var OldTextBuf, P: PAnsiChar;
+ I : Integer;
+ begin
+ if Src <> nil then
+ begin
+ OldTextBuf := fTextBuf;
+ GetMem( fTextBuf, fTextSiz + Len );
+ if fTextSiz <> 0 then
+ begin
+ System.Move( OldTextBuf^, fTextBuf^, fTextSiz );
+ for I := 0 to fCount - 1 do
+ begin
+ P := fList.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ];
+ if (DWORD( P ) >= DWORD( OldTextBuf )) and
+ (DWORD( P ) < DWORD( OldTextBuf ) + fTextSiz) then
+ fList.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ] :=
+ Pointer( DWORD( P ) - DWORD( OldTextBuf ) + DWORD( fTextBuf ) );
+ end;
+ FreeMem( OldTextBuf );
+ end;
+ System.Move( Src^, fTextBuf[ fTextSiz ], Len );
+ Inc( fTextSiz, Len );
+ end;
+ end;
+begin
+ if not Append2List then Clear;
+ if S = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ L := fTextSiz;
+ AddTextBuf( PAnsiChar( S ), Length( S ) + 1 );
+ P := PAnsiChar( DWORD( fTextBuf ) + DWORD( L ) );
+ if fList = nil then fList := NewList;
+ I := 0;
+ TheLast := P + Length( S );
+ while P^ <> #0 do
+ begin
+ Inc( I );
+ {$IFDEF WIN}
+ P := StrScanLen( P, #13, TheLast - P );
+ if P^ = #10 then
+ Inc( P );
+ {$ELSE LIN}
+ P := StrScanLen( P, #10, TheLast - P );
+ {$ENDIF}
+ end;
+ Inc( fCount, I );
+ {$IFNDEF TLIST_FAST}
+ if fList.fCapacity < fCount then
+ fList.Capacity := fCount;
+ {$ENDIF}
+ P := PAnsiChar( DWORD( fTextBuf ) + DWORD( L ) );
+ while P^ <> #0 do
+ begin
+ fList.Add( P );
+ {$IFDEF WIN}
+ P := StrScanLen( P, #13, TheLast - P );
+ if PAnsiChar( P - 1 )^ = #13 then
+ PAnsiChar( P - 1 )^ := #0;
+ if P^ = #10 then Inc(P);
+ {$ELSE LIN}
+ P := StrScanLen( P, #10, TheLast - P );
+ {$ENDIF}
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TStrList.SetUnixText(const S: AnsiString; Append2List: Boolean);
+var S1: AnsiString;
+begin
+ S1 := S;
+ NormalizeUnixText( S1 );
+ SetText( S1, Append2List );
+end;
+
+procedure TStrList.SetTextStr(const Value: Ansistring);
+begin
+ SetText( Value, False );
+end;
+
+{$IFDEF ASM_TLIST}
+function CompareStrListItems_NoCase( 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_NoCase
+end;
+{$ELSE PAS_VERSION} //Pascal
+function CompareStrListItems_NoCase( 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_NoCase( S1, S2 );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+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;
+{$ELSE PAS_VERSION} //Pascal
+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;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+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
+end;
+{$ELSE PAS_VERSION} //Pascal
+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;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_TLIST}
+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 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 )
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TStrList.Sort(CaseSensitive: Boolean);
+begin
+ fCaseSensitiveSort := CaseSensitive;
+ fAnsiSort := FALSE;
+ {$IFDEF SPEED_FASTER}
+ {$DEFINE SORT_STRLIST_ARRAY}
+ {$ENDIF}
+ {$IFDEF TLIST_FAST}
+ {$UNDEF SORT_STRLIST_ARRAY}
+ {$ENDIF}
+ {$IFDEF _D2}
+ {$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}
+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);
+begin
+ fCaseSensitiveSort := CaseSensitive;
+ fAnsiSort := TRUE;
+ {$IFDEF SPEED_FASTER}
+ {$DEFINE SORT_STRLIST_ARRAY}
+ {$ENDIF}
+ {$IFDEF TLIST_FAST}
+ {$UNDEF SORT_STRLIST_ARRAY}
+ {$ENDIF}
+ {$IFDEF _D2}
+ {$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}
+ {$IFDEF SORT_STRLIST_ARRAY}
+ if CaseSensitive then
+ SortArray( fList.fItems, fCount, @_AnsiCompareStrA )
+ else
+ SortArray( fList.fItems, fCount, @_AnsiCompareStrNoCaseA );
+ {$ELSE}
+ if CaseSensitive then
+ SortData( @Self, fCount, @CompareAnsiStrListItems_Case, @TStrList.Swap )
+ else
+ SortData( @Self, fCount, @CompareAnsiStrListItems, @TStrList.Swap );
+ {$ENDIF}
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TStrList.SortEx(const CompareFun: TCompareEvent);
+begin
+ SortData( @Self, Count, CompareFun, @TStrList.Swap );
+end;
+
+procedure TStrList.Swap(Idx1, Idx2: Integer);
+begin
+ fList.Swap( Idx1, Idx2 );
+end;
+
+function TStrList.Last: AnsiString;
+begin
+ if Count = 0 then
+ Result := ''
+ else
+ Result := Items[ Count - 1 ];
+end;
+
+//-- code by Dod:
+function TStrList.IndexOfName(AName: Ansistring): Integer;
+var i: Integer;
+ L: Integer;
+begin
+ Result:=-1;
+ // Do not start search if empty string
+ L := Length( AName );
+ if L > 0 then
+ begin
+ AName := LowerCase( AName ) + fNameDelim;
+ Inc( L );
+ for i := 0 to fCount - 1 do
+ begin
+ // For optimization, check only list entry that begin with same letter as searched name
+ if StrLComp( PAnsiChar( LowerCase( ItemPtrs[ i ] ) ), PAnsiChar( AName ), L ) = 0 then
+ begin
+ Result:=i; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end;
+end;
+
+function TStrList.IndexOfName_NoCase(AName: Ansistring): Integer;
+var i: Integer;
+ L: Integer;
+ s, p: PAnsiChar;
+begin
+ Result:=-1;
+ L := Length( AName );
+ if L > 0 then
+ begin
+ s := PAnsiChar( AName );
+ for i := 0 to fCount - 1 do
+ begin
+ if StrLComp_NoCase( ItemPtrs[ i ], s, L ) = 0 then
+ begin
+ p := ItemPtrs[ i ];
+ inc( p, L );
+ while (p^ <> #0) and (p^ <= ' ') do inc( p );
+ if p^ = fNameDelim then
+ begin
+ Result := i; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end;
+ end;
+end;
+
+//-- code by Dod:
+function TStrList.GetValue(const AName: Ansistring): Ansistring;
+var
+ i: Integer;
+begin
+ I := IndexOfName(AName);
+ if I >= 0
+ then Result := Copy(Items[i], Length(AName) + 2, Length(Items[i])-Length(AName)-1)
+ else Result := '';
+end;
+
+//-- code by Dod:
+procedure TStrList.SetValue(const AName, Value: Ansistring);
+var
+ I: Integer;
+begin
+ I := IndexOfName(AName);
+ if i=-1
+ then Add( AName + fNameDelim + Value )
+ else Items[i] := AName + fNameDelim + Value;
+end;
+
+function TStrList.GetLineName(Idx: Integer): AnsiString;
+var s: AnsiString;
+ Q: PAnsiChar;
+begin
+ s := ItemPtrs[ Idx ];
+ Q := StrScan( PAnsiChar(s), fNameDelim );
+ if Assigned(Q) {by Dufa} then Q^ := #0;
+ Result := PAnsiChar(s);
+end;
+
+procedure TStrList.SetLineName(Idx: Integer; const NV: AnsiString);
+begin
+ Items[ Idx ] := NV + fNameDelim + LineValue[ Idx ];
+end;
+
+function TStrList.GetLineValue(Idx: Integer): AnsiString;
+var Q: PAnsiChar;
+begin
+ Q := ItemPtrs[ Idx ];
+ Q := StrScan( Q, fNameDelim );
+ if Q <> nil then
+ inc( Q );
+ Result := Q;
+end;
+
+procedure TStrList.SetLineValue(Idx: Integer; const Value: Ansistring);
+begin
+ Items[ Idx ] := LineName[ Idx ] + fNameDelim + Value;
+end;
+
+function TStrList.Join( const sep: AnsiString ): AnsiString;
+var
+ I, Len, Size: integer;
+ P: PAnsiChar;
+begin
+ Size := 0;
+
+ for I := 0 to Count - 1 do
+ Inc(Size, Integer( StrLen( ItemPtrs[I] ) ) + Length(Sep));
+
+ SetString(Result, nil, Size);
+
+ P := @ Result[ 1 ];
+ for I := 0 to Count - 1 do
+ begin
+ Len := StrLen( ItemPtrs[I] );
+ if (Len > 0) then
+ begin
+ System.Move( ItemPtrs[I]^, P^, Len);
+ Inc(P, Len);
+ end;
+ P := StrPCopy(P, Sep);
+ inc( P, Length( Sep ) ); // + by Korneev Ivan
+ end;
+end;
+
+{$IFDEF WIN_GDI}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TStrList.AppendToFile(const FileName: KOLString): Boolean;
+var F: HFile;
+ Buf: AnsiString;
+ L: Integer;
+begin
+ F := FileCreate( FileName, ofOpenWrite or ofOpenAlways );
+ Result := F <> INVALID_HANDLE_VALUE;
+ if Result then
+ begin
+ FileSeek( F, 0, spEnd );
+ Buf := Text;
+ L := Length( Buf );
+ FileWrite( F, Buf[ 1 ], L );
+ FileClose( F );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TStrList.LoadFromFile(const FileName: KOLString): Boolean;
+var Buf: AnsiString;
+ F: HFile;
+ Sz: Integer;
+begin
+ F := FileCreate( FileName, ofOpenRead or ofShareDenyWrite or ofOpenExisting );
+ Result := F <> INVALID_HANDLE_VALUE;
+ if Result then
+ begin
+ Sz := GetFileSize( F, nil );
+ SetString( Buf, nil, Sz );
+ FileRead( F, Buf[1], Sz );
+ FileClose( F );
+
+ SetText( Buf, False );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_STREAM}
+procedure TStrList.LoadFromStream(Stream: PStream; Append2List: boolean);
+asm
+ PUSH EAX
+ PUSH ECX
+ PUSH EBX
+ XCHG EAX, EDX
+ MOV EBX, EAX
+ CALL TStream.GetSize
+ PUSH EAX
+ MOV EAX, EBX
+ CALL TStream.GetPosition
+ POP ECX
+ SUB ECX, EAX
+ XOR EDX, EDX
+ PUSH EDX
+ MOV EAX, ESP
+ PUSH ECX
+ {$IFDEF _D2}
+ CALL _LStrFromPCharLen
+ {$ELSE}
+ {$IFDEF _D2009orHigher}
+ push 0
+ {$ENDIF}
+ CALL System.@LStrFromPCharLen
+ {$ENDIF}
+ POP ECX
+ POP EDX
+ XCHG EAX, EBX
+ PUSH EDX
+ CALL TStream.Read
+ POP EDX
+ POP EBX
+ POP ECX
+ POP EAX
+ PUSH EDX
+ CALL SetText
+ CALL RemoveStr
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure TStrList.LoadFromStream(Stream: PStream; Append2List: Boolean);
+var Buf: AnsiString;
+ Sz: Integer;
+begin
+ Sz := Stream.Size - Stream.Position;
+ SetString( Buf, nil, Sz );
+ Stream.Read( Buf[1], Sz );
+ SetText( Buf, Append2List );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TStrList.MergeFromFile(const FileName: KOLString);
+var TmpStream: PStream;
+begin
+ TmpStream := NewReadFileStream( FileName );
+ LoadFromStream( TmpStream, True );
+ TmpStream.Free;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TStrList.SaveToFile(const FileName: KOLString): Boolean;
+var F: HFile;
+ Buf: AnsiString;
+begin
+ F := FileCreate( FileName, ofOpenWrite or ofCreateAlways );
+ Result := F <> INVALID_HANDLE_VALUE;
+ if Result then
+ begin
+ Buf := Text;
+ FileWrite( F, Buf[ 1 ], Length( Buf ) );
+ SetEndOfFile( F ); // necessary! - V.K.
+ FileClose( F );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TStrList.SaveToStream(Stream: PStream);
+var S: Ansistring;
+ L: Integer;
+begin
+ S := GetTextStr;
+ L := Length( S );
+ if L <> 0 then
+ Stream.Write( S[1], L );
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TStrList.OptimizeForRead;
+begin
+ {$IFDEF TLIST_FAST}
+ if fList <> nil then
+ fList.OptimizeForRead;
+ {$ENDIF}
+end;
+
+{$ENDIF WIN_GDI}
+////////////////////////////////// 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;
+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
+ Dest^ := Src^;
+ if Src^ = #0 then break;
+ inc( Dest );
+ inc( Src );
+ dec( MaxLen );
+ if MaxLen = 0 then
+ Dest^ := Src^;
+ 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}
+
+{$IFDEF _D3orHigher}
+function WStrCmp_NoCase( W1, W2: PWideChar ): Integer;
+begin
+ Result := 0;
+ while (WUpperCase( '' + W1^ ) = WUpperCase( '' + W2^ )) do
+ begin
+ if W1^ = #0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ inc( W1 );
+ inc( W2 );
+ end;
+ Result := Integer(W1^) - Integer(W2^);
+end;
+{$ENDIF}
+
+{ TStrListEx }
+
+function NewStrListEx: PStrListEx;
+begin
+ new( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TStrListEx';
+ {$ENDIF}
+end;
+
+destructor TStrListEx.Destroy;
+var Obj: PList;
+begin
+ Obj := FObjects;
+ inherited;
+ Obj.Free;
+end;
+
+function TStrListEx.GetObjects(Idx: Integer): DWORD;
+begin
+ Result := 0;
+ if FObjects.fCount > Idx then
+ Result := DWORD( FObjects.Items[ Idx ] );
+end;
+
+function TStrListEx.GetObjectCount: Integer;
+begin
+ Result := FObjects.Count;
+end;
+
+procedure TStrListEx.SetObjects(Idx: Integer; const Value: DWORD);
+begin
+ ProvideObjCapacity( Idx + 1 );
+ FObjects.Items[ Idx ] := Pointer( Value );
+end;
+
+procedure TStrListEx.Init;
+begin
+ inherited;
+ FObjects := NewList;
+end;
+
+procedure SwapStrListExItems( const Sender: Pointer; const e1, e2: DWORD );
+begin
+ PStrListEx( Sender ).Swap( e1, e2 );
+end;
+
+procedure TStrListEx.AnsiSort(CaseSensitive: Boolean);
+begin
+ fCaseSensitiveSort := CaseSensitive;
+ fAnsiSort := TRUE;
+ if CaseSensitive then
+ SortData( @Self, fCount, @CompareAnsiStrListItems_Case, @SwapStrListExItems )
+ else
+ SortData( @Self, fCount, @CompareAnsiStrListItems, @SwapStrListExItems )
+end;
+
+procedure TStrListEx.Sort(CaseSensitive: Boolean);
+begin
+ fCaseSensitiveSort := CaseSensitive;
+ fAnsiSort := FALSE;
+ if CaseSensitive then
+ SortData( @Self, fCount, @CompareStrListItems_Case, @SwapStrListExItems )
+ else SortData( @Self, fCount, @CompareStrListItems_NoCase, @SwapStrListExItems );
+end;
+
+procedure TStrListEx.Move(CurIndex, NewIndex: integer);
+begin
+ // move string
+ fList.MoveItem( CurIndex, NewIndex );
+ // move object
+ if FObjects.fCount >= Min( CurIndex, NewIndex ) then
+ begin
+ ProvideObjCapacity( max( CurIndex, NewIndex ) + 1 );
+ FObjects.MoveItem( CurIndex, NewIndex );
+ end;
+end;
+
+procedure TStrListEx.Swap(Idx1, Idx2: Integer);
+begin
+ // swap strings
+ fList.Swap( Idx1, Idx2 );
+ // swap objects
+ if FObjects.fCount >= Min( Idx1, Idx2 ) then
+ begin
+ ProvideObjCapacity( max( Idx1, Idx2 ) + 1 );
+ FObjects.Swap( Idx1, Idx2 );
+ end;
+end;
+
+procedure TStrListEx.ProvideObjCapacity(NewCap: Integer);
+begin
+ if FObjects.FCount < NewCap then
+ begin
+ {$IFDEF TLIST_FAST}
+ while FObjects.FCount < NewCap do
+ FObjects.Add( nil );
+ {$ELSE}
+ FObjects.Capacity := NewCap;
+ ZeroMemory( @FObjects.{$IFDEF TLIST_FAST} Items {$ELSE} FItems {$ENDIF}[ FObjects.FCount ],
+ (FObjects.Capacity - FObjects.Count) * sizeof( Pointer ) );
+ FObjects.FCount := NewCap;
+ {$ENDIF}
+ end;
+end;
+
+procedure TStrListEx.AddStrings(Strings: PStrListEx);
+var I: Integer;
+begin
+ I := Count;
+ if Strings.FObjects.fCount > 0 then
+ ProvideObjCapacity( I );
+ inherited AddStrings( Strings );
+ if Strings.FObjects.fCount > 0 then
+ begin
+ {$IFDEF TLIST_FAST}
+ for I := 0 to Strings.FObjects.fCount-1 do
+ FObjects.Add( Strings.FObjects.Items[ I ] );
+ {$ELSE}
+ ProvideObjCapacity( I + Strings.FObjects.fCount );
+ System.Move( Strings.FObjects.fItems[ 0 ],
+ FObjects.FItems[ I ],
+ Sizeof( Pointer ) * Strings.FObjects.fCount );
+ {$ENDIF}
+ end;
+end;
+
+procedure TStrListEx.Assign(Strings: PStrListEx);
+begin
+ inherited Assign( Strings );
+ FObjects.Assign( Strings.FObjects );
+end;
+
+procedure TStrListEx.Clear;
+begin
+ inherited;
+ FObjects.Clear;
+end;
+
+procedure TStrListEx.Delete(Idx: integer);
+begin
+ inherited;
+ if FObjects.fCount > Idx then // mdw: '>=' -> '>'
+ FObjects.Delete( Idx );
+end;
+
+procedure TStrListEx.DeleteLast;
+var C: Integer;
+begin
+ C := fCount;
+ if C <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ inherited;
+ if FObjects.fCount >= C then FObjects.Delete( C );
+end;
+
+
+function TStrListEx.LastObj: DWORD;
+begin
+ if Count = 0 then
+ Result := 0
+ else
+ Result := Objects[ Count - 1 ];
+end;
+
+function TStrListEx.AddObject(const S: AnsiString; Obj: DWORD): Integer;
+begin
+ Result := Count;
+ InsertObject( Count, S, Obj );
+end;
+
+procedure TStrListEx.InsertObject(Before: Integer; const S: AnsiString; Obj: DWORD);
+begin
+ Insert( Before, S );
+ ProvideObjCapacity( Before );
+ FObjects.Insert( Before, Pointer( Obj ) );
+end;
+
+function TStrListEx.IndexOfObj( Obj: Pointer ): Integer;
+begin
+ Result := FObjects.IndexOf( Obj );
+end;
+
+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;
+
+procedure TStrListEx.OptimizeForRead;
+begin
+ {$IFDEF TLIST_FAST}
+ if fList <> nil then
+ fList.OptimizeForRead;
+ if FObjects <> nil then
+ FObjects.OptimizeForRead;
+ {$ENDIF}
+end;
+
+{$IFDEF _D3orHigher}
+function UTF8_2KOLWideString( const s: AnsiString ): KOLWideString;
+var Buffer: PWideChar;
+ L: Integer;
+begin
+ L := Length( s ) + 1;
+ GetMem( Buffer, L * 2 );
+ MultiByteToWideChar( CP_UTF8, 0, PAnsiChar( s ), L-1,
+ Buffer, L );
+ Result := Buffer;
+ FreeMem( Buffer );
+end;
+{$ENDIF _D3orHigher}
+
+{------------------------------------------------------------------------------)
+| |
+| T W S t r L i s t |
+| |
+(------------------------------------------------------------------------------}
+
+{$IFDEF WIN_GDI}
+{$IFNDEF _D2}
+
+function NewWStrList: PWStrList;
+begin
+ new( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TWStrList';
+ {$ENDIF}
+end;
+
+{ TWStrList }
+
+function TWStrList.Add(const W: KOLWideString): Integer;
+begin
+ Result := Count;
+ Insert( Result, W );
+end;
+
+procedure TWStrList.AddWStrings(WL: PWStrList);
+begin
+ Text := Text + WL.Text;
+end;
+
+function TWStrList.AppendToFile(const Filename: KOLString): Boolean;
+var Strm: PStream;
+begin
+ Strm := NewReadWriteFileStream( Filename );
+ Result := Strm.Handle <> INVALID_HANDLE_VALUE;
+ if Result then
+ begin
+ Strm.Position := Strm.Size;
+ SaveToStream( Strm );
+ end;
+ Strm.Free;
+end;
+
+procedure TWStrList.Assign(WL: PWStrList);
+begin
+ Text := WL.Text;
+end;
+
+procedure TWStrList.Clear;
+var I: Integer;
+ P: Pointer;
+begin
+ for I := 0 to Count-1 do
+ begin
+ P := fList.Items[ I ];
+ if P <> nil then
+ if not( (P >= fText) and (P <= fText + fTextBufSz) ) then
+ FreeMem( P );
+ end;
+ if fText <> nil then
+ FreeMem( fText );
+ fText := nil;
+ fTextBufSz := 0;
+ fList.Clear;
+end;
+
+procedure TWStrList.Delete(Idx: Integer);
+var P: Pointer;
+begin
+ P := fList.Items[ Idx ];
+ if P <> nil then
+ if not( (P >= fText) and (P <= fText + fTextBufSz) ) then
+ FreeMem( P );
+ fList.Delete( Idx );
+end;
+
+destructor TWStrList.Destroy;
+begin
+ Clear;
+ fList.Free;
+ inherited;
+end;
+
+function TWStrList.GetCount: Integer;
+begin
+ Result := fList.Count;
+end;
+
+function TWStrList.GetItems(Idx: Integer): KOLWideString;
+begin
+ Result := PWideChar( fList.Items[ Idx ] );
+end;
+
+function TWStrList.GetPtrs(Idx: Integer): PWideChar;
+begin
+ Result := fList.Items[ Idx ];
+end;
+
+function TWStrList.GetText: KOLWideString;
+const
+ EoL: Array[ 0..5 ] of AnsiChar = ( #13, #0, #10, #0, #0, #0 ); // KOL_ANSI
+var
+ L, I: Integer;
+ P, Dest: Pointer;
+begin
+ L := 0;
+ for I := 0 to Count-1 do
+ begin
+ P := fList.Items[ I ];
+ if P <> nil then
+ L := L + WStrLen( P ) + 2
+ else
+ L := L + 2;
+ end;
+ SetLength( Result, L );
+ Dest := PWideChar( Result );
+ for I := 0 to Count-1 do
+ begin
+ P := fList.Items[ I ];
+ if P <> nil then
+ begin
+ WStrCopy( Dest, P );
+ Dest := Pointer( Integer( Dest ) + WStrLen( P ) * 2 );
+ end;
+ WStrCopy( Dest, Pointer( @ EoL[ 0 ] ) );
+ Dest := Pointer( Integer( Dest ) + 4 );
+ end;
+end;
+
+procedure TWStrList.Init;
+begin
+ fList := NewList;
+ fNameDelim := WideChar( DefaultNameDelimiter );
+end;
+
+procedure TWStrList.Insert(Idx: Integer; const W: KOLWideString);
+var P: Pointer;
+begin
+ while Idx > Count do // by Misha Shar. a.k.a. kreit
+ fList.Add( nil );
+ GetMem( P, (Length( W ) + 1) * Sizeof(WideChar) );
+ fList.Insert( Idx, P );
+ WStrCopy( P, PWideChar( W ) );
+end;
+
+function TWStrList.LoadFromFile(const Filename: KOLString): Boolean;
+begin
+ Clear;
+ Result := MergeFromFile( Filename );
+end;
+
+procedure TWStrList.LoadFromStream(Strm: PStream; AppendToList: Boolean);
+begin
+ if not AppendToList then Clear;
+ MergeFromStream( Strm );
+end;
+
+const
+ BOM : WideChar = #$FEFF;
+
+function TWStrList.MergeFromFile(const Filename: KOLString): Boolean;
+var Strm: PStream;
+ DBOM: WideChar;
+begin
+ Strm := NewReadFileStream( Filename );
+ Result := Strm.Handle <> INVALID_HANDLE_VALUE;
+ if Result then
+ begin
+ Strm.Read(DBOM, SizeOf(DBOM));
+ if DBOM<>BOM then Strm.Position := 0;
+ MergeFromStream( Strm );
+ end;
+ Strm.Free;
+end;
+
+procedure TWStrList.MergeFromStream(Strm: PStream);
+var Buf: KOLWideString;
+ L: Integer;
+begin
+ L := Strm.Size - Strm.Position;
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( L mod 1 = 0, 'Wide strings streams must be of even length in bytes.' );
+ {$ENDIF KOL_ASSERTIONS}
+ if L = 0 then Exit;
+ SetLength( Buf, L div 2 );
+ Strm.Read( Buf[ 1 ], L );
+ Text := Text + Buf;
+end;
+
+procedure TWStrList.Move(IdxOld, IdxNew: Integer);
+begin
+ fList.MoveItem( IdxOld, IdxNew );
+end;
+
+procedure TWStrList.Put(Idx: integer; const Value: KOLWideString);
+begin
+ Delete( Idx );
+ Insert( Idx, Value );
+end;
+
+function TWStrList.SaveToFile(const Filename: KOLString): Boolean;
+var Strm: PStream;
+ DBOM: WideChar;
+begin
+ Strm := NewWriteFileStream( Filename );
+ Result := Strm.Handle <> INVALID_HANDLE_VALUE;
+ if Result then
+ begin
+ DBOM := BOM;
+ Strm.Write(DBOM, SizeOf(DBOM));
+ SaveToStream( Strm );
+ end;
+ Strm.Free;
+end;
+
+procedure TWStrList.SaveToStream(Strm: PStream);
+var Buf, Dest: PWideChar;
+ I, L, Sz: Integer;
+ P: Pointer;
+begin
+ Sz := 0;
+ for I := 0 to Count-1 do
+ begin
+ P := fList.Items[ I ];
+ if P <> nil then
+ Sz := Sz + WStrLen( P ) * 2 + 4
+ else
+ Sz := Sz + 4;
+ end;
+ GetMem( Buf, Sz );
+ Dest := Buf;
+ for I := 0 to Count-1 do
+ begin
+ P := fList.Items[ I ];
+ if P <> nil then
+ begin
+ L := WStrLen( P );
+ System.Move( P^, Dest^, L * 2 );
+ Inc( Dest, L );
+ end;
+ Dest^ := #13;
+ Inc( Dest );
+ Dest^ := #10;
+ Inc( Dest );
+ end;
+ Strm.Write( Buf^, Sz );
+ FreeMem( Buf );
+end;
+
+procedure TWStrList.SetItems(Idx: Integer; const Value: KOLWideString);
+var P: Pointer;
+begin
+ while Idx > Count-1 do
+ fList.Add( nil );
+ if WStrLen( ItemPtrs[ Idx ] ) > Length( Value ) then // fixed by kreit
+ WStrCopy( ItemPtrs[ Idx ], PWideChar( Value ) )
+ else
+ begin
+ P := fList.Items[ Idx ];
+ if P <> nil then
+ if not ((P >= fText) and (P <= fText + fTextBufSz)) then
+ FreeMem( P );
+ GetMem( P, (Length( Value ) + 1) * Sizeof(WideChar) );
+ fList.Items[ Idx ] := P;
+ WStrCopy( P, PWideChar( Value ) );
+ end;
+end;
+
+procedure TWStrList.SetText(const Value: KOLWideString);
+var L, N: Integer;
+ P: PWideChar;
+begin
+ Clear;
+ if Value = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ L := (Length( Value ) + 1) * Sizeof( WideChar );
+ GetMem( fText, L );
+ System.Move( Value[ 1 ], fText^, L );
+ fTextBufSz := Length( Value );
+ fText[ fTextBufSz ] := #0;
+ N := 0;
+ P := fText;
+ while Word( P^ ) <> 0 do
+ begin
+ if (Word( P^ ) = 13) then
+ begin
+ Inc( N );
+ PWord( P )^ := 0;
+ if Word( P[ 1 ] ) = 10 then
+ begin
+ Inc( P );
+ //PWord( P )^ := 0;
+ end;
+ end
+ else
+ if (Word( P^ ) = 10) and ((P = fText) or (Word( P[ -1 ] ) <> 0)) then
+ begin
+ Inc( N );
+ PWord( P )^ := 0;
+ end;
+ Inc( P );
+ end;
+ fList.Capacity := N;
+ P := fText;
+ while P < fText + fTextBufSz do
+ begin
+ fList.Add( P );
+ while Word( P^ ) <> 0 do Inc( P );
+ Inc( P );
+ if Word( P^ ) = 10 then Inc( P );
+ end;
+end;
+
+function CompareWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer;
+var WL: PWStrList;
+begin
+ WL := Sender;
+ Result := WStrCmp( WL.fList.Items[ Idx1 ], WL.fList.Items[ Idx2 ] );
+end;
+
+function CompareWStrListItems_UpperCase( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer;
+var WL: PWStrList;
+ L1, L2, tL1, tL2: Integer;
+begin
+ WL := Sender;
+ L1 := WStrLen( WL.fList.Items[ Idx1 ] );
+ L2 := WStrLen( WL.fList.Items[ Idx2 ] );
+ tL1 := Length( WL.fTmp1 );
+ if tL1 <= L1 then
+ SetLength( WL.fTmp1, L1 + 1 );
+ tL2 := Length( WL.fTmp2 );
+ if tL2 <= L2 then
+ SetLength( WL.fTmp2, L2 + 1 );
+ if L1 > 0 then
+ Move( WL.fList.Items[ Idx1 ]^, WL.fTmp1[ 1 ], (L1 + 1) * 2 )
+ else
+ WL.fTmp1[ 1 ] := #0;
+ if L2 > 0 then
+ Move( WL.fList.Items[ Idx2 ]^, WL.fTmp2[ 1 ], (L2 + 1) * 2 )
+ else
+ WL.fTmp2[ 1 ] := #0;
+ CharUpperBuffW( PWideChar( WL.fTmp1 ), L1 );
+ CharUpperBuffW( PWideChar( WL.fTmp2 ), L2 );
+ Result := WStrCmp( PWideChar( WL.fTmp1 ), PWideChar( WL.fTmp2 ) );
+end;
+
+procedure SwapWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD );
+var WL: PWStrList;
+begin
+ WL := Sender;
+ WL.Swap( Idx1, Idx2 );
+end;
+
+procedure TWStrList.Sort( CaseSensitive: Boolean );
+begin
+ if CaseSensitive then
+ SortData( @ Self, Count, @CompareWStrListItems, @SwapWStrListItems )
+ else
+ begin
+ SortData( @ Self, Count, @CompareWStrListItems_UpperCase, @SwapWStrListItems );
+ fTmp1 := '';
+ fTmp2 := '';
+ end;
+end;
+
+procedure TWStrList.Swap(Idx1, Idx2: Integer);
+begin
+ fList.Swap( Idx1, Idx2 );
+end;
+
+function TWStrList.IndexOf( const s: KOLWideString ): Integer;
+var i: Integer;
+ p: PWideChar;
+begin
+ if s = '' then
+ begin
+ for i := 0 to fList.fCount-1 do
+ begin
+ p := ItemPtrs[ i ];
+ if (p = nil) or
+ (p^ = #0) then
+ begin
+ Result := i; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end
+ else
+ begin
+ for i := 0 to Count-1 do
+ begin
+ p := ItemPtrs[ i ];
+ if (p <> nil) and
+ (WStrCmp( PWideChar( s ), p ) = 0) then
+ begin
+ Result := i; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end;
+ Result := -1;
+end;
+
+function TWStrList.IndexOf_NoCase( const s: KOLWideString ): Integer;
+var i: Integer;
+ p: PWideChar;
+begin
+ if s = '' then
+ begin
+ for i := 0 to fList.fCount-1 do
+ begin
+ p := ItemPtrs[ i ];
+ if (p = nil) or
+ (p^ = #0) then
+ begin
+ Result := i; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end
+ else
+ begin
+ for i := 0 to Count-1 do
+ begin
+ p := ItemPtrs[ i ];
+ if (p <> nil) and
+ (WStrCmp_NoCase( PWideChar( s ), p ) = 0) then
+ begin
+ Result := i; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end;
+ Result := -1;
+end;
+
+function TWStrList.Last: KOLWideString;
+begin
+ if Count <= 0 then Result := ''
+ else Result := Items[ Count-1 ];
+end;
+
+function NewWStrListEx: PWStrListEx;
+begin
+ new( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TWStrListEx';
+ {$ENDIF}
+end;
+
+function TWStrList.GetLineName(Idx: Integer): KOLWideString;
+var s: KOLWideString;
+ Q: PWideChar;
+begin
+ s := ItemPtrs[ Idx ];
+ Q := WStrScan( PWideChar(s), fNameDelim );
+ Q^ := #0;
+ Result := PWideChar(s);
+end;
+
+function TWStrList.GetLineValue(Idx: Integer): KOLWideString;
+var Q: PWideChar;
+begin
+ Q := ItemPtrs[ Idx ];
+ Q := WStrScan( Q, fNameDelim );
+ if Q <> nil then
+ inc( Q );
+ Result := Q;
+end;
+
+procedure TWStrList.SetLineName(Idx: Integer; const NV: KOLWideString);
+var del: KOLWideString;
+begin
+ del := fNameDelim;
+ Items[ Idx ] := NV + del + LineValue[ Idx ];
+end;
+
+procedure TWStrList.SetLineValue(Idx: Integer; const Value: KOLWideString);
+var del: KOLWideString;
+begin
+ del := fNameDelim;
+ Items[ Idx ] := LineName[ Idx ] + del + Value;
+end;
+
+procedure TWStrList.OptimizeForRead;
+begin
+ {$IFDEF TLIST_FAST}
+ if fList <> nil then
+ fList.OptimizeForRead;
+ {$ENDIF}
+end;
+
+function TWStrList.IndexOfName(AName: KOLWideString): Integer;
+var i: Integer;
+ L: Integer;
+ fCount: integer;
+begin
+ Result:=-1;
+ L := Length( AName );
+ if L > 0 then
+ begin
+ AName := WLowerCase( AName ) + fNameDelim;
+ Inc( L );
+ fCount := GetCount - 1;
+ for i := 0 to fCount do
+ begin
+ if _WStrLComp( PWideChar( WLowerCase( ItemPtrs[ i ] ) ), PWideChar( AName ), L ) = 0 then
+ begin
+ Result:=i; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end;
+end;
+
+procedure TWStrList.SetValue(const AName, Value: KOLWideString);
+var
+ I: Integer;
+begin
+ I := IndexOfName(AName);
+ if i=-1
+ then Add( AName + fNameDelim + Value )
+ else Items[i] := AName + fNameDelim + Value;
+end;
+
+function TWStrList.GetValue(const AName: KOLWideString): KOLWideString;
+var
+ i: Integer;
+begin
+ I := IndexOfName(AName);
+ if I >= 0
+ then Result := Copy(Items[i], Length(AName) + 2, Length(Items[i])-Length(AName)-1)
+ else Result := '';
+end;
+
+{ TWStrListEx }
+
+function TWStrListEx.AddObject(const S: KOLWideString; Obj: DWORD): Integer;
+begin
+ Result := Count;
+ InsertObject( Count, S, Obj );
+end;
+
+procedure TWStrListEx.AddWStrings(WL: PWStrListEx);
+var I: Integer;
+begin
+ {$IFDEF TLIST_FAST}
+ {$ELSE}
+ I := Count;
+ {$ENDIF}
+ if WL.FObjects.Count > 0 then
+ ProvideObjectsCapacity( Count );
+ inherited AddWStrings( WL );
+ if WL.FObjects.Count > 0 then
+ begin
+ {$IFDEF TLIST_FAST}
+ for I := 0 to WL.FObjects.Count-1 do
+ FObjects.Add( WL.fObjects.Items[ I ] );
+ {$ELSE}
+ ProvideObjectsCapacity( I + WL.FObjects.Count );
+ System.Move( WL.FObjects.FItems[ 0 ],
+ FObjects.FItems[ I ],
+ Sizeof( Pointer ) * WL.FObjects.Count );
+ {$ENDIF}
+ end;
+end;
+
+procedure TWStrListEx.Assign(WL: PWStrListEx);
+begin
+ inherited Assign( WL );
+ FObjects.Assign( WL.FObjects );
+end;
+
+procedure TWStrListEx.Clear;
+begin
+ inherited Clear;
+ FObjects.Clear;
+end;
+
+procedure TWStrListEx.Delete(Idx: Integer);
+begin
+ inherited Delete( Idx );
+ if FObjects.FCount >= Idx then
+ FObjects.Delete( Idx );
+end;
+
+destructor TWStrListEx.Destroy;
+begin
+ fObjects.Free;
+ inherited;
+end;
+
+function TWStrListEx.GetObjects(Idx: Integer): DWORD;
+begin
+ Result := DWORD( fObjects.Items[ Idx ] );
+end;
+
+function TWStrListEx.IndexOfObj(Obj: Pointer): Integer;
+begin
+ Result := FObjects.IndexOf( Obj );
+end;
+
+procedure TWStrListEx.Init;
+begin
+ inherited;
+ fObjects := NewList;
+end;
+
+procedure TWStrListEx.InsertObject(Before: Integer; const S: KOLWideString;
+ Obj: DWORD);
+begin
+ Insert( Before, S );
+ FObjects.Insert( Before, Pointer( Obj ) );
+end;
+
+procedure TWStrListEx.Move(IdxOld, IdxNew: Integer);
+begin
+ fList.MoveItem( IdxOld, IdxNew );
+ if FObjects.FCount >= Min( IdxOld, IdxNew ) then
+ begin
+ ProvideObjectsCapacity( Max( IdxOld, IdxNew ) + 1 );
+ FObjects.MoveItem( IdxOld, IdxNew );
+ end;
+end;
+
+procedure SwapWStrListExItems( const Sender: Pointer; const Idx1, Idx2: DWORD );
+var WL: PWStrListEx;
+begin
+ WL := Sender;
+ WL.Swap( Idx1, Idx2 );
+end;
+
+procedure TWStrListEx.Sort(CaseSensitive: Boolean);
+begin
+ if CaseSensitive then
+ SortData( @ Self, Count, @CompareWStrListItems, @SwapWStrListExItems )
+ else
+ begin
+ SortData( @ Self, Count, @CompareWStrListItems_UpperCase, @SwapWStrListExItems );
+ fTmp1 := '';
+ fTmp2 := '';
+ end;
+end;
+
+procedure TWStrListEx.Swap(Idx1, Idx2: Integer);
+begin
+ inherited Swap( Idx1, Idx2 );
+ if FObjects.fCount >= Min( Idx1, Idx2 ) then
+ begin
+ ProvideObjectsCapacity( max( Idx1, Idx2 ) + 1 );
+ FObjects.Swap( Idx1, Idx2 );
+ end;
+end;
+
+procedure TWStrListEx.OptimizeForRead;
+begin
+ {$IFDEF TLIST_FAST}
+ if fList <> nil then
+ fList.OptimizeForRead;
+ if FObjects <> nil then
+ FObjects.OptimizeForRead;
+ {$ENDIF}
+end;
+
+procedure TWStrListEx.ProvideObjectsCapacity(NewCap: Integer);
+begin
+ if fObjects.Capacity >= NewCap then Exit;
+ fObjects.Capacity := NewCap;
+ {$IFDEF TLIST_FAST}
+ {$ELSE}
+ ZeroMemory( @FObjects.FItems[ FObjects.Count ],
+ (FObjects.Capacity - FObjects.Count) * Sizeof( Pointer ) );
+ FObjects.FCount := NewCap;
+ {$ENDIF}
+end;
+
+procedure TWStrListEx.SetObjects(Idx: Integer; const Value: DWORD);
+begin
+ ProvideObjectsCapacity( Idx + 1 );
+ fObjects.Items[ Idx ] := Pointer( Value );
+end;
+
+{$ENDIF}
+{$ENDIF WIN_GDI}
+
+function NewKOLStrList: PKOLStrList;
+begin
+ new( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TKOLStrList';
+ {$ENDIF}
+end;
+
+function NewKOLStrListEx: PKOLStrListEx;
+begin
+ new( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TKOLStrListEx';
+ {$ENDIF}
+end;
+
+//////////////////////////////////////////////////////////////////////////
+// S O R T I N G
+//////////////////////////////////////////////////////////////////////////
+
+{ -- qsort -- }
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure SortData( const Data: Pointer; const uNElem: Dword;
+ const CompareFun: TCompareEvent;
+ const SwapProc: TSwapEvent );
+{ uNElem - number of elements to sort }
+
+ function Compare( const e1, e2 : DWord ) : Integer;
+ begin
+ Result := CompareFun( Data, e1 - 1, e2 - 1 );
+ end;
+
+ procedure Swap( const e1, e2 : DWord );
+ begin
+ SwapProc( Data, e1 - 1, e2 - 1 );
+ end;
+
+ procedure qSortHelp(pivotP: Dword; nElem: Dword);
+ label
+ TailRecursion,
+ qBreak;
+ var
+ leftP, rightP, pivotEnd, pivotTemp, leftTemp: Dword;
+ lNum: Dword;
+ retval: integer;
+ begin
+ TailRecursion:
+ if (nElem <= 2) then
+ begin
+ if (nElem = 2) then
+ begin
+ rightP := pivotP +1;
+ retval := Compare(pivotP,rightP);
+ if (retval > 0) then Swap(pivotP,rightP);
+ end;
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ rightP := (nElem -1) + pivotP;
+ leftP := (nElem shr 1) + pivotP;
+ { sort pivot, left, and right elements for "median of 3" }
+ retval := Compare(leftP,rightP);
+ if (retval > 0) then Swap(leftP, rightP);
+ retval := Compare(leftP,pivotP);
+
+ if (retval > 0) then
+ Swap(leftP, pivotP)
+ else
+ begin
+ retval := Compare(pivotP,rightP);
+ if retval > 0 then Swap(pivotP, rightP);
+ end;
+ if (nElem = 3) then
+ begin
+ Swap(pivotP, leftP); exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ { now for the classic Horae algorithm }
+ pivotEnd := pivotP + 1;
+ leftP := pivotEnd;
+ repeat
+
+ retval := Compare(leftP, pivotP);
+ while (retval <= 0) do
+ begin
+
+ if (retval = 0) then
+ begin
+ Swap(leftP, pivotEnd);
+ Inc(pivotEnd);
+ end;
+ if (leftP < rightP) then
+ Inc(leftP)
+ else
+ goto qBreak;
+ retval := Compare(leftP, pivotP);
+ end; {while}
+ while (leftP < rightP) do
+ begin
+ retval := Compare(pivotP, rightP);
+ if (retval < 0) then
+ Dec(rightP)
+
+ else
+ begin
+ Swap(leftP, rightP);
+ if (retval <> 0) then
+ begin
+ Inc(leftP);
+ Dec(rightP);
+ end;
+ break;
+ end;
+ end; {while}
+
+ until (leftP >= rightP);
+ qBreak:
+ retval := Compare(leftP,pivotP);
+ if (retval <= 0) then Inc(leftP);
+
+ leftTemp := leftP -1;
+ pivotTemp := pivotP;
+ while ((pivotTemp < pivotEnd) and (leftTemp >= pivotEnd)) do
+ begin
+ Swap(pivotTemp, leftTemp);
+ Inc(pivotTemp);
+ Dec(leftTemp);
+ end; {while}
+ lNum := (leftP - pivotEnd);
+ nElem := ((nElem + pivotP) -leftP);
+
+ if (nElem < lNum) then
+ begin
+ qSortHelp(leftP, nElem);
+ nElem := lNum;
+ end
+ else
+ begin
+ qSortHelp(pivotP, lNum);
+ pivotP := leftP;
+ end;
+ goto TailRecursion;
+ end; {qSortHelp }
+
+begin
+ if (uNElem < 2) then exit; { nothing to sort } {>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ qSortHelp(1, uNElem);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF _D3orHigher}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+procedure SortArray( const Data: Pointer; const uNElem: Dword;
+ const CompareFun: TCompareArrayEvent );
+{ uNElem - number of elements to sort }
+type TDWORDArray = array[0..0] of Integer;
+ PDWORDArray = ^TDWORDArray;
+var DataArray: PDWORDArray;
+
+ procedure SwapIdx( const e1, e2 : DWord );
+ begin
+ Swap( DataArray[e1], DataArray[e2] );
+ end;
+
+ procedure qSortArrayHelp(pivotP: Dword; nElem: Dword);
+ label
+ TailRecursion,
+ qBreak;
+ var
+ leftP, rightP, pivotEnd, pivotTemp, leftTemp: Dword;
+ lNum: Dword;
+ retval: integer;
+ begin
+ TailRecursion:
+ if (nElem <= 2) then
+ begin
+ if (nElem = 2) then
+ begin
+ rightP := pivotP +1;
+ retval := CompareFun(DataArray[pivotP],DataArray[rightP]);
+ if (retval > 0) then SwapIdx(pivotP,rightP);
+ end;
+ exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ rightP := (nElem -1) + pivotP;
+ leftP := (nElem shr 1) + pivotP;
+ { sort pivot, left, and right elements for "median of 3" }
+ retval := CompareFun(DataArray[leftP],DataArray[rightP]);
+ if (retval > 0) then SwapIdx(leftP, rightP);
+ retval := CompareFun(DataArray[leftP],DataArray[pivotP]);
+
+ if (retval > 0) then
+ SwapIdx(leftP, pivotP)
+ else
+ begin
+ retval := CompareFun(DataArray[pivotP],DataArray[rightP]);
+ if retval > 0 then SwapIdx(pivotP, rightP);
+ end;
+ if (nElem = 3) then
+ begin
+ SwapIdx(pivotP, leftP); exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ { now for the classic Horae algorithm }
+ pivotEnd := pivotP + 1;
+ leftP := pivotEnd;
+ repeat
+
+ retval := CompareFun(DataArray[leftP], DataArray[pivotP]);
+ while (retval <= 0) do
+ begin
+
+ if (retval = 0) then
+ begin
+ SwapIdx(leftP, pivotEnd);
+ Inc(pivotEnd);
+ end;
+ if (leftP < rightP) then
+ Inc(leftP)
+ else
+ goto qBreak;
+ retval := CompareFun(DataArray[leftP], DataArray[pivotP]);
+ end; {while}
+ while (leftP < rightP) do
+ begin
+ retval := CompareFun(DataArray[pivotP], DataArray[rightP]);
+ if (retval < 0) then
+ Dec(rightP)
+
+ else
+ begin
+ SwapIdx(leftP, rightP);
+ if (retval <> 0) then
+ begin
+ Inc(leftP);
+ Dec(rightP);
+ end;
+ break;
+ end;
+ end; {while}
+
+ until (leftP >= rightP);
+ qBreak:
+ retval := CompareFun( DataArray[leftP], DataArray[pivotP] );
+ if (retval <= 0) then Inc(leftP);
+
+ leftTemp := leftP -1;
+ pivotTemp := pivotP;
+ while ((pivotTemp < pivotEnd) and (leftTemp >= pivotEnd)) do
+ begin
+ SwapIdx(pivotTemp, leftTemp);
+ Inc(pivotTemp);
+ Dec(leftTemp);
+ end; {while}
+ lNum := (leftP - pivotEnd);
+ nElem := ((nElem + pivotP) -leftP);
+
+ if (nElem < lNum) then
+ begin
+ qSortArrayHelp(leftP, nElem);
+ nElem := lNum;
+ end
+ else
+ begin
+ qSortArrayHelp(pivotP, lNum);
+ pivotP := leftP;
+ end;
+ goto TailRecursion;
+ end; {qSortHelp }
+
+begin
+ DataArray := Pointer( Integer( Data ) - Sizeof( DWORD ) );
+ if (uNElem < 2) then exit; { nothing to sort } {>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ qSortArrayHelp(1, uNElem);
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF _D3orHigher}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
+var I1, I2 : Integer;
+begin
+ I1 := PInteger( DWORD( Sender ) + e1 * Sizeof( Integer ) )^;
+ I2 := PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;
+ Result := 0;
+ if I1 < I2 then Result := -1
+ else
+ if I1 > I2 then Result := 1;
+end;
+{$ENDIF PAS_VERSION}
+
+function Compare2Integers( e1, e2: Integer ) : Integer;
+begin
+ Result := e1-e2;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
+var I1, I2 : DWord;
+begin
+ I1 := PDWORD( DWORD( Sender ) + e1 * Sizeof( Integer ) )^;
+ I2 := PDWORD( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;
+ Result := 0;
+ if I1 < I2 then Result := -1
+ else
+ if I1 > I2 then Result := 1;
+end;
+{$ENDIF PAS_VERSION}
+
+function Compare2Dwords( e1, e2 : DWORD ) : Integer; forward;
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+function Compare2Dwords( e1, e2 : DWORD ) : Integer;
+begin
+ if e1 < e2 then
+ Result := -1
+ else
+ if e1 > e2 then
+ Result := 1
+ else
+ Result := 0;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD );
+var Tmp : Integer;
+begin
+ Tmp := PInteger( DWORD( Sender ) + e1 * SizeOf( Integer ) )^;
+ PInteger( DWORD( Sender ) + e1 * Sizeof( Integer ) )^ :=
+ PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;
+ PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^ := Tmp;
+end;
+{$ENDIF PAS_VERSION}
+
+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 );
+begin
+ PList( L ).Swap( e1, e2 );
+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;
+{$IFDEF WIN_GDI}
+
+{ -- status bar implementation -- }
+
+function _NewStatusbar( AParent: PControl ): PControl; forward;
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function _NewStatusbar( AParent: PControl ): PControl;
+var Style: DWORD;
+begin
+ Style := WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or 3 or WS_VISIBLE;
+ if {$IFDEF USE_FLAGS} G3_SizeGrip in AParent.fFlagsG3
+ {$ELSE} AParent.fSizeGrip {$ENDIF} then
+ Style := (Style or SBARS_SIZEGRIP) and not 3;
+ Result := _NewCommonControl( AParent, STATUSCLASSNAME,
+ Style, FALSE,
+ {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS )
+ {$ELSE} nil {$ENDIF} );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TControl:StatusBar';
+ {$ENDIF}
+ with Result.fBoundsRect do
+ begin
+ Left := 0;
+ Right := 0;
+ Top := 0;
+ Bottom := 0;
+ end;
+ Result.fAlign := caBottom;
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG4, G4_NotUseAlign );
+ {$ELSE} Result.fNotUseAlign := True; {$ENDIF}
+ {$IFDEF TEST_VERSION}
+ Result.fTag := DWORD( PAnsiChar( 'Status bar' ) );
+ {$ENDIF}
+ InitCommonControlSizeNotify( Result );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetStatusText(Index: Integer; const Value: KOLString);
+var ch: Integer;
+ R : TRect;
+ N, I, L, W : Integer;
+ WidthsBuf: array[ 0..254 ] of Integer;
+ Val: Integer;
+begin
+ if fStatusCtl = nil then
+ begin
+ ch := GetClientHeight;
+ fStatusCtl := _NewStatusBar( @Self );
+ fStatusCtl.Perform( SB_SIMPLE, Integer( LongBool( Index = 255 ) ), 0 );
+ GetWindowRect( {fStatusWnd}fStatusCtl.fHandle, R );
+ fClientBottom := R.Bottom - R.Top;
+ SetClientHeight( ch );
+ fStatusCtl.Perform( WM_SIZE, 0, 0 );
+ end;
+ if Index < 255 then
+ begin
+ N := fStatusCtl.Perform( SB_GETPARTS, 0, 0 );
+ if N <= Index then
+ begin
+ W := Width;
+ L := W div (Index + 1);
+ W := L;
+ for I := 0 to Index - 1 do
+ begin
+ WidthsBuf[ I ] := W;
+ Inc( W, L );
+ end;
+ WidthsBuf[ Index ] := -1;
+ fStatusCtl.Perform( SB_SETPARTS, Index + 1, Integer( @WidthsBuf[ 0 ] ) );
+ end;
+ fStatusCtl.Perform( SB_SIMPLE, 0, 0 );
+ end;
+ Val := 0;
+ if Value <> '' then
+ Val := Integer( @ Value[1] );
+ fStatusCtl.Perform(
+ {$IFDEF UNICODE_CTRLS} SB_SETTEXTW {$ELSE} SB_SETTEXT {$ENDIF}, Index, Val );
+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;
+begin
+ Result := '';
+ if fStatusCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Msg := SB_GETTEXTLENGTH;
+ I := Index;
+ if Index = 255 then
+ begin
+ Msg := WM_GETTEXTLENGTH;
+ I := 0;
+ end;
+ L := fStatusCtl.Perform( Msg, I, 0 ) and $FFFF;
+ if L > 0 then
+ begin
+ SetLength( Result, L );
+ Msg := {$IFDEF UNICODE_CTRLS} SB_GETTEXTW {$ELSE} SB_GETTEXT {$ENDIF};
+ if Index = 255 then
+ Msg := WM_GETTEXT;
+ fStatusCtl.Perform( Msg, I, Integer( @ Result[1] ) );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.RemoveStatus;
+var ch: Integer;
+begin
+ if fStatusCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ ch := ClientHeight;
+ fStatusCtl.Free;
+ fStatusCtl := nil;
+ fClientBottom := 0;
+ ClientHeight := ch;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.StatusPanelCount: Integer;
+begin
+ Result := 0;
+ if fStatusCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := fStatusCtl.Perform( SB_GETPARTS, 0, 0 );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetStatusPanelX(Idx: Integer): Integer;
+var Buf: array[0..254] of Integer;
+ N : Integer;
+begin
+ Result := 0;
+ if fStatusCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ N := fStatusCtl.Perform( SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) );
+ if N <= Idx then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := Buf[ Idx ];
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetStatusPanelX(Idx: Integer; const Value: Integer);
+var Buf: array[0..254] of Integer;
+ N : Integer;
+begin
+ if fStatusCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ N := fStatusCtl.Perform( SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) );
+ if N <= Idx then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Buf[ Idx ] := Value;
+ fStatusCtl.Perform( SB_SETPARTS, N, Integer( @Buf[ 0 ] ) );
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.SetColor1(const Value: TColor);
+begin
+ DF.fColor1 := Value;
+ Invalidate;
+end;
+
+procedure TControl.SetColor2(const Value: TColor);
+begin
+ DF.fColor2 := Value;
+ Invalidate;
+end;
+
+procedure TControl.SetGradientLayout(const Value: TGradientLayout);
+begin
+ DF.fGradientLayout := Value;
+ Invalidate;
+end;
+
+procedure TControl.SetGradientStyle(const Value: TGradientStyle);
+begin
+ DF.fGradientStyle := Value;
+ Invalidate;
+end;
+
+{ -- Image List -- }
+
+{$IFDEF USE_CONSTRUCTORS}
+function NewImageList( AOwner: PControl ): PImageList;
+begin
+ new( Result, CreateImageList( AOwner ) );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TImageList';
+ {$ENDIF}
+end;
+{$ELSE not_USE_CONSTRUCTORS}
+function NewImageList( AOwner: PControl ): PImageList;
+begin
+ {*************} DoInitCommonControls( ICC_WIN95_CLASSES );
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TImageList';
+ {$ENDIF}
+ Result.FAllocBy := 1;
+ Result.FMasked := True;
+ Result.fBkColor := clNone;
+ //ImageList_SetBkColor( Result.FHandle, CLR_NONE );
+ Result.FImgWidth := 32;
+ Result.FImgHeight := 32;
+ Result.FColors := ilcDefault;
+
+ if AOwner = nil then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result.fNext := PImageList( AOwner.fImageList );
+ if AOwner.fImageList <> nil then
+ PImageList( AOwner.fImageList ).fPrev := Result;
+ Result.FControl := AOwner;
+ {$IFDEF USE_AUTOFREE4CONTROLS}
+ AOwner.Add2AutoFree( Result );
+ {$ENDIF}
+ AOwner.fImageList := Result;
+end;
+{$ENDIF USE_CONSTRUCTORS}
+
+function ImageList_Create; stdcall; external cctrl name 'ImageList_Create';
+function ImageList_Destroy; external cctrl name 'ImageList_Destroy';
+function ImageList_GetImageCount; external cctrl name 'ImageList_GetImageCount';
+function ImageList_SetImageCount; external cctrl name 'ImageList_SetImageCount';
+function ImageList_Add; external cctrl name 'ImageList_Add';
+function ImageList_ReplaceIcon; external cctrl name 'ImageList_ReplaceIcon';
+function ImageList_SetBkColor; external cctrl name 'ImageList_SetBkColor';
+function ImageList_GetBkColor; external cctrl name 'ImageList_GetBkColor';
+function ImageList_SetOverlayImage; external cctrl name 'ImageList_SetOverlayImage';
+function ImageList_Draw; external cctrl name 'ImageList_Draw';
+function ImageList_Replace; external cctrl name 'ImageList_Replace';
+function ImageList_AddMasked; external cctrl name 'ImageList_AddMasked';
+function ImageList_DrawEx; external cctrl name 'ImageList_DrawEx';
+function ImageList_Remove; external cctrl name 'ImageList_Remove';
+function ImageList_GetIcon; external cctrl name 'ImageList_GetIcon';
+{$IFDEF UNICODE_CTRLS}
+function ImageList_LoadImage; external cctrl name 'ImageList_LoadImageW';
+{$ELSE}
+function ImageList_LoadImage; external cctrl name 'ImageList_LoadImageA';
+{$ENDIF}
+function ImageList_BeginDrag; external cctrl name 'ImageList_BeginDrag';
+function ImageList_EndDrag; external cctrl name 'ImageList_EndDrag';
+function ImageList_DragEnter; external cctrl name 'ImageList_DragEnter';
+function ImageList_DragLeave; external cctrl name 'ImageList_DragLeave';
+function ImageList_DragMove; external cctrl name 'ImageList_DragMove';
+function ImageList_SetDragCursorImage; external cctrl name 'ImageList_SetDragCursorImage';
+function ImageList_DragShowNolock; external cctrl name 'ImageList_DragShowNolock';
+function ImageList_GetDragImage; external cctrl name 'ImageList_GetDragImage';
+function ImageList_GetIconSize; external cctrl name 'ImageList_GetIconSize';
+function ImageList_SetIconSize; external cctrl name 'ImageList_SetIconSize';
+function ImageList_GetImageInfo; external cctrl name 'ImageList_GetImageInfo';
+function ImageList_Merge; external cctrl name 'ImageList_Merge';
+
+function ImageList_AddIcon(ImageList: HImageList; Icon: HIcon): Integer;
+begin
+ Result := ImageList_ReplaceIcon(ImageList, -1, Icon);
+end;
+
+function Index2OverlayMask(Index: Integer): Integer;
+begin
+ Result := Index shl 8;
+end;
+
+{ macros }
+procedure ImageList_RemoveAll(ImageList: HImageList); stdcall;
+begin
+ ImageList_Remove(ImageList, -1);
+end;
+
+function ImageList_ExtractIcon(Instance: THandle; ImageList: HImageList;
+ Image: Integer): HIcon; stdcall;
+begin
+ Result := ImageList_GetIcon(ImageList, Image, 0);
+end;
+
+function ImageList_LoadBitmap(Instance: THandle; Bmp: PKOLChar;
+ CX, Grow: Integer; Mask: TColorRef): HImageList; stdcall;
+begin
+ Result := ImageList_LoadImage(Instance, Bmp, CX, Grow, Mask, IMAGE_BITMAP, 0);
+end;
+
+procedure FreeBmp( Bmp: HBitmap );
+begin
+ DeleteObject( Bmp );
+end;
+
+function LoadBmp( Instance: Integer; Rsrc: PKOLChar; MasterObj: PObj ): HBitmap;
+{$IFDEF LOAD_RLE_BMP_RSRCES}
+var B: PBitmap;
+ R: PStream;
+{$ENDIF}
+begin
+ {$IFDEF LOAD_RLE_BMP_RSRCES}
+ R := NewMemoryStream;
+ Resource2Stream( R, hInstance, Rsrc, RT_BITMAP );
+ B := NewBitmap( 0, 0 );
+ R.Position := 0;
+ B.LoadFromStreamEx( R );
+ R.Free;
+ //B.SaveToFile( GetStartDir + 'test_loadbmp.bmp' );
+ Result := B.ReleaseHandle;
+ B.Free;
+ {$ELSE}
+ Result := LoadBitmap( Instance, Rsrc );
+ {$ENDIF}
+ MasterObj.Add2AutoFreeEx( TObjectMethod( MakeMethod( Pointer( Result ), @ FreeBmp ) ) );
+end;
+
+function LoadBmp32( Instance: Integer; Rsrc: PKOLChar; MasterObj: PObj ): HBitmap;
+var B: PBitmap;
+begin
+ B := NewBitmap( 0, 0 );
+ B.Handle := LoadBmp( Instance, Rsrc, MasterObj );
+ B.PixelFormat := pf32bit;
+ Result := B.ReleaseHandle;
+ B.Free;
+end;
+
+{ TImageList }
+
+function TImageList.Add(Bmp, Msk: HBitmap): Integer;
+begin
+ Result := -1;
+ if not HandleNeeded then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := ImageList_Add( FHandle, Bmp, Msk );
+end;
+
+function TImageList.AddIcon(Ico: HIcon): Integer;
+{var Bmp : HBitmap;
+ DC : HDC;}
+begin
+ Result := -1;
+ if ImgWidth = 0 then
+ ImgWidth := 32;
+ if ImgHeight = 0 then
+ ImgHeight := 32;
+ if not HandleNeeded then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := ImageList_AddIcon( fHandle, Ico );
+end;
+
+function TImageList.AddMasked(Bmp: HBitmap; Color: TColor): Integer;
+{$IFDEF TEST_IL}
+var B: PBitmap;
+{$ENDIF}
+begin
+ Result := -1;
+ if not HandleNeeded then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF TEST_IL}
+ B := NewBitmap( 0, 0 );
+ B.Handle := Bmp;
+ B.PixelFormat := pf32bit;
+ B.SaveToFile( GetStartDir + 'test_Add_masked1.bmp' );
+ Bmp := B.ReleaseHandle;
+ B.Free;
+ {$ENDIF}
+ Result := ImageList_AddMasked( FHandle, Bmp, Color2RGB( Color ) );
+ {$IFDEF TEST_IL}
+ B := NewBitmap( 0, 0 );
+ B.Handle := GetBitmap;
+ B.SaveToFile( GetStartDir + 'test_Add_masked2.bmp' );
+ B.ReleaseHandle;
+ B.Free;
+ B := NewBitmap( 0, 0 );
+ B.Handle := GetMask;
+ B.SaveToFile( GetStartDir + 'test_Add_masked3.bmp' );
+ B.ReleaseHandle;
+ B.Free;
+ {$ENDIF}
+end;
+
+procedure TImageList.Clear;
+begin
+ Handle := 0;
+end;
+
+procedure TImageList.Delete(Idx: Integer);
+begin
+ if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ ImageList_Remove( FHandle, Idx );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TImageList.Destroy;
+begin
+ Clear;
+ if fNext <> nil then
+ fNext.fPrev := fPrev;
+ if fPrev <> nil then
+ fPrev.fNext := fNext;
+ if fControl <> nil then
+ begin
+ if PControl( fControl ).fImageList = @Self then
+ PControl( fControl ).fImageList := fNext;
+ {$IFDEF USE_AUTOFREE4CONTROLS}
+ PControl(fControl).RemoveFromAutoFree( @ Self );
+ {$ENDIF}
+ end;
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TImageList.Draw(Idx: Integer; DC: HDC; X, Y: Integer);
+begin
+ if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ ImageList_Draw( FHandle, Idx, DC, X, Y, GetDrawStyle );
+end;
+
+function TImageList.ExtractIcon(Idx: Integer): HIcon;
+begin
+ Result := ImageList_ExtractIcon( 0, FHandle, Idx );
+end;
+
+function TImageList.ExtractIconEx(Idx: Integer): HIcon;
+begin
+ Result := ImageList_GetIcon( FHandle, Idx, GetDrawStyle );
+end;
+
+function TImageList.GetBitmap: HBitmap;
+var II : TImageInfo;
+begin
+ Result := 0;
+ if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if ImageList_GetImageInfo( FHandle, 0, II ) then
+ Result := II.hbmImage;
+end;
+
+function TImageList.GetBkColor: TColor;
+begin
+ Result := fBkColor;
+ if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := ImageList_GetBkColor( FHandle );
+end;
+
+function TImageList.GetCount: Integer;
+begin
+ Result := 0;
+ if FHandle <> 0 then
+ Result := ImageList_GetImageCount( FHandle );
+end;
+
+function TImageList.GetDrawStyle: DWord;
+begin
+ Result := 0;
+ if dsBlend25 in DrawingStyle then
+ Result := Result or ILD_BLEND25;
+ if dsBlend50 in DrawingStyle then
+ Result := Result or ILD_BLEND50;
+ if dsTransparent in DrawingStyle then
+ Result := Result or ILD_TRANSPARENT
+ else
+ if dsMask in DrawingStyle then
+ Result := Result or ILD_MASK
+ {else Result := Result or ILD_NORMAL}; // ILD_NORMAL = 0
+ Result := Result or WORD(FOverlayIdx shl 8);
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TImageList.GetHandle: THandle;
+begin
+ HandleNeeded;
+ Result := FHandle;
+end;
+{$ENDIF PAS_VERSION}
+
+function TImageList.GetMask: HBitmap;
+var II : TImageInfo;
+begin
+ Result := 0;
+ if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if ImageList_GetImageInfo( FHandle, 0, II ) then
+ Result := II.hbmMask;
+end;
+
+{$IFDEF ASM_noVERSION}
+function TImageList.HandleNeeded: Boolean;
+const ColorFlags : array[ TImageListColors ] of Byte = ( ILC_COLOR,
+ ILC_COLOR4, ILC_COLOR8, ILC_COLOR16, ILC_COLOR24,
+ ILC_COLOR32, ILC_COLORDDB );
+asm
+ MOV ECX, [EAX].FHandle
+ JECXZ @@make_handle
+ MOV AL, 1
+ RET
+@@make_handle:
+ MOV ECX, [EAX].fImgWidth
+ JECXZ @@ret_ECX
+ MOV EDX, ECX
+ MOV ECX, [EAX].fImgHeight
+ JECXZ @@ret_ECX
+ PUSH EBX
+ XCHG EBX, EAX
+
+ PUSH [EBX].FAllocBy
+ PUSH 0
+ MOVZX EAX, [EBX].FColors
+ MOVZX EAX, byte ptr [ColorFlags+EAX]
+ CMP [EBX].FMasked, 0
+ JZ @@flags_ready
+ {$IFDEF PARANOIA} DB $0C, $01 {$ELSE} OR AL, 1 {$ENDIF}
+@@flags_ready:
+ PUSH EAX
+ PUSH ECX
+ PUSH EDX
+ CALL ImageList_Create
+ MOV [EBX].FHandle, EAX
+ XCHG ECX, EAX
+ POP EBX
+@@ret_ECX:
+ TEST ECX, ECX
+ SETNZ AL
+end;
+{$ELSE PAS_VERSION} //Pascal
+function TImageList.HandleNeeded: Boolean;
+const ColorFlags : array[ TImageListColors ] of Byte = ( ILC_COLOR,
+ ILC_COLOR4, ILC_COLOR8, ILC_COLOR16, ILC_COLOR24,
+ ILC_COLOR32, ILC_COLORDDB, 0 );
+var Flags : DWord;
+begin
+ Result := True;
+ if FHandle <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := False;
+ if ImgWidth = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if ImgHeight = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Flags := ColorFlags[ FColors ];
+ if Masked then
+ Flags := Flags or ILC_MASK;
+ FHandle := ImageList_Create( ImgWidth, ImgHeight, Flags, 0, FAllocBy );
+ if fBkColor <> clNone then
+ SetBkColor( fBkColor );
+ Result := FHandle <> 0;
+end;
+{$ENDIF PAS_VERSION}
+
+function TImageList.ImgRect(Idx: Integer): TRect;
+var II : TImageInfo;
+begin
+ Result := MakeRect( 0, 0, 0, 0 );
+ if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if ImageList_GetImageInfo( FHandle, Idx, II ) then
+ Result := II.rcImage;
+end;
+
+{$IFDEF ASM_noVERSION_UNICODE}
+function TImageList.LoadBitmap(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;
+var NewHandle : THandle;
+ TranColr: TColor;
+begin
+ TranColr := TranspColor;
+ if TranColr = clNone then TranColr := TColor( CLR_NONE )
+ else TranColr := Color2RGB( TranColr );
+ NewHandle := ImageList_LoadBitmap( hInstance, ResourceName,
+ ImgWidth, AllocBy, TranColr );
+ //ImageList_GetIconSize( NewHandle, fImgWidth, fImgHeight );
+ Result := NewHandle <> 0;
+ if Result then
+ Handle := NewHandle;
+ ImageList_GetIconSize( fHandle, FImgWidth, FImgHeight );
+end;
+{$ENDIF PAS_VERSION}
+
+function TImageList.LoadFromFile(FileName: PKOLChar; TranspColor: TColor;
+ ImgType: TImageType): Boolean;
+const ImgTypes:array[ TImageType ] of DWord = ( IMAGE_BITMAP, IMAGE_ICON, IMAGE_CURSOR );
+var NewHandle : THandle;
+ TranspFlag : DWord;
+begin
+ TranspFlag := 0;
+ if TranspColor <> clNone then
+ TranspFlag := LR_LOADTRANSPARENT;
+ NewHandle := ImageList_LoadImage( hInstance, FileName, ImgWidth, AllocBy,
+ Color2RGB( TranspColor ), ImgTypes[ ImgType ],
+ LR_LOADFROMFILE or LR_CREATEDIBSECTION or TranspFlag );
+ Result := NewHandle <> 0;
+ if Result then
+ Handle := NewHandle;
+end;
+
+function TImageList.LoadSystemIcons(SmallIcons: Boolean): Boolean;
+var NewHandle : THandle;
+ FileInfo : TSHFileInfo;
+ Flags : DWord;
+begin
+ OleInit;
+ Flags := SHGFI_SYSICONINDEX;
+ if SmallIcons then
+ Flags := Flags or SHGFI_SMALLICON;
+ NewHandle := {$IFDEF UNICODE_CTRLS} SHGetFileInfoW {$ELSE} SHGetFileInfoA {$ENDIF}
+ ( '', 0, FileInfo, Sizeof( FileInfo ), Flags );
+ Result := NewHandle <> 0;
+ if Result then
+ begin
+ Handle := NewHandle;
+ FShareImages := True;
+ end;
+end;
+
+function TImageList.Merge(Idx: Integer; ImgList2: PImageList; Idx2, X,
+ Y: Integer): PImageList;
+var L : THandle;
+begin
+ Result := nil;
+ L := ImageList_Merge( FHandle, Idx, ImgList2.Handle, Idx2, X, Y );
+ if L <> 0 then
+ begin
+ Result := NewImageList( fControl );
+ Result.Handle := L;
+ end;
+end;
+
+function TImageList.Replace(Idx: Integer; Bmp, Msk: HBitmap): Boolean;
+begin
+ Result := False;
+ if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := ImageList_Replace( FHandle, Idx, Bmp, Msk );
+end;
+
+function TImageList.ReplaceIcon(Idx: Integer; Ico: HIcon): Boolean;
+begin
+ Result := False;
+ if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := ImageList_ReplaceIcon( FHandle, Idx, Ico ) >= 0;
+end;
+
+procedure TImageList.SetAllocBy(const Value: Integer);
+begin
+ if FHandle <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ // AllocBy can be changed only before adding images and creating handle
+ FAllocBy := Value;
+end;
+
+procedure TImageList.SetBkColor(const Value: TColor);
+begin
+ fBkColor := Value;
+ if fHandle <> 0 then
+ ImageList_SetBkColor( FHandle, Color2RGB( Value ) );
+end;
+
+procedure TImageList.SetColors(const Value: TImageListColors);
+begin
+ if FHandle <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FColors := Value;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TImageList.SetHandle(const Value: THandle);
+begin
+ if FHandle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if (FHandle <> 0) and not FShareImages then
+ ImageList_Destroy( FHandle );
+ FHandle := Value;
+ if FHandle <> 0 then
+ ImageList_GetIconSize( FHandle, FImgWidth, FImgHeight )
+ else
+ begin
+ FImgWidth := 0;
+ FImgHeight := 0;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TImageList.SetImgHeight(const Value: Integer);
+begin
+ if FHandle <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FImgHeight := Value;
+end;
+
+procedure TImageList.SetImgWidth(const Value: Integer);
+begin
+ if FHandle <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FImgWidth := Value;
+end;
+
+procedure TImageList.SetMasked(const Value: Boolean);
+begin
+ if FHandle <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FMasked := Value;
+end;
+
+function TImageList.GetOverlay(Idx: TImgLOVrlayIdx): Integer;
+begin
+ Result := fOverlay[ Idx ];
+end;
+
+procedure TImageList.SetOverlay(Idx: TImgLOVrlayIdx; const Value: Integer);
+begin
+ if ImageList_SetOverlayImage( fHandle, Value, Idx shl 8 ) then
+ fOverlay[ Idx ] := Value;
+end;
+
+procedure TImageList.StretchDraw(Idx: Integer; DC: HDC; const Rect: TRect);
+begin
+ if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ ImageList_DrawEx( FHandle, Idx, DC, Rect.Left, Rect.Top,
+ Rect.Right- Rect.Left, Rect.Bottom-Rect.Top,
+ BkColor, BlendColor, GetDrawStyle );
+end;
+
+function GetImgListSize( Sender: PControl; Size: Integer ): PImageList;
+begin
+ if Size > 16 then
+ Result := Sender.DF.fCtlImageListNormal
+ else
+ Result := Sender.DF.fCtlImageListSml;
+ if Result <> nil then
+ begin
+ if Result.fImgWidth = 0 then
+ Result.ImgWidth := Size;
+ if Result.fImgHeight = 0 then
+ Result.ImgHeight := Size;
+ end;
+ if Result = nil then
+ begin
+ Result := Sender.fImageList;
+ while Result <> nil do
+ begin
+ if (Result.FImgWidth = Size) and (Result.FImgHeight = Size) then
+ break;
+ Result := Result.fNext;
+ end;
+ end;
+end;
+
+function TControl.GetImgListIdx(const Index: Integer): PImageList;
+begin
+ if Index <> 0 then
+ Result := GetImgListSize( @Self, Index )
+ else
+ begin
+ Result := DF.fCtlImgListState;
+ if Result = nil then
+ begin
+ Result := fImageList;
+ while Result <> nil do
+ begin
+ if (Result <> GetImgListIdx( 16 )) and (Result <> GetImgListIdx( 32 )) then
+ break;
+ Result := Result.fNext;
+ end;
+ end;
+ end;
+end;
+
+procedure TControl.SetImgListIdx(const Index: Integer;
+ const Value: PImageList);
+begin
+
+ if Value <> nil then
+ begin
+ if Index <> 0 then
+ if (Value.ImgWidth = 0) or (Value.ImgHeight = 0) then
+ begin
+ Value.ImgWidth := Index;
+ Value.ImgHeight := Index;
+ end;
+ end;
+
+ case Index of
+ 32: DF.fCtlImageListNormal := Value;
+ 16: DF.fCtlImageListSml := Value;
+ else DF.fCtlImgListState := Value;
+ end;
+ ApplyImageLists2Control( @Self );
+end;
+
+{ -- list view -- }
+
+function WndProcEndLabelEdit( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var NMhdr: PNMHdr;
+ LVDisp: PLVDispInfo;
+ Flag: Boolean;
+begin
+ Result := False;
+ if Msg.message = WM_NOTIFY then
+ begin
+ NMHdr := Pointer( Msg.lParam );
+ case NMHdr.code of
+ LVN_ENDLABELEDIT:
+ begin
+ LVDisp := Pointer( Msg.lParam );
+ Result := True;
+ if LVDisp.item.pszText = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Rslt := 1;
+ {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnEndEditLVItem ) then
+ {$ENDIF}
+ begin
+ Flag := Self_.EV.fOnEndEditLVItem( Self_, LVDisp.item.iItem,
+ LVDisp.item.iSubItem, LVDisp.item.pszText );
+ if Flag then Rslt := 1
+ else Rslt := 0;
+ end;
+ end;
+ end;
+ end;
+end;
+
+procedure TControl.SetOnEndEditLVItem(const Value: TOnEditLVItem);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnEndEditLVITem := Value;
+ AttachProc( WndProcEndLabelEdit );
+end;
+
+procedure TControl.LVColAdd(const aText: KOLString; aalign: TTextAlign;
+ aWidth: Integer);
+begin
+ LVColInsert( DF.fLVColCount, aText, aalign, aWidth );// 21.10.2001
+end;
+
+//****************** changed by Mike Gerasimov
+procedure TControl.LVColInsert(ColIdx: Integer; const aText: KOLString;
+ aAlign: TTextAlign; aWidth: Integer);
+var LVColData: TLVColumn;
+begin
+ LVColData.mask := LVCF_FMT or LVCF_TEXT;
+ if ImageListSmall <> nil then
+ LVColData.mask := LVColData.mask; // or LVCF_IMAGE ;
+ LVColData.iImage := -1;
+ LVColData.fmt := Ord( aAlign );
+ if aWidth < 0 then
+ begin
+ aWidth := -aWidth;
+ LVColData.fmt := LVColData.fmt or LVCFMT_BITMAP_ON_RIGHT;
+ end;
+ LVColData.cx := aWidth;
+ if aWidth > 0 then
+ LVColData.mask := LVColData.mask or LVCF_WIDTH;
+ LVColData.pszText := PKOL_Char( aText );
+ if Perform( LVM_INSERTCOLUMN, ColIdx, Integer( @LVColData ) ) >= 0 then
+ Inc( DF.fLVColCount );
+end;
+
+function TControl.GetLVColText(Idx: Integer): KOLString;
+var Buf: array[ 0..4095 ] of KOLChar;
+ LC: TLVColumn;
+begin
+ LC.mask := LVCF_TEXT;
+ LC.pszText := @ Buf[ 0 ];
+ LC.cchTextMax := 4096;
+ Buf[ 0 ] := #0;
+ Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );
+ Result := Buf;
+end;
+
+procedure TControl.SetLVColText(Idx: Integer; const Value: KOLString);
+var LC: TLVColumn;
+begin
+ ZeroMemory( @LC, Sizeof( LC ) ); {Alexey (Lecha2002)}
+ LC.mask := LVCF_TEXT;
+ LC.pszText := '';
+ if Value <> '' then
+ LC.pszText := @ Value[ 1 ];
+ Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) );
+end;
+
+function TControl.GetLVColalign(Idx: Integer): TTextAlign;
+const Formats: array[ 0..2 ] of TTextAlign = ( taLeft, taRight, taCenter );
+var LC: TLVColumn;
+begin
+ ZeroMemory( @LC, Sizeof( LC ) ); {Alexey (Lecha2002)}
+ LC.mask := LVCF_FMT;
+ Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );
+ Result := Formats[ LC.fmt and LVCFMT_JUSTIFYMASK ];
+end;
+
+procedure TControl.SetLVColalign(Idx: Integer; const Value: TTextAlign);
+const FormatFlags: array[ TTextAlign ] of BYTE = ( LVCFMT_LEFT, LVCFMT_RIGHT,
+ LVCFMT_CENTER );
+var LC: TLVColumn;
+begin
+ ZeroMemory( @LC, Sizeof( LC ) ); {Alexey (Lecha2002)}
+ LC.mask := LVCF_FMT;
+ Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );
+ LC.fmt := LC.fmt and not LVCFMT_JUSTIFYMASK or FormatFlags[ Value ];
+ Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) );
+end;
+
+function TControl.GetLVColEx(Idx: Integer; const Index: Integer): Integer;
+var LC: TLVColumn;
+begin
+ ZeroMemory( @LC, Sizeof( LC ) ); {Alexey (Lecha2002)}
+ LC.mask := LoWord( Index );
+ Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );
+ Result := PDWORD( Integer( @ LC ) + HiWord( Index ) )^;
+end;
+
+//********************** changed by Mike Gerasimov
+procedure TControl.SetLVColEx(Idx: Integer; const Index: Integer;
+ const Value: Integer);
+var LC: TLVColumn;
+begin
+ ZeroMemory(@LC,SizeOf(LC)); // Added Line
+ LC.mask := LoWord( Index );
+ if HiWord( Index ) = 24 then // Added Line
+ begin // Added Line
+ LC.mask := LC.mask or LVCF_FMT; // Added Line
+ if Value <>-1 then // Added Line
+ LC.fmt := LC.fmt or LVCFMT_IMAGE or LVCFMT_COL_HAS_IMAGES // Added Line
+ else LC.mask := LC.mask and not LVCF_IMAGE; // + by non
+ end;
+ if (value<>-1)or(HiWord( Index )<>24) then // + by non
+ PDWORD( Integer( @ LC ) + HiWord( Index ) )^ := Value;
+ Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) );
+end;
+
+function TControl.LVAdd(const aText: KOLString; ImgIdx: Integer;
+ State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer;
+ Data: DWORD): Integer;
+begin
+ Result := LVInsert( MaxInt {Count}, aText, ImgIdx, State, StateImgIdx, OverlayImgIdx, Data );
+end;
+
+function TControl.LVInsert(Idx: Integer; const aText: KOLString;
+ ImgIdx: Integer; State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer;
+ Data: DWORD): Integer;
+const
+ LVM_REDRAWITEMS = LVM_FIRST + 21;
+var LVI: TLVItem;
+begin
+ LVI.mask := LVIF_TEXT or LVIF_IMAGE or LVIF_PARAM or LVIF_STATE
+ or LVIF_DI_SETITEM;
+ LVI.iItem := Idx;
+ LVI.iSubItem := 0;
+ LVI.state := 0;
+ if lvisBlend in State then
+ LVI.state := LVIS_CUT;
+ if lvisHighlight in State then
+ LVI.state := LVI.state or LVIS_DROPHILITED;
+ if lvisFocus in State then
+ LVI.state := LVI.state or LVIS_FOCUSED;
+ if lvisSelect in State then
+ LVI.state := LVI.state or LVIS_SELECTED;
+ LVI.stateMask := $FFFF;
+ if StateImgIdx <> 0 then
+ LVI.state := LVI.state or ((StateImgIdx and $F) shl 12);
+ if OverlayImgIdx <> 0 then
+ LVI.state := LVI.state or ((OverlayImgIdx and $F) shl 8);
+ LVI.pszText := PKOL_Char( aText );
+ LVI.iImage := ImgIdx;
+ LVI.lParam := Data;
+ Result := Perform( LVM_INSERTITEM, 0, Integer( @LVI ) );
+end;
+
+procedure TControl.LVSetItem(Idx, Col: Integer; const aText: KOLString;
+ ImgIdx: Integer; State: TListViewItemState; StateImgIdx,
+ OverlayImgIdx: Integer; Data: DWORD);
+var LVI: TLVItem;
+ {$IFDEF KOL_ASSERTIONS} I: Integer; {$ENDIF}
+begin
+ LVI.mask := LVIF_TEXT or {LVIF_STATE or} LVIF_DI_SETITEM;
+ if Col = 0 then
+ begin
+ LVI.mask := LVIF_TEXT or LVIF_STATE or LVIF_PARAM
+ or LVIF_DI_SETITEM;
+ end;
+ if ImgIdx <> I_SKIP then
+ LVI.mask := LVI.mask or LVIF_IMAGE;
+ if ImgIdx < I_SKIP then
+ LVI.mask := LVIF_TEXT or LVIF_DI_SETITEM;
+ LVI.iItem := Idx;
+ LVI.iSubItem := Col;
+ LVI.state := 0;
+ if lvisBlend in State then
+ LVI.state := LVIS_CUT;
+ if lvisHighlight in State then
+ LVI.state := LVI.state or LVIS_DROPHILITED;
+ if lvisFocus in State then
+ LVI.state := LVI.state or LVIS_FOCUSED;
+ if lvisSelect in State then
+ LVI.state := LVI.state or LVIS_SELECTED;
+ LVI.stateMask := $FFFF;
+ if StateImgIdx <> 0 then
+ LVI.state := LVI.state or ((StateImgIdx and $F) shl 12);
+ if StateImgIdx < 0 {= I_SKIP} then
+ LVI.stateMask := $F0FF;
+ if OverlayImgIdx <> 0 then
+ LVI.state := LVI.state or ((OverlayImgIdx and $F) shl 8);
+ if OverlayImgIdx < 0 {=I_SKIP} then
+ LVI.stateMask := LVI.stateMask and $FFF;
+ LVI.pszText := PKOL_Char( aText );
+ LVI.iImage := ImgIdx;
+ LVI.lParam := Data;
+ {$IFDEF KOL_ASSERTIONS} I := {$ENDIF}
+ Perform( LVM_SETITEM, 0, Integer( @LVI ) );
+ {$IFDEF KOL_ASSERTIONS}
+ if (I = 0) and (Col = 0) then
+ Assert( False, 'Can not set item ' );
+ {$ENDIF KOL_ASSERTIONS}
+end;
+
+procedure LVGetItem( Sender: PControl; Idx, Col: Integer; var LVI: TLVItem;
+ TextBuf: PKOL_Char; TextBufSize: Integer );
+begin
+ LVI.mask := LVIF_STATE or LVIF_PARAM or LVIF_IMAGE;
+ if Col > 0 then
+ if not (lvoSubItemImages in Sender.DF.fLVOptions) then
+ LVI.mask := LVIF_STATE or LVIF_PARAM;
+ LVI.iItem := Idx;
+ LVI.iSubItem := Col;
+ LVI.pszText := TextBuf;
+ LVI.cchTextMax := TextBufSize;
+ if TextBufSize <> 0 then
+ LVI.mask := LVI.mask or LVIF_TEXT;
+ Sender.Perform( LVM_GETITEM, 0, Integer( @LVI ) );
+end;
+
+function TControl.LVGetItemImgIdx(Idx: Integer): Integer;
+var LVI: TLVItem;
+begin
+ LVI.iImage := -1;//= Result if image is not assigned {Andrzej Kubaszek}
+ LVGetItem( @Self, Idx, 0, LVI, nil, 0 );
+ Result := LVI.iImage;
+end;
+
+procedure TControl.LVSetItemImgIdx(Idx: Integer; const Value: Integer);
+var LVI: TLVItem;
+begin
+ LVGetItem( @Self, Idx, 0, LVI, nil, 0 );
+ LVI.iImage := Value;
+ Perform( LVM_SETITEM, 0, Integer( @LVI ) );
+end;
+
+function TControl.LVGetItemText(Idx, Col: Integer): KOLString;
+var LVI: TLVItem;
+ TextBuf: PKOL_Char;
+ BufSize: Integer;
+begin
+ BufSize := 0;
+ TextBuf := nil;
+ repeat
+ if TextBuf <> nil then
+ FreeMem( TextBuf );
+ BufSize := BufSize * 2 + 100; // to vary in asm version
+ GetMem( TextBuf, BufSize * Sizeof( KOLChar ) );
+ TextBuf[ 0 ] := #0;
+ LVGetItem( @Self, Idx, Col, LVI, TextBuf, BufSize );
+ until Integer({$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}
+ ( PKOLChar( TextBuf ) )) < BufSize - 1;
+ Result := TextBuf;
+ FreeMem( TextBuf );
+end;
+
+procedure TControl.LVSetItemText(Idx, Col: Integer; const Value: KOLString);
+var LVI: TLVItem;
+begin
+ LVI.iSubItem := Col;
+ LVI.pszText := PKOL_Char( Value );
+ Perform( LVM_SETITEMTEXT, Idx, Integer( @LVI ) );
+end;
+
+procedure TControl.LVColDelete(ColIdx: Integer);
+begin
+ Perform( LVM_DELETECOLUMN, ColIdx, 0 );
+ if DF.fLVColCount > 0 then
+ Dec( DF.fLVColCount );
+end;
+
+procedure TControl.SetLVOptions(const Value: TListViewOptions);
+begin
+ if DF.fLVOptions = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ DF.fLVOptions := Value;
+ ApplyImageLists2ListView( @Self );
+ PostMessage( fHandle, WM_SIZE, 0, 0 ); // to restore scrollers (otherwise its are lost)
+end;
+
+procedure TControl.SetLVStyle(const Value: TListViewStyle);
+begin
+ if DF.fLVStyle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ DF.fLVStyle := Value;
+ ApplyImageLists2ListView( @Self );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.Perform(msgcode: DWORD; wParam, lParam: Integer): Integer; stdcall;
+begin
+ {$IFDEF INPACKAGE}
+ Log( '->TControl.Perform' );
+ TRY
+ {$ENDIF INPACKAGE}
+ Result := SendMessage( GetWindowHandle, msgcode, wParam, lParam );
+ {$IFDEF INPACKAGE}
+ LogOK;
+ FINALLY
+ Log( '<-TControl.Perform' );
+ END;
+ {$ENDIF INPACKAGE}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.Postmsg(msgcode: DWORD; wParam, lParam: Integer): Boolean; stdcall;
+begin
+ Result := PostMessage( GetWindowHandle, msgcode, wParam, lParam );
+end;
+{$ENDIF PAS_VERSION}
+
+{$ENDIF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.GetChildCount: Integer;
+begin
+ Result := fChildren.Count;
+end;
+{$ENDIF PAS_VERSION}
+{$IFDEF WIN_GDI}
+
+procedure TControl.LVDelete(Idx: Integer);
+begin
+ Perform( LVM_DELETEITEM, Idx, 0 );
+end;
+
+procedure TControl.LVEditItemLabel(Idx: Integer);
+begin
+ Perform( LVM_EDITLABEL, Idx, 0 );
+end;
+
+function TControl.LVItemRect(Idx: Integer; Part: TGetLVItemPart): TRect;
+const Parts: array[ TGetLVItemPart ] of Byte = (
+ LVIR_BOUNDS, LVIR_ICON, LVIR_LABEL, LVIR_SELECTBOUNDS );
+begin
+ Result := MakeRect( Parts[ Part ], 0, 0, 0 );
+ if Perform( LVM_GETITEMRECT, Idx, Integer( @Result ) ) = 0 then
+ Result := MakeRect( 0, 0, 0, 0 );
+end;
+
+function TControl.LVSubItemRect(Idx, ColIdx: Integer): TRect;
+var Hdr: HWnd;
+ R, R1: TRect;
+ ClassNameBuf: array[ 0..31 ] of KOLChar;
+ HdItem: THDItem;
+begin
+ Result.Top := ColIdx; // + 1; error in MSDN ?
+ Result.Left := LVIR_BOUNDS;
+ if Perform( LVM_GETSUBITEMRECT, Idx, Integer( @Result ) ) <> 0 then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := MakeRect( 0, 0, 0, 0 );
+ if ColIdx > 0 then R := LVSubItemRect( Idx, ColIdx - 1 )
+ else R := LVItemRect( Idx, lvipBounds );
+ if (R.Left = 0) and (R.Right = 0) and
+ (R.Top = 0) and (R.Bottom = 0) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Hdr := GetWindow( GetWindowHandle, GW_CHILD );
+ if Hdr <> 0 then
+ begin
+ if GetClassName( Hdr, ClassNameBuf, 32 ) > 0 then
+ if ClassNameBuf = 'SysHeader32' then
+ begin
+ if ColIdx > 0 then R.Left := R.Right
+ else R.Left := 0;
+ R1.Top := 0; R1.Left := 0;
+ Windows.ClientToScreen( Hdr,{$IFDEF FPC} PPoint( @ R1.Left )^ {$ELSE} R1.TopLeft {$ENDIF} );
+ Windows.ScreenToClient( fHandle, {$IFDEF FPC} PPoint( @ R1.Left )^ {$ELSE} R1.TopLeft {$ENDIF} );
+ R1 := R;
+ HdItem.Mask := HDI_WIDTH;
+ if SendMessage( Hdr, HDM_GETITEM, ColIdx, Integer( @HdItem ) ) = 0 then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ R1.Right := R1.Left + HdItem.cxy;
+ Result := R1;
+ end;
+ end;
+end;
+
+function TControl.LVGetItemPos(Idx: Integer): TPoint;
+begin
+ Perform( LVM_GETITEMPOSITION, Idx, Integer( @Result ) );
+end;
+
+procedure TControl.LVSetItemPos(Idx: Integer; const Value: TPoint);
+begin
+ Perform( LVM_SETITEMPOSITION32, Idx, Integer( @Value ) );
+end;
+
+function TControl.LVItemAtPos(X, Y: Integer): Integer;
+var Dummy: TWherePosLVItem;
+begin
+ Result := LVItemAtPosEx( X, Y, Dummy );
+end;
+
+function TControl.LVItemAtPosEx(X, Y: Integer;
+ var Where: TWherePosLVItem): Integer;
+var HTI: TLVHitTestInfo;
+begin
+ HTI.pt.x := X;
+ HTI.pt.y := Y;
+ Perform( LVM_HITTEST, 0, Integer( @HTI ) );
+ Result := HTI.iItem;
+ Where := lvwpOnColumn;
+ if HTI.flags = LVHT_ONITEMICON then
+ Where := lvwpOnIcon
+ else
+ if HTI.flags = LVHT_ONITEMLABEL then
+ Where := lvwpOnLabel
+ else
+ if HTI.flags = LVHT_ONITEMSTATEICON then
+ Where := lvwpOnStateIcon
+ else
+ if HTI.flags = LVHT_ONITEM then
+ Where := lvwpOnItem;
+end;
+
+procedure TControl.LVMakeVisible(Item: Integer; PartiallyOK: Boolean);
+begin
+ if Item < 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Perform( LVM_ENSUREVISIBLE, Item, Integer( PartiallyOK ) );
+end;
+
+procedure TControl.LVSetColorByIdx(const Index: Integer;
+ const Value: TColor);
+var MsgCode: Integer;
+ ColorValue: TColor;
+begin
+ MsgCode := Index + 1;
+ case MsgCode of
+ LVM_SETTEXTCOLOR: fTextColor := Value;
+ LVM_SETTEXTBKCOLOR: DF.fLVTextBkColor := Value;
+ LVM_SETBKCOLOR: fColor := Value;
+ end;
+ ColorValue := Color2RGB( Value );
+ Perform( MsgCode, 0, ColorValue );
+end;
+
+{$IFDEF F_P}
+function TControl.LVGetColorByIdx(const Index: Integer): TColor;
+begin
+ CASE Index OF
+ LVM_SETTEXTCOLOR: Result := fTextColor;
+ LVM_SETTEXTBKCOLOR: Result := fLVTextBkColor;
+ LVM_SETBKCOLOR: Result := fColor;
+ END;
+end;
+{$ENDIF F_P}
+
+function TControl.GetIntVal(const Index: Integer): Integer;
+begin
+ Result := GetItemVal( 0, Index );
+end;
+
+procedure TControl.SetIntVal(const Index, Value: Integer);
+begin
+ SetItemVal( Value, Index, 0 );
+end;
+
+function TControl.GetItemVal(Item: Integer; const Index: Integer): Integer;
+begin
+ Result := Perform( LoWord(Index), Item, 0 );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.SetItemVal(Item: Integer; const Index: Integer; const Value: Integer);
+var MsgCode: Integer;
+begin
+ MsgCode := HiWord( Index );
+ if MsgCode = 0 then
+ MsgCode := Index + 1;
+ Perform( MsgCode and $7FFF, Item, Value );
+ if (MsgCode and $8000) <> 0 then
+ Invalidate;
+end;
+{$ENDIF PAS_VERSION}
+
+function TControl.GetSBMinMax: TPoint;
+{$IFDEF _D2}
+var X, Y: Integer;
+{$ENDIF}
+begin
+ if (Handle <> 0) then begin
+ {$IFDEF _D2}
+ GetScrollRange(Handle, SB_CTL, X, Y);
+ Result.X := X;
+ Result.Y := Y;
+ {$ELSE}
+ GetScrollRange(Handle, SB_CTL, Result.X, Result.Y);
+ {$ENDIF}
+ Dec(Result.Y, SBPageSize - 1);
+ end
+ else
+ Result := DF.fSBMinMax;
+end;
+
+function TControl.GetSBPageSize: Integer;
+var
+ SI: TScrollInfo;
+begin
+ ZeroMemory(@SI, SizeOf(SI));
+ SI.cbSize := SizeOf(SI);
+ SI.fMask := SIF_PAGE;
+ SBGetScrollInfo(SI);
+ Result := SI.nPage;
+end;
+
+function TControl.GetSBPosition: Integer;
+begin
+ Result := GetScrollPos(Handle, SB_CTL);
+end;
+
+procedure TControl.SetSBMax(Value: Longint);
+var
+ P: TPoint;
+begin
+ DF.fSBMinMax.Y := Value;
+ if (Handle <> 0) then
+ begin
+ P := SBMinMax;
+ P.Y := Value;
+ SBMinMax := P;
+ end;
+end;
+
+procedure TControl.SetSBMin(Value: Longint);
+var
+ P: TPoint;
+begin
+ DF.fSBMinMax.X := Value;
+ if (Handle <> 0) then
+ begin
+ P := SBMinMax;
+ P.X := Value;
+ SBMinMax := P;
+ end;
+end;
+
+procedure TControl.SetSBPageSize(Value: Integer);
+var
+ SI: TScrollInfo;
+begin
+ DF.fSBPageSize := Value;
+ if fHandle <> 0 then
+ begin
+ ZeroMemory(@SI, SizeOf(SI));
+ SI.cbSize := SizeOf(SI);
+ SI.fMask := SIF_PAGE or SIF_RANGE;
+ SBGetScrollInfo(SI);
+ {$IFDEF SCROLL_OLD} // by QAZ
+ {$IFDEF SCROLL_OLD_MAX1}
+ if (SI.nMax = 0) and (SI.nMin = 0) then
+ SI.nMax := 1;
+ {$ENDIF}
+ SI.nMax := SI.nMax - Integer(SI.nPage) + Value;
+ {$ENDIF}
+ SI.nPage := Value;
+ SBSetScrollInfo(SI);
+ end;
+end;
+
+procedure TControl.SetSBPosition(Value: Integer);
+begin
+ DF.fSBPosition := Value;
+ if (Handle <> 0) then
+ SetScrollPos(Handle, SB_CTL, Value, True);
+end;
+
+procedure TControl.SetSBMinMax(const Value: TPoint);
+begin
+ GetSBMinMax;
+ if (Handle <> 0) then
+ SetScrollRange(Handle, SB_CTL, Value.X,
+ Value.Y {$IFDEF SCROLL_OLD} + SBPageSize - 1{$ENDIF (by QAZ)} , True)
+ else
+ DF.fSBMinMax := Value;
+end;
+
+function TControl.SBSetScrollInfo(const SI: TScrollInfo): Integer;
+begin
+ Result := SetScrollInfo(Handle, SB_CTL, SI, True)
+end;
+
+function TControl.SBGetScrollInfo(var SI: TScrollInfo): Boolean;
+begin
+ Result := Cardinal(GetScrollInfo(Handle, SB_CTL, SI)) <> 0;
+end;
+
+{ -- OpenSaveDialog -- }
+
+function NewOpenSaveDialog( const Title, StrtDir: KOLString;
+ Options: TOpenSaveOptions ): POpenSaveDialog;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TOpenSaveDialog';
+ {$ENDIF}
+ Result.FOptions := Options;
+ if Options = [] then
+ Result.FOptions := DefOpenSaveDlgOptions;
+ Result.fOpenDialog := True;
+ Result.FTitle := Title;
+ Result.FInitialDir := StrtDir;
+end;
+
+{ TOpenSaveDialog }
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TOpenSaveDialog.Destroy;
+begin
+ FFilter := '';
+ FInitialDir := '';
+ FDefExtension := '';
+ FFileName := '';
+ FTitle := '';
+ {$IFDEF OpenSaveDialog_Extended}
+ TemplateName := '';
+ {$ENDIF}
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TOpenSaveDialog.Execute: Boolean;
+const OpenSaveFlags: array[ TOpenSaveOption ] of Integer = (
+ OFN_CREATEPROMPT,
+ OFN_EXTENSIONDIFFERENT,
+ OFN_FILEMUSTEXIST,
+ OFN_HIDEREADONLY,
+ OFN_NOCHANGEDIR,
+ OFN_NODEREFERENCELINKS,
+ OFN_ALLOWMULTISELECT,
+ OFN_NONETWORKBUTTON,
+ OFN_NOREADONLYRETURN,
+ OFN_OVERWRITEPROMPT,
+ OFN_PATHMUSTEXIST,
+ OFN_READONLY,
+ OFN_NOVALIDATE,
+ OFN_ENABLETEMPLATE,
+ OFN_ENABLEHOOK );
+var
+ Ofn : TOpenFilename;
+ Fltr : KOLString;
+ TempFilename : KOLString;
+ Function MakeFilter(s : KOLString) : KOLString;
+ { format of filter for API call is following:
+ 'text files'#0'*.txt'#0
+ 'bitmap files'#0'*.bmp'#0#0 }
+ var Str: PKOLChar;
+ begin
+ Result := s;
+ if Result='' then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result:=Result+#0; {Delphi string always end on #0 is this is #0#0}
+ Str := PKOLChar( Result );
+ while Str^ <> #0 do
+ begin
+ if Str^ = '|' then
+ Str^ := #0;
+ Inc( Str );
+ end;
+ end;
+
+var m: Integer;
+begin
+ ZeroMemory( @ofn, sizeof( ofn ) );
+
+ {$IFDEF OpenSaveDialog_Extended}
+ if (WinVer <= wvNT) and (WinVer <> wvME) then
+ ofn.lStructSize := 76
+ else
+ begin
+ ofn.lStructSize := Sizeof( ofn );
+ ofn.FlagsEx := Integer( NoPlaceBar );
+ end;
+ {$ELSE}
+ ofn.lStructSize:= 76; //to provide correct work in Win9x
+ {$ENDIF}
+ if fWnd <> 0 then
+ ofn.hWndOwner := fWnd
+ else
+ if Applet <> nil then
+ ofn.hwndOwner := applet.Handle;
+
+ ofn.hInstance:=HInstance;
+
+ Fltr := MakeFilter(FFilter);
+ if Fltr <> '' then
+ ofn.lpstrFilter := PKOLchar(Fltr);
+ ofn.nFilterIndex := FFilterIndex;
+
+ if OSAllowMultiSelect in FOptions then
+ ofn.nMaxFile := High(word)-14 // by V.K. (exchanged condition)
+ else
+ ofn.nMaxFile := MAX_PATH+2;
+
+ SetLength( TempFileName, ofn.nMaxFile );
+ ZeroMemory( @TempFileName[ 1 ], ofn.nMaxFile * sizeof( KOLChar ) );
+ m := Min( ofn.nMaxFile, Length(fFileName) );
+ {$IFDEF UNICODE_CTRLS}
+ ofn.lpstrFile := PKOLchar( TempFileName );
+ WStrLCopy(PWideChar(TempFileName), PWideChar(fFileName), m );
+ {$ELSE}
+ ofn.lpstrFile := StrLCopy(PKOLChar(TempFileName), PKOLchar(fFileName), m );
+ {$ENDIF}
+
+ ofn.lpstrInitialDir:=Pointer(FInitialDir);
+ ofn.lpstrTitle := Pointer(FTitle);
+ ofn.Flags := MakeFlags( @FOptions, OpenSaveFlags )
+ or OFN_EXPLORER or OFN_LONGNAMES or OFN_ENABLESIZING;
+
+ ofn.lpstrDefExt := PKOLChar(FDefExtension);
+ ofn.lCustData := integer(@self);
+ {$IFDEF OpenSaveDialog_Extended}
+ ofn.lpTemplateName := PKOLChar( TemplateName );
+ ofn.lpfnHook := HookProc;
+ {$ELSE}
+ ofn.lpTemplateName := nil;
+ ofn.lpfnHook := nil;
+ {$ENDIF}
+ if fOpenDialog then
+ result := GetOpenFileName(POpenFileName( @ofn )^)
+ else
+ result := GetSaveFileName(POpenFileName( @ofn )^);
+ if result then begin
+ fFilterIndex := ofn.nFilterIndex; // by Vadim
+ fOpenReadOnly := OFN_READONLY and ofn.Flags <> 0; // by ECM (in my redaction)
+ if OSAllowMultiSelect in foptions then begin
+ FFileName := copy(TempFileName, 1, pos(KOLString(#0#0), tempfilename)-1);
+ while pos(KOLString(#0), ffilename) > 0 do begin
+ FFilename[pos(KOLString(#0), ffilename)]:=#13;
+ end;
+ end else
+ FFileName := copy(tempFileName, 1, pos(KOLString(#0), TempFilename)
+ -1 // by X.Y.B.
+ );
+ end else
+ FFilename:='';
+end;
+{$ENDIF PAS_VERSION}
+
+{ -- OpenDirDialog -- }
+
+function NewOpenDirDialog( const Title: KOLString; Options: TOpenDirOptions ):
+ POpenDirDialog;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TOpenDirDialog';
+ {$ENDIF}
+ Result.FOptions := [ odOnlySystemDirs ];
+ if Options <> [] then
+ Result.FOptions := Options;
+ Result.FTitle := Title;
+end;
+
+{ TOpenDirDialog }
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TOpenDirDialog.Destroy;
+begin
+ FTitle := '';
+ FInitialPath := '';
+ FStatusText := '';
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+type
+ PSHItemID = ^TSHItemID;
+ TSHItemID = packed record
+ cb: Word; { Size of the ID (including cb itself) }
+ abID: array[0..0] of Byte; { The item ID (variable length) }
+ end;
+
+ PItemIDList = ^TItemIDList;
+ TItemIDList = record
+ mkid: TSHItemID;
+ end;
+
+ PBrowseInfo = ^TBrowseInfo;
+ TBrowseInfoA = record
+ hwndOwner: HWND;
+ pidlRoot: PItemIDList;
+ pszDisplayName: PAnsiChar; { Return display name of item selected. }
+ lpszTitle: PAnsiChar; { text to go in the banner over the tree. }
+ ulFlags: UINT; { Flags that control the return stuff }
+ lpfn: Pointer; //TFNBFFCallBack;
+ lParam: LPARAM; { extra info that's passed back in callbacks }
+ iImage: Integer; { output var: where to return the Image index. }
+ end;
+ TBrowseInfoW = record
+ hwndOwner: HWND;
+ pidlRoot: PItemIDList;
+ pszDisplayName: PWideChar; { Return display name of item selected. }
+ lpszTitle: PWideChar; { text to go in the banner over the tree. }
+ ulFlags: UINT; { Flags that control the return stuff }
+ lpfn: Pointer; //TFNBFFCallBack;
+ lParam: LPARAM; { extra info that's passed back in callbacks }
+ iImage: Integer; { output var: where to return the Image index. }
+ end;
+ TBrowseInfo = {$IFDEF UNICODE_CTRLS} TBrowseInfoW {$ELSE} TBrowseInfoA {$ENDIF};
+
+function SHBrowseForFolderA(var lpbi: TBrowseInfoA): PItemIDList; stdcall;
+ external 'shell32.dll' name 'SHBrowseForFolderA';
+{$IFDEF UNICODE_CTRLS}
+function SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; stdcall;
+ external 'shell32.dll' name 'SHBrowseForFolderW';
+{$ENDIF UNICODE_CTRLS}
+function SHGetPathFromIDListA(pidl: PItemIDList; pszPath: PAnsiChar): BOOL; stdcall;
+ external 'shell32.dll' name 'SHGetPathFromIDListA';
+{$IFDEF UNICODE_CTRLS}
+function SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PKOLChar): BOOL; stdcall;
+ external 'shell32.dll' name 'SHGetPathFromIDListW';
+{$ENDIF UNICODE_CTRLS}
+procedure CoTaskMemFree(pv: Pointer); stdcall; external 'ole32.dll'
+ name 'CoTaskMemFree';
+
+const
+ BIF_RETURNONLYFSDIRS = $0001; { For finding a folder to start document searching }
+ BIF_DONTGOBELOWDOMAIN = $0002; { For starting the Find Computer }
+ BIF_STATUSTEXT = $0004;
+ BIF_RETURNFSANCESTORS = $0008;
+ BIF_EDITBOX = $0010;
+ BIF_VALIDATE = $0020; { insist on valid result (or CANCEL) }
+ BIF_NEWDIALOGSTYLE = $0040; { Use the new dialog layout with the ability to resize }
+ { Caller needs to call OleInitialize() before using this API (c) JVCL }
+ BIF_BROWSEFORCOMPUTER = $1000; { Browsing for Computers. }
+ BIF_BROWSEFORPRINTER = $2000; { Browsing for Printers }
+ BIF_BROWSEINCLUDEFILES = $4000; { Browsing for Everything }
+
+ BFFM_INITIALIZED = 1;
+ BFFM_SELCHANGED = 2;
+
+ BFFM_SETSTATUSTEXT = WM_USER + 100;
+ BFFM_ENABLEOK = WM_USER + 101;
+ BFFM_SETSELECTION = WM_USER + 102;
+ BFFM_SETSELECTIONW = WM_USER + 103;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TOpenDirDialog.Execute: Boolean;
+const FlagsArray: array[ TOpenDirOption ] of Integer =
+ ( BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER, BIF_DONTGOBELOWDOMAIN,
+ BIF_RETURNFSANCESTORS, BIF_RETURNONLYFSDIRS, BIF_STATUSTEXT,
+ BIF_BROWSEINCLUDEFILES, BIF_EDITBOX, BIF_NEWDIALOGSTYLE );
+var BI : TBrowseInfo;
+ Browse : PItemIdList;
+begin
+ Result := False;
+ if WndOwner <> 0 then
+ BI.hwndOwner := WndOwner
+ else
+ if Applet <> nil then
+ BI.hwndOwner := Applet.Handle
+ else
+ BI.hwndOwner := 0;
+ BI.pidlRoot := nil;
+ BI.pszDisplayName := @FBuf[ 0 ];
+ BI.lpszTitle := PKOLChar( Title );
+ BI.ulFlags := MakeFlags( @FOptions, FlagsArray );
+ BI.lpfn := FCallBack;
+ BI.lParam := Integer( @Self );
+ Browse := {$IFDEF UNICODE_CTRLS} SHBrowseForFolderW {$ELSE} SHBrowseForFolderA {$ENDIF}
+ ( BI );
+ if Browse <> nil then
+ begin
+ {$IFDEF UNICODE_CTRLS}SHGetPathFromIDListW{$ELSE} SHGetPathFromIDListA{$ENDIF}( Browse, @FBuf[ 0 ] );
+ CoTaskMemFree( Browse );
+ Result := True;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function TOpenDirDialog.GetInitialPath: KOLString;
+begin
+ Result := IncludeTrailingPathDelimiter( fInitialPath );
+end;
+
+function TOpenDirDialog.GetPath: KOLString;
+begin
+ Result := FBuf;
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function OpenDirSelChangeCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ):
+ Integer; stdcall;
+var _Self_: POpenDirDialog;
+ EnableOK: Integer;
+begin
+ _Self_ := Pointer( lpData );
+ if Assigned( _Self_.FOnSelChanged ) then
+ begin
+ {$IFDEF UNICODE_CTRLS} SHGetPathFromIDListW {$ELSE} SHGetPathFromIDListA {$ENDIF}( PItemIDList( lParam ), @ _Self_.FBuf[ 0 ] );
+ EnableOK := 0;
+ _Self_.FOnSelChanged( _Self_, _Self_.FBuf, EnableOK,
+ KOL_String( KOLString( _Self_.FStatusText ) ) );
+ SendMessage( Wnd, BFFM_ENABLEOK, 0, EnableOK );
+ if _Self_.FStatusText <> '' then
+ SendMessage( Wnd, BFFM_SETSTATUSTEXT, 0, Integer( PKOLChar( _Self_.FStatusText ) ) );
+ end;
+ Result := 0;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_LOCAL} {$UNDEF ASM_LOCAL} {$ENDIF}
+{$IFNDEF NEW_OPEN_DIR_STYLE_EX}
+ {$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF}
+{$ENDIF}
+
+{$IFDEF ASM_LOCAL}
+{$ELSE PAS_VERSION} //Pascal
+function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer;
+ stdcall;
+const
+ Shel: array[ 0..3 ] of AnsiChar = 'SHBr'; // KOL_ANSI used as DWORD
+var Self_ : POpenDirDialog;
+ {$IFDEF NEW_OPEN_DIR_STYLE_EX}
+ WList: HWnd;
+ ClassBuf: array[ 0..127 ] of KOLChar;
+ {$ENDIF}
+begin
+ Self_ := Pointer( lpData );
+ Self_.FDialogWnd := Wnd;
+ if Msg = BFFM_INITIALIZED then
+ begin
+ if Assigned( Self_.FCenterProc ) then
+ Self_.FCenterProc( Wnd );
+ if Self_.FInitialPath <> '' then
+ begin
+ {$IFDEF NEW_OPEN_DIR_STYLE_EX}
+ WList := GetWindow( Wnd, GW_CHILD );
+ while WList <> 0 do
+ begin
+ WList := GetWindow( WList, GW_HWNDNEXT );
+ GetClassName( WList, @ ClassBuf[ 0 ], Sizeof( ClassBuf ) );
+ if PDWord( @ ClassBuf[ 0 ] )^ = DWORD( Shel ) then
+ begin
+ PostMessage( Wnd, WM_NEXTDLGCTL, WList, 1 );
+ break;
+ end;
+ end;
+ PostMessage( Wnd, {$IFDEF UNICODE_CTRLS} BFFM_SETSELECTIONW
+ {$ELSE} BFFM_SETSELECTION {$ENDIF}, 1, Integer( PKOLChar(
+ ExtractFilePath( Self_.FInitialPath ) ) ) );
+ PostMessage( WND, WM_KEYDOWN, VK_ADD, 0 );
+ PostMessage( WND, WM_KEYUP, VK_ADD, 0 );
+ PostMessage( Wnd, {$IFDEF UNICODE_CTRLS} BFFM_SETSELECTIONW
+ {$ELSE} BFFM_SETSELECTION {$ENDIF}, 1, Integer( PKOLChar( Self_.FInitialPath ) ) );
+ {$ELSE}
+ SendMessage( Wnd, {$IFDEF UNICODE_CTRLS} BFFM_SETSELECTIONW
+ {$ELSE} BFFM_SETSELECTION {$ENDIF}, 1, Integer( PKOLChar( Self_.FInitialPath ) ) );
+ {$ENDIF}
+ SendMessage( Wnd, BFFM_ENABLEOK, 0, 1 );
+ end;
+ end
+ else
+ if Msg = BFFM_SELCHANGED then
+ begin
+ if Assigned( Self_.FDoSelChanged ) then
+ Self_.FDoSelChanged( Wnd, Msg, lParam, lpData )
+ else
+ SendMessage( Wnd, BFFM_ENABLEOK, 0, 1 );
+ end;
+ Result := 0;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure OpenDirDlgCenter( Wnd: HWnd );
+var R: TRect;
+ W, H: Integer;
+begin
+ GetWindowRect( Wnd, R );
+ W := R.Right - R.Left;
+ H := R.Bottom - R.Top;
+ R.Left := (GetSystemMetrics( SM_CXSCREEN ) - W) div 2;
+ R.Top := (GetSystemMetrics( SM_CYSCREEN ) - H) div 2;
+ MoveWindow( Wnd, R.Left, R.Top, W, H, True );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TOpenDirDialog.SetCenterOnScreen(const Value: Boolean);
+var P: procedure( Wnd: HWnd );
+begin
+ FCenterOnScreen := Value;
+ P := nil;
+ if Value then
+ P := @OpenDirDlgCenter;
+ FCenterProc := P;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TOpenDirDialog.SetInitialPath(const Value: KOLString);
+begin
+ FCallBack := @OpenDirCallBack;
+ FInitialPath := ExcludeTrailingPathDelimiter( Value );
+ if (FInitialPath <> '') and
+ (FInitialPath[ Length( FInitialPath ) ] = ':') then
+ FInitialPath := IncludeTrailingPathDelimiter( Value );
+end;
+
+procedure TOpenDirDialog.SetOnSelChanged(const Value: TOnODSelChange);
+begin
+ FOnSelChanged := Value;
+ FCallBack := @OpenDirCallBack;
+ FDoSelChanged := @OpenDirSelChangeCallBack;
+end;
+
+type
+ PByteArray =^TByteArray;
+ TByteArray = array[Word]of Byte;
+
+function CreateMappedBitmap(Instance: THandle; Bitmap: Integer;
+ Flags: UINT; ColorMap: PColorMap; NumMaps: Integer): HBitmap; stdcall;
+ external cctrl name 'CreateMappedBitmap';
+
+function CreateMappedBitmapEx(Instance: THandle; BmpRsrcName: PKOLChar; Flags:
+Cardinal; ColorMap: PColorMap; NumMaps: Integer): HBitmap;
+var bi: TBITMAPINFO;
+ DC, tmcl: Cardinal;
+ Bits: PByteArray;
+ i, j, k, CO, bps: Integer;
+ tm: array [1..4] of byte absolute tmcl;
+ bm: Windows.TBITMAP;
+ CM: PColorMap;
+ DW: HWnd;
+begin
+ Result := LoadBitmap( Instance, BmpRsrcName );
+ if Result = 0 then
+ begin
+ {$IFDEF DEBUG_ANY}
+ ShowMessage( AnsiString('Can not load bitmap ') + BmpRsrcName + ', error ' +
+ Int2Str( GetLastError ) + ': ' + SysErrorMessage( GetLastError ) );
+ {$ENDIF DEBUG_ANY}
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ DW := GetDesktopWindow;
+ DC := GetDC(DW);
+ ZeroMemory( @bm, SizeOf(bm) );
+ GetObject( Result, SizeOf( bm ), @bm );
+
+ ZeroMemory( @bi, SizeOf( bi ) );
+ bi.bmiHeader.biSize := SizeOf( bi.bmiHeader );
+ bi.bmiHeader.biWidth := bm.bmWidth;
+ bi.bmiHeader.biHeight := -bm.bmHeight;
+ bi.bmiHeader.biPlanes := 1;
+ bi.bmiHeader.biBitCount := 24;
+// BitCout - always 24 for easy algorythm
+ bi.bmiHeader.biCompression:=BI_RGB;
+ bps := CalcScanLineSize( @bi.bmiHeader );
+
+ GetMem( Bits, bps * bm.bmHeight );
+ GetDIBits( DC, Result, 0, bm.bmHeight, @Bits[0], bi, DIB_RGB_COLORS );
+ DeleteObject( Result );
+
+ for i := 0 to bm.bmHeight - 1 do begin
+ for j := 0 to bm.bmWidth - 1 do begin
+ CO := bps * i + 3 * j;
+ for k := 0 to NumMaps - 1 do begin
+ CM := Pointer( Integer( ColorMap ) + SizeOf( TColorMap ) * k );
+ if RGB( Bits[CO+2], Bits[CO+1], Bits[CO] ) = CM.cFrom then
+ begin
+ tmcl := CM.cTo;
+ tm[4]:=tm[1];
+ tm[1]:=tm[3];
+ tm[3]:=tm[4];
+ Move( tmcl, Bits[CO], 3);
+ end;
+ end;
+ end;
+ end;
+ Result := CreateDIBitmap( DC, bi.bmiHeader, CBM_INIT, @Bits[0], bi,
+ DIB_RGB_COLORS );
+ ReleaseDC( DW, DC );
+ FreeMem( Bits );
+end;
+
+function LoadMappedBitmap( hInst: THandle; BmpResID: Integer; const Map: array of TColor )
+ : HBitmap;
+var Map2Pass: Pointer;
+begin
+ Map2Pass := nil;
+ if High( Map ) > 0 then
+ Map2Pass := PColorMap( @Map[ 0 ] );
+ Result := CreateMappedBitmap( hInst, BmpResID, 0, Map2Pass, (High( Map ) + 1) div 2 );
+end;
+
+function LoadMappedBitmapEx( MasterObj: PObj; hInst: THandle; BmpResName: PKOLChar; const Map: array of TColor )
+ : HBitmap;
+var Map2Pass: Pointer;
+begin
+ Map2Pass := nil;
+ if High( Map ) > 0 then
+ Map2Pass := PColorMap( @Map[ 0 ] );
+ Result := CreateMappedBitmapEx( hInst, BmpResName, 0, Map2Pass, (High( Map ) + 1) div 2 );
+ if MasterObj <> nil then
+ MasterObj.Add2AutoFreeEx( TObjectMethod( MakeMethod( Pointer( Result ), @ FreeBmp ) ) );
+end;
+
+{ -- Toolbar -- }
+
+{$IFDEF ASM_noVERSION} // width
+procedure TControl.TBAddBitmap(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 DWORD = ( 15, 15, 0, 0, 13, 13 );
+var BI: TBitmapInfo;
+ AB: TTBAddBitmap;
+ N, W: Integer;
+begin
+ if Bitmap = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if (Integer( Bitmap ) >= -10) and (Integer( Bitmap ) <= -1) then
+ begin
+ AB.hInst := THandle(-1);
+ AB.nID := -Integer(Bitmap) - 1;
+ N := 0; //NstdBitmaps[ AB.nID ]; // (this value is ignored)
+ end
+ else
+ if GetObject( Bitmap, sizeof( TBitmapInfo ), @BI ) > 0 then
+ begin
+ AB.hInst := 0;
+ AB.nID := Bitmap;
+ W := DF.fTBBtnImgWidth;
+ if W = 0 then
+ W := Abs( BI.bmiHeader.biHeight );
+ N := BI.bmiHeader.biWidth div W;
+ Perform( TB_SETBITMAPSIZE, 0, MAKELONG( W, Abs(BI.bmiHeader.biHeight )) );
+ Perform( TB_AUTOSIZE, 0, 0 );
+ end else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Perform( TB_ADDBITMAP, N, Integer( @AB ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TControl.TBAddInsButtons(Idx: Integer; const Buttons: array of PKOLChar;
+ const BtnImgIdxArray: array of Integer): Integer; stdcall;
+
+ function AddInsButtons: Integer;
+ type TTBBtnArray = array[ 0..100000 ] of TTBButton;
+ PTBBtnArray = ^TTBBtnArray;
+ var AB: PTBBtnArray;
+ I, N, nBmp: Integer;
+ PAB: PTBButton;
+ Str: PKOLChar;
+ Str0: KOLString;
+ begin
+ Result := -1;
+ AB := nil;
+ if High( Buttons ) >= 0 then
+ GetMem( AB, Sizeof( TTBButton ) * (High(Buttons) + 1) );
+ N := 0;
+ PAB := @AB[ 0 ];
+ nBmp := -2;
+ if High(BtnImgIdxArray) >= 0 then
+ nBmp := BtnImgIdxArray[ 0 ] - 1;
+ for I:= 0 to High( Buttons ) do
+ begin
+ if Buttons[ I ] = nil then break;
+ if {$IFDEF UNICODE_CTRLS} WStrComp {$ELSE} StrComp {$ENDIF}
+ ( Buttons[ I ], {$IFDEF F_P}''+{$ENDIF} '-' ) = 0 then
+ begin
+ PAB.iBitmap := -1;
+ //PAB.idCommand := 0;
+ PAB.fsState := 0;
+ PAB.fsStyle := TBSTYLE_SEP;
+ PAB.iString := -1;
+ end
+ else
+ begin
+ Str := Buttons[ I ];
+ Inc( nBmp );
+ PAB.iBitmap := nBmp;
+ if nBmp < 0 then
+ Dec( nBmp );
+ if High( BtnImgIdxArray ) >= N then
+ PAB.iBitmap := BtnImgIdxArray[ N ];
+ PAB.fsState := TBSTATE_ENABLED;
+ PAB.fsStyle := TBSTYLE_BUTTON or DF.fDefaultTBBtnStyle;
+ if Str^ = '^' then
+ begin
+ PAB.fsStyle := TBSTYLE_DROPDOWN or DF.fDefaultTBBtnStyle;
+ Inc( Str );
+ end;
+ if CharIn( Str^, [ '-', '+' ] ) then
+ begin
+ PAB.fsStyle := PAB.fsStyle or TBSTYLE_CHECK;
+ if Str^ = '+' then
+ PAB.fsState := PAB.fsState or TBSTATE_CHECKED;
+ Inc( Str );
+ if Str^ = '!' then
+ begin
+ PAB.fsStyle := PAB.fsStyle or TBSTYLE_GROUP;
+ Inc( Str );
+ end;
+ end;
+ {$IFDEF TOOLBAR_DOT_NOAUTOSIZE_BUTTON}
+ if Str^ = '.' then
+ begin
+ PAB.fsStyle := PAB.fsStyle and not TBSTYLE_AUTOSIZE;
+ inc( Str );
+ end;
+ {$ENDIF TOOLBAR_DOT_NOAUTOSIZE_BUTTON}
+ if (KOLString(Str) = KOLString( {$IFDEF F_P}''+{$ENDIF} KOLChar( ' ' ) )) or (Str^ = #0) then
+ PAB.iString := -1
+ else
+ begin
+ Str0 := KOLString('') + KOLString(Str) + #0;
+ PAB.iString := Perform( TB_ADDSTRING, 0, Integer(PKOLChar(Str0)) );
+ end;
+ end;
+
+ PAB.idCommand := ToolbarsIDcmd;
+ if Result < 0 then Result := PAB.idCommand;
+ Inc( ToolbarsIDcmd );
+
+ PAB.dwData := Integer( @Self );
+ Inc( N );
+ Inc( PAB );
+ end;
+ if N > 0 then
+ begin
+ if Idx < 0 then
+ Perform( TB_ADDBUTTONS, N, Integer( @AB[ 0 ] ) )
+ else
+ Perform( TB_INSERTBUTTON, Idx, Integer( @AB[ 0 ] ) );
+ end;
+ if AB <> nil then
+ FreeMem( AB );
+ end;
+begin
+ if High( Buttons ) < 0 then
+ Result := -1
+ else
+ Result := AddInsButtons;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.TBAddButtons(const Buttons: array of PKOLChar;
+ const BtnImgIdxArray: array of Integer): Integer;
+begin
+ Result := TBAddInsButtons( -1, Buttons, BtnImgIdxArray );
+end;
+{$ENDIF PAS_VERSION}
+
+function TControl.TBInsertButtons(BeforeIdx: Integer;
+ Buttons: array of PKOLChar; const BtnImgIdxArray: array of Integer): Integer;
+var I, J, K: Integer;
+begin
+ J := -1;
+ Result := -1;
+ for I := 0 to High( Buttons ) do
+ begin
+ if I <= High( BtnImgIdxArray ) then
+ J := BtnImgIdxArray[ I ]
+ else
+ if J >= 0 then Inc( J );
+ K := TBAddInsButtons( BeforeIdx, [ Buttons[ I ], '' ], [ J ] );
+ if Result < 0 then Result := K;
+ end;
+end;
+
+function GetTBBtnGoodID( Toolbar: PControl; BtnIDorIdx: Integer ): Integer;
+// change by Alexander Pravdin (to fix toolbar with separator first):
+var Btn1st, i: Integer; btn: TTBButton;
+begin
+ Result := BtnIDorIdx;
+ Btn1st := 0;
+ for i := 0 to Toolbar.TBButtonCount - 1 do begin
+ Toolbar.Perform( TB_GETBUTTON, i, Integer( @btn ) );
+ if btn.fsStyle <> TBSTYLE_SEP then begin
+ Btn1st := i;
+ Break;
+ end;
+ end;
+ if Result < Toolbar.TBIndex2Item( Btn1st ) then
+ Result := Toolbar.TBIndex2Item( Result );
+end;
+
+type
+ TTBButtonEvent = packed Record
+ BtnID: DWORD;
+ Event: TOnToolbarButtonClick;
+ end;
+ PTBButtonEvent = ^TTBButtonEvent;
+
+procedure TControl.TBFreeTBevents;
+begin
+ DF.fTBevents.Release;
+end;
+
+function WndProcToolbarButtonsClicks( TB: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var Notify: PTBNotify;
+ I: Integer;
+ Event: PTBButtonEvent;
+begin
+ Result := FALSE;
+ if Msg.message = WM_NOTIFY then
+ begin
+ Notify := Pointer( Msg.lParam );
+ if Notify.hdr.code = NM_CLICK then
+ begin
+ for I := TB.DF.fTBevents.fCount-1 downto 0 do
+ begin
+ Event := TB.DF.fTBevents.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ];
+ if Integer( Event.BtnID ) = Notify.iItem then
+ begin
+ if Assigned( Event.Event ) then
+ begin
+ TB.RefInc;
+ Rslt := DefWindowProc( Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam );
+ Event.Event( TB, Event.BtnID );
+ TB.RefDec;
+ Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ break;
+ end;
+ end;
+ end;
+ end;
+end;
+
+procedure TControl.TBAssignEvents(BtnID: Integer;
+ Events: array of TOnToolbarButtonClick);
+var I: Integer;
+ EventRec: PTBButtonEvent;
+begin
+ if DF.fTBevents = nil then
+ begin
+ DF.fTBevents := NewList;
+ Add2AutoFreeEx( TBFreeTBevents );
+ AttachProc( WndProcToolbarButtonsClicks );
+ end;
+ BtnID := GetTBBtnGoodID( @Self, BtnID );
+ for I := 0 to High( Events ) do
+ begin
+ GetMem( EventRec, Sizeof( TTBButtonEvent ) );
+ DF.fTBevents.Add( EventRec );
+ EventRec.Event := Events[ I ];
+ EventRec.BtnID := BtnID;
+ Inc( BtnID );
+ end;
+end;
+
+function TControl.TBBtnEvent( Idx: Integer ): TOnToolbarButtonClick;
+var EventRec: PTBButtonEvent;
+begin
+ Result := nil;
+ if DF.fTBevents = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Idx < DF.fTBevents.Count then
+ begin
+ EventRec := DF.fTBevents.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}
+ [ Idx ];
+ Result := EventRec.Event;
+ end;
+end;
+
+procedure TControl.TBResetImgIdx( BtnID, BtnCount: Integer );
+begin
+ while BtnCount > 0 do
+ begin
+ TBButtonImage[ BtnID ] := -2;
+ Inc( BtnID );
+ Dec( BtnCount );
+ end;
+end;
+
+function TControl.TBGetButtonVisible(BtnID: Integer): Boolean;
+begin
+ Result := Perform( TB_ISBUTTONHIDDEN, GetTBBtnGoodID( @ Self, BtnID ), 0 ) = 0;
+end;
+
+function TControl.TBItem2Index(BtnID: Integer): Integer;
+begin
+ Result := Perform( TB_COMMANDTOINDEX, BtnID, 0 );
+end;
+
+procedure TControl.TBSetButtonVisible(BtnID: Integer;
+ const Value: Boolean);
+begin
+ BtnID := GetTBBtnGoodID( @Self, BtnID );
+ Perform( TB_HIDEBUTTON, BtnID, Integer( not Value ) );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean;
+begin
+ BtnID := GetTBBtnGoodID( @Self, BtnID );
+ Result := Perform( Index + 8, BtnID, 0 ) <> 0;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.TBSetBtnStt(BtnID: Integer; const Index: Integer; const Value: Boolean);
+begin
+ BtnID := GetTBBtnGoodID( @Self, BtnID );
+ Perform( Index, BtnID, Integer( Value ) );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.TBIndex2Item(Idx: Integer): Integer;
+var ButtonInfo: TTBButton;
+begin
+ Result := -1;
+ if Perform( TB_GETBUTTON, Idx, Integer( @ButtonInfo ) ) <> 0 then
+ Result := ButtonInfo.idCommand;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.TBConvertIdxArray2ID(const IdxVars: array of PDWORD);
+var i: Integer;
+begin
+ for i := 0 to High( IdxVars ) do
+ IdxVars[ i ]^ := TBIndex2Item( IdxVars[ I ]^ );
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+function TControl.TBGetButtonText( BtnID: Integer ): KOLString;
+var Buffer: array[ 0..1023 ] of KOLChar;
+begin
+ BtnID := GetTBBtnGoodID( @Self, BtnID );
+ if Perform( TB_GETBUTTONTEXT, BtnID, Integer( @Buffer[ 0 ] ) ) > 0 then
+ Result := Buffer
+ else
+ Result := '';
+end;
+{$ENDIF PAS_VERSION}
+
+function TControl.TBGetButtonRect(BtnID: Integer): TRect;
+begin
+ BtnID := GetTBBtnGoodID( @Self, BtnID );
+ Perform( TB_GETITEMRECT, TBItem2Index( BtnID ), Integer( @Result ) );
+end;
+
+function ToolbarButtonRect( Toolbar: PControl; BtnID: Integer ): TRect;
+begin
+ Result := Toolbar.TBGetButtonRect(BtnID);
+end;
+
+function TControl.TBGetRows: Integer;
+begin
+ Result := 1;
+ UpdateWndStyles;
+ if (TBSTYLE_WRAPABLE and fStyle.Value) <> 0 then
+ Result := Perform( TB_GETROWS, 0, 0 );
+end;
+
+procedure TControl.TBSetRows(const Value: Integer);
+begin
+ Perform( TB_SETROWS, Value, 0 );
+end;
+
+function TControl.TBMoveBtn(FromIdx, ToIdx: Integer): Boolean;
+var btn: TTBButton;
+begin
+ Perform(TB_GETBUTTON,FromIdx,integer(@btn));
+ Result := Perform(TB_DELETEBUTTON,FromIdx,0) <> 0;
+ if Result then
+ Perform(TB_INSERTBUTTON,ToIdx,integer(@btn));
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.TBSetTooltips(BtnID1st: Integer;
+ const Tooltips: array of PKOLChar);
+var I, J: Integer;
+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:= 0 to High( Tooltips ) do
+ begin
+ J := DF.fTBttCmd.IndexOf( Pointer( BtnID1st ) );
+ if J < 0 then
+ begin
+ DF.fTBttCmd.Add( Pointer( BtnID1st ) );
+ DF.fTBttTxt.Add( Tooltips[ I ] );
+ end
+ else
+ DF.fTBttTxt.Items[ J ] := Tooltips[ I ];
+ Inc( BtnID1st );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function TControl.TBBtnTooltip( BtnID: Integer ): KOLString;
+var J: Integer;
+begin
+ Result := '';
+ if DF.fTBttCmd = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ J := DF.fTBttCmd.IndexOf( Pointer( BtnID ) );
+ if J < 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := DF.fTBttTxt.Items[ J ];
+end;
+
+procedure ToolbarSetTooltips( Toolbar: PControl; BtnID1st: Integer;
+ const Tooltips: array of PKOLChar );
+begin
+ Toolbar.TBSetTooltips( BtnID1st, Tooltips );
+end;
+
+function ToolbarButtonEnabled( Toolbar: PControl; BtnID: Integer ): Boolean;
+begin
+ Result := Toolbar.TBButtonEnabled[ BtnID ];
+end;
+
+procedure EnableToolbarButton( Toolbar: PControl; BtnID: Integer; Enable: Boolean );
+begin
+ Toolbar.TBButtonEnabled[ BtnID ] := Enable;
+end;
+
+function ToolbarButtonVisible( Toolbar: PControl; BtnID: Integer ): Boolean;
+begin
+ Result := Toolbar.TBButtonVisible[ BtnID ];
+end;
+
+procedure ShowHideToolbarButton( Toolbar: PControl; BtnID: Integer; Show: Boolean );
+begin
+ Toolbar.TBButtonVisible[ BtnID ] := Show;
+end;
+
+function ToolbarButtonChecked( Toolbar: PControl; BtnID: Integer): Boolean;
+begin
+ Result := Toolbar.TBButtonChecked[ BtnID ];
+end;
+
+procedure ToolbarButtonSetChecked( Toolbar: PControl; BtnID: Integer; Checked: Boolean );
+begin
+ Toolbar.TBButtonChecked[ BtnID ] := Checked;
+end;
+
+procedure ToolbarAddButtons( Toolbar: PControl; const Buttons: array of PKOLChar;
+ const BtnImgIdxArray: array of Integer; Bitmap: HBitmap );
+begin
+ Toolbar.TBAddButtons( Buttons, BtnImgIdxArray );
+ if Bitmap <> 0 then
+ Toolbar.TBAddBitmap( Bitmap );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.TBButtonAtPos(X, Y: Integer): Integer;
+var I: Integer;
+begin
+ I := TBBtnIdxAtPos( X, Y );
+ if I >= 0 then
+ I := TBIndex2Item( I );
+ Result := I;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.TBBtnIdxAtPos(X, Y: Integer): Integer;
+var I: Integer;
+ R: TRect;
+ P: TPoint;
+begin
+ P := MakePoint( X, Y );
+ for I := TBButtonCount - 1 downto 0 do
+ begin
+ Perform( TB_GETITEMRECT, I, Integer( @R ) );
+ if PointInRect( P, R ) then
+ begin
+ Result := I; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ Result := -1;
+end;
+{$ENDIF PAS_VERSION}
+
+function TControl.TBButtonSeparator(BtnID: Integer): Boolean;
+var B: TTBButton;
+begin
+ Perform( TB_GETBUTTON, TBItem2Index( GetTBBtnGoodID( @Self, BtnID )
+), Integer( @B ) ) ;
+ Result := B.fsStyle = TBSTYLE_SEP;
+end;
+
+procedure TControl.TBDeleteButton(BtnID: Integer);
+begin
+ BtnID := GetTBBtnGoodID( @Self, BtnID );
+ Perform( TB_DELETEBUTTON, TBItem2Index( BtnID ), 0 );
+end;
+
+procedure TControl.TBDeleteBtnByIdx(Idx: Integer);
+begin
+ Perform( TB_DELETEBUTTON, Idx, 0 );
+end;
+
+procedure TControl.TBClear;
+var
+ i: Integer;
+begin
+ for i := 0 to Pred(TBButtonCount) do
+ TBDeleteBtnByIdx(0);
+end;
+
+procedure TControl.Clear;
+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 ) ), Integer( @B ) );
+ Result := B.iBitmap;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.TBSetBtnImgIdx(BtnID: Integer; const Value: Integer);
+begin
+ Perform( TB_CHANGEBITMAP, GetTBBtnGoodID( @Self, BtnID ), Value );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.TBSetButtonText(BtnID: Integer; const Value: KOLString);
+var BI: TTBButtonInfo;
+begin
+ BtnID := GetTBBtnGoodID( @Self, BtnID );
+ BI.cbSize := Sizeof( BI );
+ BI.dwMask := TBIF_TEXT;
+ BI.pszText := PKOLChar( Value );
+ Perform( TB_SETBUTTONINFO, BtnID, Integer( @BI ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.TBGetBtnWidth(BtnID: Integer): Integer;
+var R: TRect;
+begin
+ R := TBButtonRect[ BtnID ];
+ Result := R.Right - R.Left;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.TBSetBtnWidth(BtnID: Integer; const Value: Integer);
+var BI: TTBButtonInfo;
+begin
+ BI.cbSize := Sizeof( BI );
+ BI.dwMask := TBIF_SIZE or TBIF_STYLE;
+ BtnID := GetTBBtnGoodID( @Self, BtnID );
+ Perform( TB_GETBUTTONINFO, BtnID, Integer( @BI ) );
+ BI.cx := Value;
+ BI.fsStyle := BI.fsStyle and not TBSTYLE_AUTOSIZE;
+ Perform( TB_SETBUTTONINFO, BtnID, Integer( @BI ) );
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.TBSetBtMinMaxWidth(const Idx: Integer; const Value: Integer);
+begin
+ case Idx of
+ 0: DF.fTBBtMinWidth := Value;
+ 1: DF.fTBBtMaxWidth := Value;
+ end;
+ Perform( TB_SETBUTTONWIDTH, 0, DF.fTBBtMaxWidth or (DF.fTBBtMinWidth shl 16) );
+end;
+
+{$IFDEF F_P}
+function TControl.TBGetBtMinMaxWidth(const Idx: Integer): Integer;
+begin
+ CASE Idx OF
+ 0: Result := FTBBtMinWidth;
+ 1: Result := FTBBtMaxWidth;
+ END;
+end;
+{$ENDIF F_P}
+
+function TControl.TBGetButtonLParam(const Idx: Integer): DWORD;
+var
+ tb: TTBButtonInfo;
+begin
+ tb.cbSize := sizeof(tb);
+ tb.dwMask := TBIF_BYINDEX or TBIF_LPARAM;
+ Perform(TB_GETBUTTONINFO, Idx, Integer(@tb));
+ Result := tb.lParam;
+end;
+
+procedure TControl.TBSetButtonLParam(const Idx: Integer; const Value: DWORD);
+var
+ tb: TTBButtonInfo;
+begin
+ tb.cbSize := sizeof(tb);
+ tb.dwMask := TBIF_BYINDEX or TBIF_LPARAM;
+ tb.lParam := Value;
+ Perform(TB_SETBUTTONINFO, Idx, Integer(@tb));
+end;
+
+function WndProcTBCustomDraw( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var CD: PNMTBCustomDraw;
+ Br: HBrush;
+begin
+ Result := FALSE;
+ if Msg.message = WM_NOTIFY then
+ begin
+ CD := Pointer( Msg.lParam );
+ if CD.nmcd.hdr.code = NM_CUSTOMDRAW then
+ begin
+ if Assigned( Sender.DF.fOnTBCustomDraw ) then
+ Rslt := Sender.DF.fOnTBCustomDraw( Sender, CD^ )
+ else
+ begin
+ if Sender.fBrush <> nil then
+ Windows.FillRect( CD.nmcd.hdc, Sender.ClientRect, Sender.fBrush.Handle )
+ else
+ begin
+ Br := CreateSolidBrush( Color2RGB( Sender.Color ) );
+ Windows.FillRect( CD.nmcd.hdc, Sender.ClientRect, Br );
+ DeleteObject( Br );
+ end;
+ Rslt := CDRF_SKIPDEFAULT;
+ end;
+ end;
+ end;
+end;
+
+procedure TControl.SetOnTBCustomDraw( const Value: TOnTBCustomDraw );
+begin
+ DF.fOnTBCustomDraw := Value;
+ AttachProc( WndProcTBCustomDraw );
+end;
+
+
+procedure TControl.SetDroppedDown(const Value: Boolean);
+begin
+ Perform( CB_SHOWDROPDOWN, Integer( Value ), 0 );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.AddDirList(const Filemask: KOLString; Attrs: DWORD);
+begin
+ if fCommandActions.aDir <> 0 then
+ Perform( fCommandActions.aDir, Attrs, Integer( PKOLChar( Filemask ) ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_noVERSION}
+{$ELSE PAS_VERSION} //Pascal
+function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+//var Accept: Boolean; // {Alexander Pravdin, AP}
+begin
+ Result := FALSE;
+ if Msg.message = WM_CLOSE then
+ begin
+ if Self_.DF.fModalResult = 0 then { (Sergey Shishmintzev) }
+ Self_.DF.fModalResult := -1;
+ Rslt := 0;
+ Result := True; // Do not process !
+ end
+ ;
+end;
+{$ENDIF PAS_VERSION}
+
+// by TR"]F
+function WndProcFixModal( Self_: PControl; var Msg: TMsg; var Rslt:
+Integer ): Boolean;
+const HTERROR = $FFFE;
+ LBtnDown = $201;
+ LBtnUp = $202;
+ RBtnDown = $204;
+ RBtnUp = $205;
+ WeelDown = $207;
+ WeelUp = $208;
+{$IFDEF MODAL_ACTIVATE_FIX}
+var i: Integer;
+ C: PControl;
+{$ENDIF MODAL_ACTIVATE_FIX}
+begin
+ Result := false;
+ if (Msg.message = WM_SETCURSOR) then
+ if (LoWord(Msg.lParam) = HTERROR) then
+ if (HiWord(Msg.lParam) >= LBtnDown) and
+ (HiWord(Msg.lParam) <= RBtnUp) then
+ begin
+ if Applet.DF.fModalForm <> nil then
+ SetForegroundWindow(Applet.DF.fModalForm.Handle);
+ Rslt := 1;
+ Result := TRUE;
+ end;
+
+ {$IFDEF MODAL_ACTIVATE_FIX}
+ if (Msg.message = WM_ACTIVATEAPP) then
+ begin
+ if not Applet.DF.fActivating then
+ begin
+ Applet.DF.fActivating := TRUE;
+ if Msg.wParam <> 0 then
+ begin
+ for i := Applet.ChildCount-1 downto 0 do
+ begin
+ C := Applet.Children[ i ];
+ if C.Visible and not C.Enabled then
+ SetForegroundWindow( C.Handle );
+ end;
+ if Applet.DF.fModalForm <> nil then
+ SetForegroundWindow( Applet.DF.fModalForm.Handle );
+ end;
+ Applet.DF.fActivating := FALSE;
+ end;
+ end;
+ {$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
+ Result := ShowModalParented(Applet);
+end;
+{$ELSE not USE_SHOWMODALPARENTED_ALWAYS}
+function TControl.ShowModal: Integer;
+var FL: PList;
+var CurForm: PControl;
+ I: Integer;
+ F: PControl;
+ CurCtl: PControl; // { Alexander Pravdin }
+begin
+ Result := 0;
+ if {$IFDEF USE_FLAGS} (G3_IsControl in fFlagsG3)
+ {$ELSE} (fIsControl) {$ENDIF}
+ or (fParent = nil) then
+ begin
+ Show; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ AttachProc( WndProcShowModal );
+ CurForm := Applet.DF.fCurrentControl;
+ FL := NewList;
+ CurCtl := nil; // { Alexander Pravdin }
+
+ if Applet.IsApplet then
+ begin
+ for I := 0 to Applet.ChildCount - 1 do
+ begin
+ F := Applet.fChildren.Items[ I ];
+ if F <> @Self then
+ if F.Enabled then
+ begin
+ FL.Add( F );
+ F.Enabled := FALSE;
+ {$IFNDEF NOT_FIX_MODAL}
+ Inc( F.DF.fFixingModal );
+ F.AttachProc(WndProcFixModal); {**************}
+ {$ENDIF}
+ end;
+ end
+ end
+ else
+ begin
+ CurForm := Applet;
+ if Applet.Enabled then
+ 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;
+
+ Inc( DF.fModal );
+ Applet.DF.fModalForm := @ Self;
+ Enabled := TRUE;
+
+ ModalResult := 0;
+ Show;
+ while not AppletTerminated and (ModalResult = 0) do
+ begin
+ WaitMessage;
+ Applet.ProcessMessages;
+ {$IFDEF USE_OnIdle}
+ ProcessIdle( @Self );
+ {$ENDIF}
+ end;
+
+ Dec( DF.fModal );
+ Applet.DF.fModalForm := nil;
+
+ 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;
+
+ if CurForm <> nil then
+ PostMessage( CurForm.Handle, WM_ACTIVATE, WA_ACTIVE, 0 );
+ if CurCtl <> nil then CurCtl.SetFocused( TRUE ); { Alexander Pravdin }
+
+ Result := ModalResult;
+end;
+{$ENDIF USE_SHOWMODALPARENTED_ALWAYS}
+{$ENDIF PAS_VERSION}
+
+{$IFNDEF NEW_MODAL}
+function TControl.ShowModalParented( const AParent: PControl ): Integer;
+begin
+ Result := 0;
+end;
+{$ELSE NEW_MODAL defined}
+function TControl.ShowModalParented( const AParent: PControl ): Integer;
+var
+ FL: PList;
+ OldMF, F: PControl;
+ I: Integer;
+begin
+ Result := 0;
+ if ( AParent = nil ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Inc( DF.fModal );
+ FL := NewList;
+ OldMF := AParent.DF.fModalForm;
+ AParent.DF.fModalForm := @Self;
+ if {$IFDEF USE_FLAGS} (G3_IsApplet in AParent.fFlagsG3)
+ {$ELSE} AParent.fIsApplet {$ENDIF}
+ or ( AParent.IsMainWindow and
+ {$IFDEF USE_FLAGS} (G3_IsForm in AParent.fFlagsG3)
+ {$ELSE} AParent.fIsForm {$ENDIF} ) then
+ begin
+ for I := 0 to AParent.ChildCount - 1 do
+ begin
+ F := AParent.fChildren.Items[ I ];
+ if ( F <> @Self )
+ and {$IFDEF USE_FLAGS} (G3_IsForm in F.fFlagsG3)
+ {$ELSE} F.fIsForm {$ENDIF}
+ and {$IFDEF USE_FLAGS}
+ not(F3_Disabled in F.fStyle.f3_Style) and
+ (F3_Visible in F.fStyle.f3_Style)
+ {$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;
+
+ if {$IFDEF USE_FLAGS} (G3_IsForm in AParent.fFlagsG3)
+ {$ELSE} AParent.fIsForm {$ENDIF}
+ and {$IFDEF USE_FLAGS} not(F3_Disabled in AParent.fStyle.f3_Style)
+ {$ELSE} AParent.Enabled {$ENDIF} then
+ begin
+ FL.Add( AParent );
+ AParent.Enabled := FALSE;
+ end;
+
+ ModalResult := 0;
+ Show;
+ while not AppletTerminated and ( ModalResult = 0 ) do
+ begin
+ WaitMessage;
+ AParent.ProcessMessages;
+{$IFDEF USE_OnIdle}
+ ProcessIdle( @Self );
+{$ENDIF}
+ end;
+
+ AParent.DF.fModalForm := OldMF;
+ Dec( DF.fModal );
+ for I := 0 to FL.Count - 1 do
+ begin
+ F := PControl( FL.Items[ I ] );
+ F.Enabled := True;
+ {$IFNDEF NOT_FIX_MODAL}
+ F.DetachProc(WndProcFixModal); {**************}
+ {$ENDIF}
+ end;
+ FL.Free;
+ Hide;
+ Result := ModalResult;
+end;
+{$ENDIF NEW_MODAL}
+
+function DisableWindows( W: hwnd; LPARAM: Integer ): Bool; stdcall;
+var FL: PList;
+ Buf: Array[ 0..127 ] of AnsiChar;
+begin
+ FL := Pointer( LPARAM );
+ if IsWindowEnabled( W ) and (W <> FL.Tag) then
+ begin
+ GetClassName( W, @ Buf[ 0 ], Sizeof( Buf ) );
+ if Buf <> 'ComboLBox' then
+ begin
+ FL.Add( Pointer( W ) );
+ EnableWindow( W, FALSE );
+ end;
+ end;
+ Result := TRUE;
+end;
+
+function TControl.ShowModalEx: Integer;
+var FL: PList;
+var CurForm: PControl;
+ I: Integer;
+ W: HWnd;
+ CurCtl: PControl; { Alexander Pravdin }
+begin
+ Result := 0;
+ if {$IFDEF USE_FLAGS} (G3_IsControl in fFlagsG3)
+ {$ELSE} (fIsControl) {$ENDIF}
+ or (fParent = nil) then
+ begin
+ Show; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ AttachProc( WndProcShowModal );
+ CurForm := Applet.DF.fCurrentControl;
+ FL := NewList;
+ FL.Tag := fHandle;
+ // ++++ { Alexander Pravdin }
+ if {$IFDEF USE_FLAGS} not(G3_IsApplet in Applet.fFlagsG3)
+ {$ELSE} not Applet.fIsApplet {$ENDIF} then
+ CurCtl := Applet.DF.fCurrentControl
+ else CurCtl := nil;
+ // ----
+ CreateWindow;
+
+ EnumThreadWindows( GetCurrentThreadID, @ DisableWindows, Integer( FL ) );
+ Enabled := TRUE;
+
+ Inc( DF.fModal );
+ Applet.DF.fModalForm := @ Self;
+ Show;
+ DF.fModalResult := 0;
+ while not AppletTerminated and (DF.fModalResult = 0) do
+ begin
+ WaitMessage;
+ Applet.ProcessMessages;
+ {$IFDEF USE_OnIdle}
+ ProcessIdle( @Self );
+ {$ENDIF}
+ end;
+
+ Dec( DF.fModal );
+ Applet.DF.fModalForm := @ Self;
+
+ DetachProc( WndProcShowModal );
+
+ for I := 0 to FL.Count - 1 do
+ begin
+ W := THandle( FL.Items[ I ] );
+ EnableWindow( W, TRUE );
+ end;
+ FL.Free;
+
+ if CurForm <> nil then
+ PostMessage( CurForm.Handle, WM_ACTIVATE, WA_ACTIVE, 0 );
+ if CurCtl <> nil then CurCtl.SetFocused( True ); { Alexander Pravdin }
+ Result := ModalResult;
+end;
+
+function TControl.GetModal: Boolean;
+begin
+ Result := DF.fModal > 0;
+end;
+
+{$IFDEF USE_SETMODALRESULT}
+procedure TControl.SetModalResult( const Value: Integer );
+begin
+ DF.fModalResult := Value;
+ if Value <> 0 then
+ PostMessage( GetWindowHandle, 0, 0, 0 );
+end;
+{$ENDIF}
+
+{$IFNDEF NEW_MENU_ACCELL}
+procedure TControl.DoDestroyAccelTable;
+begin
+ if fAccelTable <> 0 then
+ begin
+ DestroyAcceleratorTable( fAccelTable );
+ fAccelTable := 0;
+ end;
+end;
+{$ENDIF}
+
+{$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION control_clicked( Obj: PGtkWidget; Sender: PControl ): Boolean; cdecl;
+BEGIN
+ IF Assigned( Sender.fOnClick ) THEN
+ Sender.fOnClick( Sender );
+ Result := FALSE;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+procedure TControl.SetOnClick( const Value: TOnEvent );
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnClick := Value;
+ {$IFDEF GTK}
+ IF fEventboxHandle = fHandle THEN
+ BEGIN
+ {$IFNDEF SMALLER_CODE}
+ IF NOT Assigned( Value ) THEN
+ gtk_signal_disconnect( GTK_OBJECT( fEventboxHandle ), fClickedEvent )
+ ELSE
+ {$ENDIF SMALLEST_CODE}
+ fClickedEvent := gtk_signal_connect( GTK_OBJECT( fEventboxHandle ), 'clicked',
+ @ control_clicked, @ Self )
+ END ELSE SetMouseEvent( @ Self, 'button_release_event' );
+ {$ENDIF GTK}
+end;
+//////////////////////////////////////////////////////////////////
+// T I M E R
+//////////////////////////////////////////////////////////////////
+
+var {$IFDEF WIN} TimerOwnerWnd: PControl; {$ENDIF} // in Linux, timer not need in a window
+ TimerCount: Integer = 0;
+
+{ -- Constructor of timer -- }
+
+function NewTimer( Interval: Integer ): PTimer;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TTimer';
+ {$ENDIF}
+ if Interval <= 0 then Interval := 1000;
+ Result.fInterval := Interval;
+ Inc( TimerCount );
+end;
+
+{ -- Timer procedure -- }
+
+{$IFDEF WIN}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TimerProc( Wnd : HWnd; Msg : Integer; T : PTimer; CurrentTime : DWord ): Integer;
+ stdcall;
+begin
+ {$IFDEF STOPTIMER_AFTER_APPLETTERMINATED}
+ if not AppletTerminated then
+ {$ENDIF}
+ if Assigned( T.fOnTimer ) then
+ T.fOnTimer( T );
+ Result := 0;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN}
+
+{ TTimer }
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TTimer.Destroy;
+begin
+ Enabled := False;
+ inherited;
+ Dec( TimerCount );
+ {$IFDEF WIN}
+ if TimerCount = 0 then
+ begin
+ TimerOwnerWnd.Free;
+ TimerOwnerWnd := nil;
+ end;
+ {$ENDIF WIN}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF WIN_GDI}
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TTimer.SetEnabled(const Value: Boolean);
+var WasEnabled: Boolean;
+begin
+ WasEnabled := fEnabled;
+ fEnabled := Value;
+ if WasEnabled = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF TIMER_APPLETWND}
+ if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$ENDIF}
+
+ if Value then
+ begin
+ {$IFDEF TIMER_APPLETWND}
+ fHandle := SetTimer( Applet.GetWindowHandle, Integer( @Self ),
+ fInterval, @TimerProc );
+ {$ELSE}
+ if TimerOwnerWnd = nil then
+ begin
+ TimerOwnerWnd := _NewWindowed( nil, '', TRUE,
+ {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS )
+ {$ELSE} nil {$ENDIF} );
+ TimerOwnerWnd.fStyle.Value := 0;
+ {$IFDEF USE_FLAGS} include( TimerOwnerWnd.fFlagsG3, G3_IsControl );
+ {$ELSE} TimerOwnerWnd.fIsControl := TRUE; {$ENDIF}
+ end;
+ fHandle := SetTimer( TimerOwnerWnd.GetWindowHandle, Integer( @Self ),
+ fInterval, @TimerProc );
+ {$ENDIF}
+ end
+ else
+ begin
+ if fHandle <> 0 then
+ begin
+ KillTimer( {$IFDEF TIMER_APPLETWND} Applet.fHandle
+ {$ELSE} TimerOwnerWnd.fHandle {$ENDIF}, fHandle );
+ fHandle := 0;
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF WIN_GDI}
+
+{$IFDEF _X_}
+{$IFDEF GTK}
+FUNCTION TimerGTKTick( Sender: Pointer ): LONGBOOL; cdecl;
+BEGIN
+ IF NOT PTimer( Sender ).fEnabled THEN Result := FALSE
+ ELSE
+ BEGIN
+ IF Assigned( PTimer( Sender ).fOnTimer ) THEN
+ Ptimer( Sender ).fOnTimer( Sender );
+ Result := PTimer( Sender ).fEnabled;
+ END;
+ IF Result THEN
+ PTimer( Sender ).RefDec;
+END;
+
+PROCEDURE TTimer.SetEnabled(const Value: Boolean);
+BEGIN
+ IF FEnabled = Value THEN Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fEnabled := Value;
+ IF Value THEN
+ BEGIN
+ RefInc;
+ fHandle := gtk_timeout_add( fInterval, TimerGTKTick, @ Self );
+ END ELSE
+ BEGIN
+ IF AppletTerminated THEN
+ BEGIN
+ gtk_timeout_remove( fHandle );
+ RefDec;
+ END;
+ END;
+END;
+{$ELSE not GTK}
+VAR fActiveTimerList: PTimer;
+ fClockPerSecond: Integer;
+ fAlarmHandling: Boolean;
+
+PROCEDURE SetAlarm; FORWARD;
+
+PROCEDURE AlarmHandler(SigNum: Integer); CDECL;
+VAR T, NT: PTimer;
+ c: Integer;
+ count_handled: Integer;
+BEGIN
+ c := clock;
+ fAlarmHandling := TRUE; // to prevent SetAlarm working while timers are handling
+ TRY
+ //--- 1. Clear fTimerHandled flag for all active timers
+ T := fActiveTimerList;
+ WHILE T <> nil DO
+ BEGIN
+ T.fTimerHandled := FALSE;
+ T := T.fNext;
+ END;
+ //--- 2. Handle all expired timers
+ count_handled := 0;
+ WHILE not AppletTerminated DO // until all timers expired are handled or
+ BEGIN // until the application is terminated
+ //--- 2.A. Search a timer which was expired before all others
+ T := fActiveTimerList;
+ NT := nil;
+ WHILE T <> nil do
+ BEGIN
+ IF not T.fTimerHandled and (
+ (NT = nil) or ((T.fExpireNext - c) < (NT.fExpireNext - c))
+ ) THEN
+ NT := T;
+ T := T.fNext;
+ END;
+ IF NT = nil then break; // there are no more timers expired
+ IF (count_handled > 0) and
+ ((NT.fExpireNext - c > 0) or (NT.fExpireNext < 0) and (c > 0)) then break;
+ //--- 2.B. Handle found timer (NT)
+ inc( count_handled ); // count handled timer to ensure that at least 1 timer
+ // was handled in result of alarm call
+ {$IFDEF SUPPORT_LONG_TIMER}
+ NT.fExpireTotal := NT.fExpireTotal - (c - NT.fTimeStart);
+ IF NT.fExpireTotal > 30 * 60 * fClockPerSecond then
+ NT.fExpireNext := c + 30 * 60 * fClockPerSecond
+ ELSE
+ NT.fExpireNext := c + NT.fExpireTotal;
+ {$ELSE not SUPPORT_LONG_TIMER}
+ NT.fExpireNext := // next time to expire this timer
+ NT.fExpireNext + fClockPerSecond * NT.fInterval;
+ {$ENDIF SUPPORT_LONG_TIMER}
+ NT.fTimerHandled := TRUE; // do not handle that timer again in that loop
+ {$IFDEF SUPPORT_LONG_TIMER}
+ IF NT.fExpireTotal <= 0 then
+ {$ENDIF SUPPORT_LONG_TIMER}
+ BEGIN IF NT.fMultimedia and not NT.fPeriodic then
+ NT.Enabled := FALSE; // one-shot timer, disable it now
+ IF Assigned( NT.fOnTimer ) then
+ NT.fOnTimer( NT ); // in result of this action, timer NT or any
+ // other active timer can be disabled and dropped from
+ // fActiveTimerList and any amount of previously disabled timers
+ // can be added
+ END;
+ END;
+ FINALLY
+ fAlarmHandling := FALSE;
+ END;
+ // 3. finally, install the next alarm to the nearest expirating timer if any
+ SetAlarm;
+END;
+
+PROCEDURE SetAlarm;
+VAR i: Integer;
+ T, NT: PTimer;
+ TV: itimerval;
+ c: clock_t;
+BEGIN
+ IF AppletTerminated then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ // if the application is terminated we do not install alarms
+ IF fAlarmHandling then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ // while alarm is handling do not reinstall alarms
+ c := clock;
+ T := fActiveTimerList;
+ NT := T;
+ WHILE T <> nil do
+ BEGIN
+ if (T.fExpireNext - c) < (NT.fExpireNext - c) then
+ NT := T;
+ T := T.fNext;
+ END;
+ IF NT = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ i := (NT.fExpireNext - c) * 1000 div fClockPerSecond;
+ IF i < 0 then i := 10; // 10 milliseconds as minimum time to alarm
+ TV.it_interval.tv_sec := 0; // set interval to alarm once
+ TV.it_interval.tv_usec := 0;
+ TV.it_value.tv_sec := i div 1000; // set time to alarm next time
+ TV.it_value.tv_usec := (i mod 1000) * 1000;
+ signal( SIGALRM, AlarmHandler );
+ setitimer( ITIMER_REAL, TV, nil );
+END;
+
+PROCEDURE TTimer.SetEnabled(const Value: Boolean);
+BEGIN
+ IF FEnabled = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fEnabled := Value;
+ IF Value then
+ BEGIN
+ IF fClockPerSecond = 0 then
+ fClockPerSecond := CLK_TCK;
+ fExpireTotal := Int64( fClockPerSecond ) * fInterval;
+ {$IFDEF SUPPORT_LONG_TIMER}
+ IF fExpireTotal > 30 * 60 * fClockPerSecond then
+ fExpireNext := clock + 30 * 60 * fClockPerSecond
+ ELSE
+ fExpireNext := clock + fExpireTotal;
+ {$ELSE}
+ fExpireNext := clock + fExpireTotal;
+ {$ENDIF SUPPORT_LONG_TIMER}
+ IF fActiveTimerList <> nil then
+ BEGIN
+ fNext := fActiveTimerList;
+ fActiveTimerList.fPrev := @ Self;
+ END;
+ fActiveTimerList := @ Self;
+ END ELSE
+ BEGIN
+ IF fPrev <> nil then fPrev.fNext := fNext;
+ IF fNext <> nil then fNext.fPrev := fPrev;
+ IF fActiveTimerList = @ Self then
+ fActiveTimerList := fNext;
+ fPrev := nil;
+ fNext := nil;
+ end;
+ if fActiveTimerList <> nil then
+ SetAlarm; // set alarm to the nearest expiring timer
+END;
+{$ENDIF not GTK}
+{$ENDIF _X_}
+
+procedure TTimer.SetInterval(const Value: Integer);
+var WasEnabled : Boolean;
+begin
+ if fInterval = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fInterval := Value;
+ WasEnabled := Enabled;
+ Enabled := False;
+ Enabled := WasEnabled {$IFDEF STOPTIMER_AFTER_APPLETTERMINATED}
+ and not AppletTerminated
+ {$ENDIF};
+end;
+
+{$IFDEF WIN}
+{ TMMTimer }
+
+{ ------------ declarations moved here from MMSystem -------------------- }
+const
+ TIME_ONESHOT = 0; { program timer for single event }
+ TIME_PERIODIC = 1; { program for continuous periodic event }
+ TIME_CALLBACK_FUNCTION = $0000; { callback is function }
+ TIME_CALLBACK_EVENT_SET = $0010; { callback is event - use SetEvent }
+ TIME_CALLBACK_EVENT_PULSE = $0020; { callback is event - use PulseEvent }
+
+type
+ TFNTimeCallBack = procedure(uTimerID, uMessage: UINT;
+ dwUser, dw1, dw2: DWORD) stdcall;
+function timeSetEvent(uDelay, uResolution: UINT;
+ lpFunction: TFNTimeCallBack; dwUser: DWORD; uFlags: UINT): THandle; stdcall;
+ external 'winmm.dll' name 'timeSetEvent';
+function timeKillEvent(uTimerID: UINT): Integer; stdcall;
+ external 'winmm.dll' name 'timeKillEvent';
+{ ----------------------------------------------------------------------- }
+
+procedure MMTimerCallback(uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD);
+ stdcall;
+var MMTimer: PMMTimer;
+begin
+ MMTimer := Pointer( dwUser );
+ if Assigned( MMTimer.FOnTimer ) then
+ MMTimer.fOnTimer( MMTimer );
+end;
+
+function NewMMTimer( Interval: Integer ): PMMTimer;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TMMTimer';
+ {$ENDIF}
+ Result.fInterval := Interval;
+ Result.FPeriodic := TRUE;
+end;
+
+destructor TMMTimer.Destroy;
+begin
+ Enabled := FALSE;
+ Inc( TimerCount );
+ inherited;
+end;
+
+procedure TMMTimer.SetEnabled(const Value: Boolean);
+begin
+ if Value xor (fHandle <> 0) then
+ begin
+ if fHandle = 0 then
+ fHandle := timeSetEvent( Interval, Resolution, MMTimerCallback, DWORD( @ Self ),
+ Integer( Periodic ) or TIME_CALLBACK_FUNCTION )
+ else
+ begin
+ timeKillEvent( fHandle );
+ fHandle := 0;
+ end;
+ end;
+ fEnabled := Value;
+end;
+{$ENDIF WIN}
+{$IFDEF LIN}
+function NewMMTimer( Interval: Integer ): PTimer;
+begin
+ Result := NewTimer( Interval );
+ {$IFNDEF GTK}
+ {$IFNDEF QT}
+ Result.fMultimedia := TRUE;
+ Result.fPeriodic := TRUE;
+ Result.fResolution := 1;
+ {$ENDIF QT}
+ {$ENDIF GTK}
+end;
+{$ENDIF LIN}
+
+{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
+////////////////////////////////////////////////////////////////////////
+// t B I T M A P
+///////////////////////////////////////////////////////////////////////
+
+{ -- bitmap -- }
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo;
+begin
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( W > 0, 'Width must be >0' );
+ Assert( H > 0, 'Height must be >0' );
+ {$ENDIF KOL_ASSERTIONS}
+ Result := AllocMem( 256*Sizeof(TRGBQuad)+Sizeof(TBitmapInfoHeader) );
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( Result <> nil, 'No memory' );
+ {$ENDIF KOL_ASSERTIONS}
+ Result.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );
+ Result.bmiHeader.biWidth := W;
+ Result.bmiHeader.biHeight := H; // may be, -H ?
+ Result.bmiHeader.biPlanes := 1;
+ Result.bmiHeader.biBitCount := BitsPerPixel;
+end;
+{$ENDIF PAS_VERSION}
+
+const
+ BitsPerPixel_By_PixelFormat: array[ TPixelFormat ] of Byte =
+ ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat;
+var I: TPixelFormat;
+begin
+ for I := High(I) downto Low(I) do
+ if BitsPerPixel = BitsPerPixel_By_PixelFormat[ I ] then
+ begin
+ Result := I; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := pfDevice;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure DummyDetachCanvas( Sender: PBitmap );
+begin
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewBitmap( W, H: Integer ): PBitmap;
+var DC: HDC;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TBitmap';
+ {$ENDIF}
+ Result.fHandleType := bmDDB;
+ Result.fDetachCanvas := DummyDetachCanvas;
+ Result.fWidth := W;
+ Result.fHeight := H;
+ if (W <> 0) and (H <> 0) then
+ begin
+ DC := GetDC( 0 );
+ Result.fHandle := CreateCompatibleBitmap( DC, W, H );
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( Result.fHandle <> 0, 'Can not create bitmap handle' );
+ {$ENDIF KOL_ASSERTIONS}
+ ReleaseDC( 0, DC );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+const InitColors: array[ 0..17 ] of DWORD = ( $F800, $7E0, $1F, 0, $800000, $8000,
+ $808000, $80, $800080, $8080, $808080, $C0C0C0, $FF0000, $FF00, $FFFF00, $FF,
+ $FF00FF, $FFFF );
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure PreparePF16bit( DIBHeader: PBitmapInfo );
+begin
+ DIBHeader.bmiHeader.biCompression := BI_BITFIELDS;
+ Move( InitColors[ 0 ], DIBHeader.bmiColors[ 0 ], 19*Sizeof(TRGBQUAD) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap;
+const BitsPerPixel: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
+var BitsPixel: Integer;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TBitmap:DIBBitmap';
+ {$ENDIF}
+ Result.fDetachCanvas := DummyDetachCanvas;
+ Result.fWidth := W;
+ Result.fHeight := H;
+ if (W <> 0) and (H <> 0) then
+ begin
+ BitsPixel := BitsPerPixel[ PixelFormat ];
+ if BitsPixel = 0 then
+ begin
+ Result.fNewPixelFormat := DefaultPixelFormat;
+ BitsPixel := BitsPerPixel[DefaultPixelFormat];
+ end
+ else
+ Result.fNewPixelFormat := PixelFormat;
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( Result.fNewPixelFormat in [ pf1bit..pf32bit ], 'Strange pixel format' );
+ {$ENDIF KOL_ASSERTIONS}
+ Result.fDIBHeader := PrepareBitmapHeader( W, H, BitsPixel );
+ if PixelFormat = pf16bit then
+ begin
+ PreparePF16bit( Result.fDIBHeader );
+ end;
+
+ Result.fDIBSize := Result.ScanLineSize * H;
+ Result.fDIBBits :=
+ Pointer( GlobalAlloc( GMEM_FIXED or GMEM_ZEROINIT, Result.fDIBSize + 16 ) );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( Result.fDIBBits <> nil, 'No memory' );
+ {$ENDIF KOL_ASSERTIONS}
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{ TBitmap }
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.ClearData;
+begin
+ fDetachCanvas( @Self );
+ if fHandle <> 0 then
+ begin
+ DeleteObject( fHandle );
+ fHandle := 0;
+ fDIBBits := nil;
+ end;
+ if fDIBBits <> nil then
+ begin
+ if not fDIBAutoFree then
+ GlobalFree( THandle( fDIBBits ) );
+ fDIBBits := nil;
+ end;
+ if fDIBHeader <> nil then
+ begin
+ FreeMem( fDIBHeader );
+ fDIBHeader := nil;
+ end;
+ fScanLineSize := 0;
+ fGetDIBPixels := nil;
+ fSetDIBPixels := nil;
+ ClearTransImage;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.Clear;
+begin
+ RemoveCanvas;
+ ClearData;
+ fWidth := 0;
+ fHeight := 0;
+ fDIBAutoFree := FALSE;
+end;
+{$ENDIF PAS_VERSION}
+
+function TBitmap.GetBoundsRect: TRect;
+begin
+ Result := MakeRect( 0, 0, Width, Height );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TBitmap.Destroy;
+begin
+ Clear;
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+function TBitmap.BitsPerPixel: Integer;
+var B: tagBitmap;
+begin
+ CASE PixelFormat OF
+ pf1bit: Result := 1;
+ pf4bit: Result := 4;
+ pf8bit: Result := 8;
+ pf15bit: Result := 15;
+ pf16bit: Result := 16;
+ pf24bit: Result := 24;
+ pf32bit: Result := 32;
+ else begin
+ Result := 0;
+ if fHandle <> 0 then
+ if GetObject( fHandle, Sizeof( B ), @B ) > 0 then
+ Result := B.bmBitsPixel * B.bmPlanes;
+ end;
+ END;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.Draw(DC: HDC; X, Y: Integer);
+var
+ DCfrom, DC0: HDC;
+ oldBmp: HBitmap;
+ oldHeight: Integer;
+ B: tagBitmap;
+label
+ TRYAgain;
+begin
+TRYAgain:
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if fHandle <> 0 then
+ begin
+ fDetachCanvas( @Self );
+ oldHeight := fHeight;
+ if GetObject( fHandle, sizeof( B ), @B ) <> 0 then
+ oldHeight := B.bmHeight;
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( oldHeight > 0, 'oldHeight must be > 0' );
+ {$ENDIF KOL_ASSERTIONS}
+
+ DC0 := GetDC( 0 );
+ DCfrom := CreateCompatibleDC( DC0 );
+ ReleaseDC( 0, DC0 );
+
+ oldBmp := SelectObject( DCfrom, fHandle );
+ {$IFDEF KOL_ASSERTIONS}
+ 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 fDIBBits <> nil then
+ begin
+ oldHeight := Abs(fDIBHeader.bmiHeader.biHeight);
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( oldHeight > 0, 'oldHeight must be > 0' );
+ ASSERT( fWidth > 0, 'Width must be > 0' );
+ {$ENDIF KOL_ASSERTIONS}
+ if StretchDIBits( DC, X, Y, fWidth, oldHeight, 0, 0, fWidth, oldHeight,
+ fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY ) = 0 then
+ begin
+ if GetHandle <> 0 then
+ goto TRYAgain;
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.StretchDraw(DC: HDC; const Rect: TRect);
+var DCfrom: HDC;
+ oldBmp: HBitmap;
+label DrawHandle;
+begin
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+DrawHandle:
+ if fHandle <> 0 then
+ begin
+ fDetachCanvas( @Self );
+ DCfrom := CreateCompatibleDC( 0 );
+ oldBmp := SelectObject( DCfrom, fHandle );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
+ {$ENDIF KOL_ASSERTIONS}
+ StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
+ Rect.Bottom - Rect.Top, DCfrom, 0, 0, fWidth, fHeight,
+ SRCCOPY );
+ SelectObject( DCfrom, oldBmp );
+ DeleteDC( DCfrom );
+ end
+ else
+ if fDIBBits <> nil then
+ begin
+ if StretchDIBits( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
+ Rect.Bottom - Rect.Top, 0, 0, fWidth, fHeight,
+ fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY )<=0 then
+ begin
+ if GetHandle <> 0 then
+ goto DrawHandle;
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TBitmap.DrawMasked(DC: HDC; X, Y: Integer; Mask: HBitmap);
+begin
+ StretchDrawMasked( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ), Mask );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.DrawTransparent(DC: HDC; X, Y: Integer; TranspColor: TColor);
+begin
+ if TranspColor = clNone then
+ Draw( DC, X, Y )
+ else
+ StretchDrawTransparent( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ),
+ TranspColor );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.StretchDrawTransparent(DC: HDC; const Rect: TRect; TranspColor: TColor);
+begin
+ if TranspColor = clNone then
+ StretchDraw( DC, Rect )
+ else
+ begin
+ if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ TranspColor := Color2RGB( TranspColor );
+ if (fTransMaskBmp = nil) or (fTransColor <> TranspColor) then
+ begin
+ if fTransMaskBmp = nil then
+ fTransMaskBmp := NewBitmap( 0, 0 {fWidth, fHeight} );
+ fTransColor := TranspColor;
+ // Create here mask bitmap:
+ fTransMaskBmp.Assign( @Self );
+ fTransMaskBmp.Convert2Mask( TranspColor );
+ end;
+ StretchDrawMasked( DC, Rect, fTransMaskBmp.Handle );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF DEBUG_DRAWTRANSPARENT}
+procedure DebugDrawTransparent( DC: HDC; X, Y, W, H: Integer; PF: TPixelFormat;
+ const Note: AnsiString );
+const PixelFormatAsStr: array[ TPixelFormat ] of String = ( 'pfDevice', 'pf1bit',
+ 'pf4bit', 'pf8bit', 'pf15bit', 'pf16bit', 'pf24bit', 'pf32bit', 'pfCustom' );
+var Bmp: PBitmap;
+begin
+ Bmp := NewDibBitmap( W, H, pf32bit );
+ BitBlt( Bmp.Canvas.Handle, 0, 0, W, H, DC, X, Y, SrcCopy );
+ Bmp.SaveToFile( GetStartDir + PixelFormatAsStr[ PF ] + Note );
+ Bmp.Free;
+end;
+{$ENDIF DEBUG_DRAWTRANSPARENT}
+
+const
+ ROP_DstCopy = $00AA0029;
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.StretchDrawMasked(DC: HDC; const Rect: TRect; Mask: HBitmap);
+var
+ DCfrom, MemDC, MaskDC: HDC;
+ MemBmp: HBITMAP;
+ //Save4From,
+ Save4Mem, Save4Mask: THandle;
+ crText, crBack: TColorRef;
+ {$IFDEF FIX_TRANSPBMPPALETTE}
+ FixBmp: PBitmap;
+ {$ENDIF FIX_TRANSPBMPPALETTE}
+begin
+ {$IFDEF FIX_TRANSPBMPPALETTE}
+ if PixelFormat in [ pf4bit, pf8bit ] then
+ begin
+ FixBmp := NewBitmap( 0, 0 );
+ FixBmp.Assign( @ Self );
+ FixBmp.PixelFormat := pf32bit;
+ FixBmp.StretchDrawMasked( DC, Rect, Mask );
+ FixBmp.Free; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ {$ENDIF FIX_TRANSPBMPPALETTE}
+ if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ DCFrom := Canvas.Handle;
+ MaskDC := CreateCompatibleDC( 0 );
+ Save4Mask := SelectObject( MaskDC, Mask );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( Save4Mask <> 0, 'Can not select mask bitmap to DC' );
+ {$ENDIF KOL_ASSERTIONS}
+ MemDC := CreateCompatibleDC( 0 );
+ MemBmp := CreateCompatibleBitmap( DCfrom, fWidth, fHeight );
+ Save4Mem := SelectObject( MemDC, MemBmp ); if Save4Mem <> 0 then;
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( Save4Mem <> 0, 'Can not select memory bitmap to DC' );
+ {$ENDIF KOL_ASSERTIONS}
+ StretchBlt( MemDC, 0, 0, fWidth, fHeight, MaskDC, 0, 0, fWidth, fHeight, SrcCopy);
+ {$IFDEF DEBUG_DRAWTRANSPARENT}
+ DebugDrawTransparent( MemDC, 0, 0, fWidth, fWidth, PixelFormat, '1SrcCopy.bmp' );
+ {$ENDIF}
+ StretchBlt( MemDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, fWidth, fHeight, SrcErase);
+ {$IFDEF DEBUG_DRAWTRANSPARENT}
+ DebugDrawTransparent( MemDC, 0, 0, fWidth, fWidth, PixelFormat, '2SrcErase.bmp' );
+ {$ENDIF}
+ crText := SetTextColor(DC, $0);
+ crBack := Windows.SetBkColor(DC, $FFFFFF);
+ StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
+ MaskDC, 0, 0, fWidth, fHeight, SrcAnd);
+ {$IFDEF DEBUG_DRAWTRANSPARENT}
+ DebugDrawTransparent( DC, Rect.Left, Rect.Top, fWidth, fHeight, PixelFormat, '3SrcAnd.bmp' );
+ {$ENDIF}
+ StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
+ MemDC, 0, 0, fWidth, fHeight, SrcInvert);
+ {$IFDEF DEBUG_DRAWTRANSPARENT}
+ DebugDrawTransparent( DC, Rect.Left, Rect.Top, fWidth, fHeight, PixelFormat, '4SrcInvert.bmp' );
+ {$ENDIF}
+ Windows.SetBkColor( DC, crBack);
+ SetTextColor( DC, crText);
+ DeleteObject(MemBmp);
+ DeleteDC(MemDC);
+ SelectObject( MaskDC, Save4Mask );
+ DeleteDC( MaskDC );
+end;
+{$ENDIF PAS_VERSION}
+
+procedure ApplyBitmapBkColor2Canvas( Sender: PBitmap );
+begin
+ if Sender.fCanvas = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Sender.fCanvas.Brush.Color := Sender.BkColor;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure DetachBitmapFromCanvas( Sender: PBitmap );
+begin
+ if Sender.fCanvasAttached = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ SelectObject( Sender.fCanvas.fHandle, Sender.fCanvasAttached );
+ Sender.fCanvasAttached := 0;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TBitmap.GetCanvas: PCanvas;
+var DC: HDC;
+begin
+ Result := nil;
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if fCanvas = nil then
+ begin
+ fApplyBkColor2Canvas := ApplyBitmapBkColor2Canvas;
+ fCanvas := NewCanvas( 0 );
+ fCanvas.OnChange := CanvasChanged;
+ if fBkColor <> 0 then
+ fCanvas.Brush.Color := fBkColor;
+ end;
+ Result := fCanvas;
+
+ if fCanvas.fHandle = 0 then
+ begin
+ DC := CreateCompatibleDC( 0 );
+ fCanvas.Handle := DC;
+ fCanvasAttached := 0;
+ end;
+
+ if fCanvasAttached = 0 then
+ begin
+ fCanvasAttached := SelectObject( fCanvas.Handle, fHandle );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( fCanvasAttached <> 0, 'Can not select bitmap to DC of Canvas' );
+ {$ENDIF KOL_ASSERTIONS}
+ end;
+ fDetachCanvas := DetachBitmapFromCanvas;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TBitmap.GetEmpty: Boolean;
+begin
+ Result := (fWidth = 0) or (fHeight = 0);
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( (fWidth >= 0) and (fHeight >= 0), 'Bitmap dimensions can be negative' );
+ {$ENDIF KOL_ASSERTIONS}
+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;
+begin
+ Result := 0;
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fDetachCanvas( @ Self );
+ if fHandle = 0 then
+ begin
+ if fDIBBits <> nil then
+ begin
+ OldBits := fDIBBits;
+ DC0 := GetDC( 0 );
+ fDIBBits := nil;
+ fHandle := CreateDIBSection( DC0, fDIBHeader^, DIB_RGB_COLORS,
+ fDIBBits, 0, 0 );
+ {$IFDEF DEBUG_ANY}
+ if fHandle = 0 then
+ ShowMessage( 'Can not create DIB section, error: ' + Int2Str( GetLastError ) +
+ ', ' + SysErrorMessage( GetLastError ) );
+ {$ELSE}
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( fHandle <> 0, 'Can not create DIB section, error: ' + Int2Str( GetLastError ) +
+ ', ' + SysErrorMessage( GetLastError ) );
+ {$ENDIF KOL_ASSERTIONS}
+ {$ENDIF DEBUG_ANY}
+ ReleaseDC( 0, DC0 );
+ if fHandle <> 0 then
+ begin
+ Move( OldBits^, fDIBBits^, fDIBSize );
+ if not fDIBAutoFree then
+ GlobalFree( THandle( OldBits ) );
+ fDIBAutoFree := TRUE;
+
+ fGetDIBPixels := nil;
+ fSetDIBPixels := nil;
+ end
+ else
+ fDIBBits := OldBits;
+ end;
+ end;
+ Result := fHandle;
+end;
+{$ENDIF PAS_VERSION}
+
+function TBitmap.GetHandleAllocated: Boolean;
+begin
+ Result := fHandle <> 0;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.LoadFromFile(const Filename: KOLString);
+var Strm: PStream;
+begin
+ Strm := NewReadFileStream( Filename );
+ LoadFromStream( Strm );
+ Strm.Free;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TBitmap.LoadFromResourceID(Inst: DWORD; ResID: Integer);
+begin
+ LoadFromResourceName( Inst, MAKEINTRESOURCE( ResID ) );
+end;
+
+{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.LoadFromResourceName(Inst: DWORD; ResName: PKOLChar);
+var ResHandle: HBitmap;
+ Flg: DWORD;
+begin
+ Clear;
+ Flg := 0;
+ if fHandleType = bmDIB then
+ Flg := LR_CREATEDIBSECTION;
+ ResHandle := LoadImage( Inst, ResName, IMAGE_BITMAP, 0, 0, LR_DEFAULTSIZE or Flg );
+ if ResHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Handle := ResHandle;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF F_P}
+type
+ TBITMAPFILEHEADER = packed record
+ bfType: Word;
+ bfSize: DWORD;
+ bfReserved1: Word;
+ bfReserved2: Word;
+ bfOffBits: DWORD;
+ end;
+{$ENDIF}
+
+{$IFDEF ASM_noVERSION} // error + 16Colors->swap(Gray,Silver) + Core
+procedure TBitmap.LoadFromStream(Strm: PStream);
+type tBFH = TBitmapFileHeader;
+ tBIH = TBitmapInfoHeader;
+const szBIH = Sizeof( tBIH );
+ szBFH = Sizeof( tBFH );
+asm
+ PUSH EBX
+ PUSH ESI
+ MOV EBX, EAX
+ PUSH EDX
+ CALL Clear
+ POP ESI
+ MOV EAX, ESI
+ CALL TStream.GetPosition
+ PUSH EAX // [EBP+4] = Strm.Pos (starting pos)
+ PUSH EBP
+ MOV EBP, ESP
+ ADD ESP, -(szBIH + szBFH)
+ // reading bitmap
+ XOR ECX, ECX
+ MOV [EBX].fHandleType, CL
+ MOV CL, szBFH
+ MOV EDX, ESP
+ PUSH ECX
+ MOV EAX, ESI
+ CALL TStream.Read
+ POP ECX
+ SUB ECX, EAX
+ JNZ @@eread1
+ CMP [ESP].tBFH.bfType, $4D42
+ JE @@1
+ MOV EDX, [EBP+4]
+ MOV EAX, ESI
+ CALL TStream.Seek
+ XOR EAX, EAX
+ XOR EDX, EDX
+ JMP @@2
+@@1:
+ MOV EDX, [ESP].tBFH.bfSize
+ MOV EAX, [ESP].tBFH.bfOffBits
+@@2:
+ PUSH EDX // Push Size
+ PUSH EAX // Push Off
+ XOR ECX, ECX
+ MOV CL, szBIH
+ LEA EDX, [EBP-szBIH]
+ MOV EAX, ESI
+ PUSH ECX
+ CALL TStream.Read // read BIH
+ POP ECX
+@@eread1:
+ XOR ECX, EAX
+ JNZ @@eread
+ MOVZX EAX, [EBP-szBIH].tBIH.biBitCount
+ MOVZX EDX, [EBP-szBIH].tBIH.biPlanes
+ MUL EDX
+ CALL Bits2PixelFormat
+ {$IFDEF PARANOIA} DB $3C, pf15bit {$ELSE} CMP AL, pf15bit {$ENDIF}
+ JNZ @@no15bit
+ CMP [EBP-szBIH].tBIH.biCompression, 0
+ JZ @@no15bit
+ INC AL // AL = pf16bit
+@@no15bit:
+ MOV [EBX].fNewPixelFormat, AL
+ MOV EAX, szBIH + 1024
+ CALL System.@GetMem
+ MOV [EBX].fDIBHeader, EAX
+ XCHG EDX, EAX
+ LEA EAX, [EBP-szBIH]
+ XOR ECX, ECX
+ MOV CL, szBIH
+ CALL System.Move
+ MOV EAX, [EBP-szBIH].tBIH.biWidth
+ MOV [EBX].fWidth, EAX
+ MOV EAX, [EBP-szBIH].tBIH.biHeight
+ TEST EAX, EAX
+ JGE @@20
+ NEG EAX
+@@20: MOV [EBX].fHeight, EAX
+ MOV EAX, EBX
+ CALL GetScanLineSize
+ MOV EDX, [EBX].fHeight
+ MUL EDX
+ MOV [EBX].fDIBSize, EAX
+ PUSH EAX
+ PUSH GMEM_FIXED or GMEM_ZEROINIT
+ CALL GlobalAlloc
+ MOV [EBX].fDIBBits, EAX
+ MOVZX EAX, [EBP-szBIH].tBIH.biBitCount
+ {$IFDEF PARANOIA} DB $3C, 8 {$ELSE} CMP AL, 8 {$ENDIF}
+ JA @@3
+ MOV AL, 4
+ MOVZX ECX, [EBP-szBIH].tBIH.biBitCount
+ SAL EAX, CL
+ XCHG ECX, EAX
+@@3:
+ CMP [EBX].TBitmap.fNewPixelFormat, pf16bit
+ JNE @@30
+ XOR ECX, ECX
+ MOV CL, 12 // ColorCount = 12
+@@30:
+ POP EAX // EAX = off
+ TEST EAX, EAX
+ JLE @@4
+ SUB EAX, szBFH + szBIH
+ CMP EAX, ECX
+ JZ @@4
+ XCHG ECX, EAX
+@@4:
+ JECXZ @@5
+ PUSH ECX
+ MOV EDX, [EBX].fDIBHeader
+ ADD EDX, szBIH
+ MOV EAX, ESI
+ CALL TStream.Read
+ POP ECX
+ XOR EAX, ECX
+ JNZ @@eread
+@@5:
+ MOV ECX, [EBX].fDIBSize
+@@7:
+ PUSH ECX
+ MOV EAX, ESI
+ CALL TStream.GetPosition
+ PUSH EAX
+ MOV EAX, ESI
+ CALL TStream.GetSize
+ POP EDX
+ SUB EAX, EDX
+ POP ECX // Size = fDIBSize
+ CMP EAX, ECX // Strm.Size - Strm.Position > Size ?
+ JL @@8
+ XCHG ECX, EAX
+@@8: // ++++++++++++++ 26-Oct-2003 VK see comment in Pascal
+ MOV EAX, [EBX].fDIBSize
+ CMP ECX, EAX
+ JGE @@9
+ SUB EAX, ECX
+ PUSH EAX
+ MOV EAX, ESI
+ PUSH ECX
+ CALL TStream.GetPosition
+ POP ECX
+ POP EDX
+ CMP EDX, EAX
+ JG @@9
+ MOV EAX, ESI
+ NEG EDX
+ XOR ECX, ECX
+ INC ECX
+ CALL TStream.Seek
+ MOV ECX, [EBX].fDIBSize
+@@9: // ++++++++++++++
+ PUSH ECX
+ MOV EDX, [EBX].fDIBBits
+ MOV EAX, ESI
+ CALL TStream.Read
+ POP ECX
+ XOR EAX, ECX
+ POP EAX // Strm.Size - Position
+ POP ECX // fDIBSize
+ // end of reading bitmap
+@@eread:
+ MOV ESP, EBP
+ POP EBP
+ POP EDX
+ JZ @@exit
+ // not success:
+ XCHG EAX, ESI
+ XOR ECX, ECX // ECX = spBegin
+ CALL TStream.Seek
+ XCHG EAX, EBX
+ CALL Clear
+@@exit: POP ESI
+ POP EBX
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.LoadFromStream(Strm: PStream);
+type
+ TColorsArray = array[ 0..15 ] of TColor;
+ PColorsArray = ^TColorsArray;
+ PColor = ^TColor;
+var Pos : DWORD;
+ BFH : TBitmapFileHeader;
+
+ function ReadBitmap : Boolean;
+ var Size, Size1: Integer;
+ BCH: TBitmapCoreHeader;
+ RGBSize: DWORD;
+ C: PColor;
+ Off, HdSz, ColorCount: DWORD;
+ begin
+ fHandleType := bmDIB;
+ Result := False;
+ if Strm.Read( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit; {>>>>>>>>>}
+ Off := 0; Size := 0;
+ if BFH.bfType <> $4D42 then
+ Strm.Seek( Pos, spBegin )
+ else
+ begin
+ Off := BFH.bfOffBits - Sizeof( BFH );
+ Size := BFH.bfSize; // don't matter, just <> 0 is good
+ end;
+ RGBSize := 4;
+ HdSz := Sizeof( TBitmapInfoHeader );
+ fDIBHeader := AllocMem( 256*sizeof(TRGBQuad) + HdSz );
+ if Strm.Read( fDIBHeader.bmiHeader.biSize, Sizeof( DWORD ) ) <> Sizeof( DWORD ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if fDIBHeader.bmiHeader.biSize = HdSz then
+ begin
+ if Strm.Read( fDIBHeader.bmiHeader.biWidth, HdSz - Sizeof( DWORD ) ) <>
+ HdSz - Sizeof( DWORD ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end
+ else
+ if fDIBHeader.bmiHeader.biSize = Sizeof( TBitmapCoreHeader ) then
+ begin
+ RGBSize := 3;
+ HdSz := Sizeof( TBitmapCoreHeader );
+ if Strm.Read( BCH.bcWidth, HdSz - Sizeof( DWORD ) ) <>
+ HdSz - Sizeof( DWORD ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fDIBHeader.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );
+ fDIBHeader.bmiHeader.biWidth := BCH.bcWidth;
+ fDIBHeader.bmiHeader.biHeight := BCH.bcHeight;
+ fDIBHeader.bmiHeader.biPlanes := BCH.bcPlanes;
+ fDIBHeader.bmiHeader.biBitCount := BCH.bcBitCount;
+ end else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fNewPixelFormat := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount
+ * fDIBHeader.bmiHeader.biPlanes );
+ {$IFDEF KOL_ASSERTIONS}
+ if (fNewPixelFormat = pf15bit) and (fDIBHeader.bmiHeader.biCompression <> BI_RGB) then
+ begin
+ ASSERT( fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS, 'Unsupported bitmap format' );
+ end;
+ {$ENDIF KOL_ASSERTIONS}
+ fWidth := fDIBHeader.bmiHeader.biWidth;
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( fWidth > 0, 'Bitmap width must be > 0' );
+ {$ENDIF KOL_ASSERTIONS}
+ fHeight := Abs(fDIBHeader.bmiHeader.biHeight);
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( fHeight > 0, 'Bitmap height must be > 0' );
+ {$ENDIF KOL_ASSERTIONS}
+
+ fDIBSize := ScanLineSize * fHeight;
+ fDIBBits :=
+ Pointer( GlobalAlloc( GMEM_FIXED or GMEM_ZEROINIT, fDIBSize ) );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( fDIBBits <> nil, 'No memory' );
+ {$ENDIF KOL_ASSERTIONS}
+
+ ColorCount := 0;
+ if fDIBHeader.bmiHeader.biBitCount <= 8 then
+ begin
+ if fDIBHeader.bmiHeader.biClrUsed > 0 then
+ ColorCount := fDIBHeader.bmiHeader.biClrUsed * Sizeof( TRGBQuad )
+ else
+ ColorCount := (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad )
+ end
+ else if (fNewPixelFormat in [ pf16bit ]) or
+ (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
+ ColorCount := 12;
+
+ if Off > 0 then
+ begin
+ Off := Off - HdSz;
+ if (Off <> ColorCount) then
+ if not(fNewPixelFormat in [pf15bit,pf16bit])
+ or (Off = 0) //+++ to fix loading 15- and 16-bit bmps with mask omitted
+ then
+ ColorCount := Min( 1024, Off );
+ end;
+ if ColorCount <> 0 then
+ begin
+ if Off >= ColorCount then
+ Off := Off - ColorCount;
+ if RGBSize = 4 then
+ begin
+ if Strm.Read( fDIBheader.bmiColors[ 0 ], ColorCount )
+ <> DWORD( ColorCount ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end
+ else
+ begin
+ C := @ fDIBHeader.bmiColors[ 0 ];
+ while ColorCount > 0 do
+ begin
+ if Strm.Read( C^, RGBSize ) <> RGBSize then Exit; {>>>>>>>>>>>>>>>}
+ Dec( ColorCount, RGBSize );
+ Inc( C );
+ end;
+ end;
+ end;
+ if Off > 0 then
+ Strm.Seek( Off, spCurrent );
+ if (Size = 0) or (Strm.Size <= 0) then
+ Size := fDIBSize
+ else
+ Size := Min( fDIBSize, Strm.Size - Strm.Position );
+ Size1 := Min( Size, fDIBSize );
+
+ if (Size1 < fDIBSize)
+ and (DWORD( fDIBSize - Size1 ) <= Strm.Position) then
+ begin
+ Strm.Seek( Size1 - fDIBSize, spCurrent );
+ Size1 := fDIBSize;
+ end;
+ if Size1 > fDIBSize then Size1 := fDIBSize;
+ // +++++++++++++++++++ to fix some "incorrect" bitmaps while loading
+ if Strm.Read( fDIBBits^, Size1 ) <> DWORD( Size1 ) then Exit; {>>>>>>>>>>}
+ if Size > Size1 then
+ Strm.Seek( Size - Size1, spCurrent );
+ Result := True;
+ end;
+begin
+ Clear;
+ Pos := Strm.Position;
+ if not ReadBitmap then
+ begin
+ Strm.Seek( Pos, spBegin );
+ Clear;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+////////////////// bitmap RLE-decoding and loading - by Vyacheslav A. Gavrik
+
+// by Vyacheslav A. Gavrik
+procedure DecodeRLE4(Bmp:PBitmap;Data:Pointer; MaxSize: DWORD);
+ procedure OddMove(Src,Dst:PByte;Size:Integer);
+ begin
+ if Size=0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ repeat
+ Dst^:=(Dst^ and $F0)or(Src^ shr 4);
+ Inc(Dst);
+ Dst^:=(Dst^ and $0F)or(Src^ shl 4);
+ Inc(Src);
+ Dec(Size);
+ until Size=0;
+ end;
+ procedure OddFill(Mem:PByte;Size,Value:Integer);
+ begin
+ Value:=(Value shr 4)or(Value shl 4);
+ Mem^:=(Mem^ and $F0)or(Value and $0F);
+ Inc(Mem);
+ if Size>1 then FillChar(Mem^,Size,Char( Value ))
+ else Mem^:=(Mem^ and $0F)or(Value and $F0);
+ end;
+var
+ pb: PByte;
+ x,y,z,i: Integer;
+begin
+ pb:=Data; x:=0; y:=0;
+ if Bmp.fScanLineSize = 0 then
+ Bmp.ScanLineSize;
+ while (y<Bmp.Height) and (DWORD(pb) - DWORD(Data) < MaxSize) do
+ begin
+ if pb^=0 then
+ begin
+ Inc(pb);
+ z:=pb^;
+ case pb^ of
+ 0: begin
+ Inc(y);
+ x:=0;
+ end;
+ 1: Break;
+ 2: begin
+ Inc(pb); Inc(x,pb^);
+ Inc(pb); Inc(y,pb^);
+ end;
+ else
+ begin
+ Inc(pb);
+ i:=(z+1)shr 1;
+ if i and 1 = 1 then Inc( i );
+ if x + z <= bmp.Width then
+ if x and 1 =1 then
+ OddMove(pb,@PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x shr 1],(z+1)shr 1)
+ else
+ Move(pb^,PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x shr 1],(z+1)shr 1);
+ Inc(pb,i-1);
+ Inc(x,z);
+ end;
+ end;
+ end else
+ begin
+ z:=pb^;
+ Inc(pb);
+ if x + z <= Bmp.Width then
+ if x and 1 = 1 then
+ OddFill(@PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x shr 1],(z+1) shr 1,pb^)
+ else
+ FillChar( PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x shr 1],
+ (z+1) shr 1, AnsiChar( pb^ ));
+ Inc(x,z);
+ end;
+ Inc(pb);
+ end;
+end;
+
+// by Vyacheslav A. Gavrik
+procedure DecodeRLE8(Bmp:PBitmap;Data:Pointer; MaxSize: DWORD);
+var
+ pb: PByte;
+ x,y,z,i: Integer;
+begin
+ pb:=Data; y:=0; x:=0;
+ if Bmp.fScanLineSize = 0 then
+ Bmp.ScanLineSize;
+
+ while (y<Bmp.Height) and (DWORD(pb) - DWORD(Data) < MaxSize) do
+ begin
+ if pb^=0 then
+ begin
+ Inc(pb);
+ case pb^ of
+ 0: begin
+ Inc(y);
+ x:=0;
+ end;
+ 1: Break;
+ 2: begin
+ Inc(pb); Inc(x,pb^);
+ Inc(pb); Inc(y,pb^);
+ end;
+ else
+ begin
+ i:=pb^;
+ z:=(i+1)and(not 1);
+ Inc(pb);
+ Move(pb^,PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x],i);
+ Inc(pb,z-1);
+ Inc(x,i);
+ end;
+ end;
+ end else
+ begin
+ i:=pb^; Inc(pb);
+ if x + i <= Bmp.Width then
+ FillChar( PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x],
+ i, AnsiChar( pb^ ));
+ Inc(x,i);
+ end;
+ Inc(pb);
+ end;
+end;
+
+function TBitmap.LoadFromFileEx(const Filename: KOLString): Boolean; // by Vyacheslav A. Gavrik
+var Strm: PStream;
+begin
+ Strm := NewReadFileStream( Filename );
+ Result := LoadFromStreamEx(Strm);
+ Strm.Free;
+end;
+
+function TBitmap.LoadFromStreamEx(Strm: PStream): Boolean; // by Vyacheslav A. Gavrik
+var Pos : DWORD;
+ i: Integer;
+
+ function ReadBitmap : Boolean;
+ var Off, Size, ColorCount: Integer;
+ BFH : TBitmapFileHeader;
+ BCH: TBITMAPCOREHEADER;
+ BFHValid: Boolean;
+ Buffer: Pointer;
+ L: DWORD;
+ ColorTriples: Boolean;
+ PColr: PDWORD;
+ FinalPos: DWORD;
+ ZI: DWORD;
+ begin
+ fHandleType := bmDIB;
+ Result := False;
+ BFHValid := FALSE;
+ if Strm.Read( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit; {>>>>>>>>>}
+ Off := 0; Size := 0;
+ ColorTriples := FALSE;
+ if BFH.bfType <> $4D42 then
+ begin
+ Strm.Seek( Pos, spBegin );
+ BFH.bfOffBits := 0;
+ BFH.bfSize := 0;
+ end
+ else
+ begin
+ BFHValid := TRUE;
+ Off := BFH.bfOffBits;
+ Size := BFH.bfSize;
+ end;
+ fDIBHeader := AllocMem( 256*sizeof(TRGBQuad) + sizeof(TBitmapInfoHeader) );
+ if Strm.Read( fDIBHeader.bmiHeader.biSize, Sizeof( fDIBHeader.bmiHeader.biSize ) ) <>
+ Sizeof( fDIBHeader.bmiHeader.biSize ) then Exit; {>>>>>>>>>>>>>>>>>>>>>}
+ if (fDIBHeader.bmiHeader.biSize <> Sizeof( TBITMAPCOREHEADER )) and
+ (fDIBHeader.bmiHeader.biSize <> Sizeof( TBitmapInfoHeader )) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ L := fDIBHeader.bmiHeader.biSize - Sizeof( fDIBHeader.bmiHeader.biSize );
+ if (fDIBHeader.bmiHeader.biSize = Sizeof( TBITMAPCOREHEADER )) then
+ begin
+ if Strm.Read( BCH.bcWidth, L ) <> L then Exit; {>>>>>>>>>>>>>>>>>>>>>>>}
+ fDIBHeader.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );
+ fDIBHeader.bmiHeader.biWidth := BCH.bcWidth;
+ fDIBHeader.bmiHeader.biHeight := BCH.bcHeight;
+ fDIBHeader.bmiHeader.biPlanes := BCH.bcPlanes;
+ fDIBHeader.bmiHeader.biBitCount := BCH.bcBitCount;
+ ColorTriples := TRUE;
+ end
+ else
+ begin
+ if Strm.Read( fDIBHeader.bmiHeader.biWidth, L) <> L then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ fNewPixelFormat := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount
+ * fDIBHeader.bmiHeader.biPlanes );
+ fWidth := fDIBHeader.bmiHeader.biWidth;
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( fWidth > 0, 'Bitmap width must be > 0' );
+ {$ENDIF KOL_ASSERTIONS}
+ fHeight := Abs(fDIBHeader.bmiHeader.biHeight);
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( fHeight > 0, 'Bitmap height must be > 0' );
+ {$ENDIF KOL_ASSERTIONS}
+
+ fDIBSize := ScanLineSize * fHeight;
+ ZI := 0;
+ if (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or
+ (fDIBHeader.bmiHeader.biCompression = BI_RLE4) then
+ ZI := GMEM_ZEROINIT;
+ fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED or ZI, fDIBSize + 4 ) );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( fDIBBits <> nil, 'No memory' );
+ ASSERT( (fDIBHeader.bmiHeader.biCompression and
+ (BI_RLE8 or BI_RLE4 or BI_RLE8 or BI_BITFIELDS) <> 0) or
+ (fDIBHeader.bmiHeader.biCompression = BI_RGB),
+ 'Unknown compression algorithm');
+ {$ENDIF KOL_ASSERTIONS}
+
+ ColorCount := 0;
+ if fDIBHeader.bmiHeader.biBitCount <= 8 then
+ begin
+ if fDIBHeader.bmiHeader.biClrUsed > 0 then
+ ColorCount := fDIBHeader.bmiHeader.biClrUsed * Sizeof( TRGBQuad )
+ else
+ ColorCount := (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad )
+ end
+ else if (fNewPixelFormat in [ pf15bit, pf16bit ]) or
+ (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
+ begin
+ if (Strm.Size = 0) or (Strm.Size - Strm.Position - DWORD( Size ) >= 12) then
+ ColorCount := 12;
+ end;
+
+ if ColorTriples then
+ ColorCount := ColorCount div 4 * 3;
+
+ if Off > 0 then
+ begin
+ if ColorTriples then
+ Off := Off - SizeOf( TBitmapFileHeader ) - Sizeof( TBitmapCoreHeader )
+ else Off := Off - SizeOf( TBitmapFileHeader ) - Sizeof( TBitmapInfoHeader );
+ if (Off <> ColorCount) and (fNewPixelFormat <= pf8bit) then
+ if ColorTriples then
+ ColorCount := min( Off, 3 * 256 )
+ else
+ ColorCount := min( Off, 4 * 256 );
+ end;
+ if (fNewPixelFormat in [ pf15bit, pf16bit ]) then
+ if (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
+ begin
+ PDWORD( DWORD( @ fDIBHeader.bmiColors[ 0 ] ) + 8 )^ := ( $00001F );
+ PDWORD( DWORD( @ fDIBHeader.bmiColors[ 0 ] ) + 4 )^ := ( $0007E0 );
+ TColor( fDIBHeader.bmiColors[ 0 ] ) := ( $00F800 );
+ end else
+ ColorCount := 0;
+
+ if ColorCount <> 0 then
+ if ColorTriples then
+ begin
+ PColr := @ fDIBheader.bmiColors[ 0 ];
+ while ColorCount >= 3 do
+ begin
+ if strm.Read( PColr^, 3 ) <> 3 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>}
+ Inc( PColr );
+ Dec( ColorCount, 3 );
+ end;
+ end else
+ begin
+ if (Integer( Strm.Size - Strm.Position ) > fDIBSize) or
+ (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or
+ (fDIBHeader.bmiHeader.biCompression = BI_RLE4) then
+ begin
+ if Strm.Read( fDIBheader.bmiColors[ 0 ], ColorCount )
+ <> DWORD( ColorCount ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Off - ColorCount > 0 then
+ Strm.Position := Integer( Strm.Position ) + Off - ColorCount;
+ end;
+ end;
+
+ if not BFHValid then
+ Size := fDIBSize
+ else
+ if (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or
+ (fDIBHeader.bmiHeader.biCompression = BI_RLE4) then
+ begin
+ //if BFHValid then //-- already TRUE here
+ Size := BFH.bfSize - BFH.bfOffBits;
+ end
+ else
+ begin
+ if (Strm.Size = 0) or
+ (Integer( Strm.Size - BFH.bfOffBits - Pos ) > Integer(Size)) then
+ Size := fDIBSize
+ else
+ Size := Strm.Size - BFH.bfOffBits - DWORD( Pos );
+ if Size > fDIBSize then Size := fDIBSize
+ else if (Size < fDIBSize) and (fDIBheader.bmiHeader.biClrUsed <> 0) then
+ begin
+ BFHValid := FALSE;
+ Strm.Position := Strm.Position + fDIBheader.bmiHeader.biClrUsed * 4;
+ Size := Strm.Size - Strm.Position;
+ end;
+ end;
+
+ if (fDIBHeader.bmiHeader.biCompression = BI_RGB) or
+ (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
+ begin
+ if BFHValid and
+ ( (Strm.Size > 0) and
+ (Integer( Strm.Size - BFH.bfOffBits - Pos) > Integer(Size))
+ or
+ (Strm.Size = 0) and
+ (Off > 0)
+ ) then
+ if Integer( Strm.Position - Pos ) <= Integer( BFH.bfOffbits ) then
+ Strm.Position := Pos + BFH.bfOffbits;
+ i := Strm.Read( fDIBBits^, Size );
+ if i <> Size then
+ begin
+ {$IFDEF FILL_BROKEN_BITMAP}
+ ZeroMemory( Pointer( Integer( fDIBBits ) + i ), Size - i );
+ {$ENDIF FILL_BROKEN_BITMAP}
+ end;
+ end
+ else
+ begin
+ if (Integer( fDIBHeader.bmiHeader.biSizeImage ) > 0) and
+ (Integer( fDIBHeader.bmiHeader.biSizeImage ) < Size) then
+ Size := Integer( fDIBHeader.bmiHeader.biSizeImage ); // - ColorCount;
+ // it is possible that bitmap "compressed" with RLE has size
+ // greater then non-compressed one:
+ FinalPos := Strm.Position + DWORD( Size );
+ L := Strm.Size - Strm.Position;
+ if L > DWORD( Size ) then
+ L := Size;
+ Buffer := AllocMem( Size * 3 );
+ if Strm.Read(Buffer^,L) <> DWORD( L ) then ;
+ if fDIBHeader.bmiHeader.biCompression=BI_RLE8 then
+ DecodeRLE8(@Self,Buffer,Size * 3)
+ else
+ DecodeRLE4(@Self,Buffer,Size * 3);
+ Strm.Position := FinalPos;
+ fDIBHeader.bmiHeader.biCompression := BI_RGB;
+ FreeMem(Buffer);
+ end;
+
+ Result := True;
+ end;
+begin
+ Clear;
+ Pos := Strm.Position;
+ result := ReadBitmap;
+ if not result then
+ begin
+ Strm.Seek( Pos, spBegin );
+ Clear;
+ end;
+end;
+
+///////////////////////////
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TBitmap.ReleaseHandle: HBitmap;
+var OldBits: Pointer;
+begin
+ HandleType := bmDIB;
+ Result := GetHandle;
+ if Result = 0 then Exit; // only when bitmap is empty {>>>>>>>>>>>>>>>>>>>>>>}
+ if fDIBAutoFree then
+ begin
+ OldBits := fDIBBits;
+ fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED {or GMEM_ZEROINIT}, fDIBSize ) );
+ Move( OldBits^, fDIBBits^, fDIBSize );
+ fDIBAutoFree := FALSE;
+ end;
+ fHandle := 0;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.SaveToFile(const Filename: KOLString);
+var Strm: PStream;
+begin
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Strm := NewWritefileStream( Filename );
+ SaveToStream( Strm );
+ Strm.Free;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TBitmap.CoreSaveToFile(const Filename: KOLString);
+var Strm: PStream;
+begin
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Strm := NewWritefileStream( Filename );
+ CoreSaveToStream( Strm );
+ Strm.Free;
+end;
+
+procedure TBitmap.RLESaveToFile(const Filename: KOLString);
+var Strm: PStream;
+begin
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Strm := NewWritefileStream( Filename );
+ RLESaveToStream( Strm );
+ Strm.Free;
+end;
+
+{$IFDEF ASM_STREAM}
+procedure TBitmap.SaveToStream(Strm: PStream);
+type tBFH = TBitmapFileHeader;
+ tBIH = TBitmapInfoHeader;
+const szBIH = Sizeof( tBIH );
+ szBFH = Sizeof( tBFH );
+asm
+ PUSH EBX
+ PUSH ESI
+ MOV EBX, EAX
+ MOV ESI, EDX
+ CALL GetEmpty
+ JZ @@exit
+ MOV EAX, ESI
+ CALL TStream.GetPosition
+ PUSH EAX
+
+ MOV EAX, EBX
+ XOR EDX, EDX // EDX = bmDIB
+ CALL SetHandleType
+ XOR EAX, EAX
+ MOV EDX, [EBX].fDIBHeader
+ MOVZX ECX, [EDX].TBitmapInfoHeader.biBitCount
+ CMP CL, 8
+ JG @@1
+ MOV AL, 4
+ SHL EAX, CL
+@@1:
+ PUSH EAX // ColorsSize
+ LEA ECX, [EAX + szBFH + szBIH]
+ CMP [EDX].TBitmapInfoHeader.biCompression, 0
+ JZ @@10
+ ADD ECX, 74
+@@10:
+ PUSH ECX // BFH.bfOffBits
+ PUSH 0
+ ADD ECX, [EBX].fDIBSize
+ PUSH ECX
+ MOV CX, $4D42
+ PUSH CX
+ XOR ECX, ECX
+ MOV EDX, ESP
+ MOV CL, szBFH
+ PUSH ECX
+ MOV EAX, ESI
+ CALL TStream.Write
+ POP ECX
+ ADD ESP, szBFH
+ XOR EAX, ECX
+ POP ECX // ColorsSize
+ JNZ @@ewrite
+ MOV EDX, [EBX].fDIBHeader
+ CMP [EDX].TBitmapInfoHeader.biCompression, 0
+ JZ @@11
+ ADD ECX, 74
+@@11:
+ ADD ECX, szBIH
+ PUSH ECX
+ MOV EAX, ESI
+ CALL TStream.Write
+ POP ECX
+ XOR EAX, ECX
+ JNZ @@ewrite
+
+ MOV ECX, [EBX].fDIBSize
+ MOV EDX, [EBX].fDIBBits
+ MOV EAX, ESI
+ PUSH ECX
+ CALL TStream.Write
+ POP ECX
+ XOR EAX, ECX
+@@ewrite:
+ POP EDX
+ JZ @@exit
+ XCHG EAX, ESI
+ XOR ECX, ECX
+ CALL TStream.Seek
+@@exit:
+ POP ESI
+ POP EBX
+end;
+{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.SaveToStream(Strm: PStream);
+var BFH : TBitmapFileHeader;
+ Pos : Integer;
+ function WriteBitmap : Boolean;
+ var ColorsSize, BitsSize, Size : Integer;
+ begin
+ Result := False;
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ HandleType := bmDIB; // convert to DIB if DDB
+ ZeroMemory( @BFH, Sizeof( BFH ) );
+ ColorsSize := 0;
+ with fDIBHeader.bmiHeader do
+ if biBitCount <= 8 then
+ ColorsSize := (1 shl biBitCount) * Sizeof( TRGBQuad );
+ BFH.bfOffBits := Sizeof( BFH ) + Sizeof( TBitmapInfoHeader ) + ColorsSize;
+ BitsSize := fDIBSize; //ScanLineSize * fHeight;
+ BFH.bfSize := BFH.bfOffBits + DWord( BitsSize );
+ BFH.bfType := $4D42; // 'BM';
+ if fDIBHeader.bmiHeader.biCompression <> 0 then
+ begin
+ ColorsSize := 12 + 16*sizeof(TRGBQuad);
+ Inc( BFH.bfOffBits, ColorsSize );
+ end;
+ if Strm.Write( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit; {>>>>>>>>}
+ Size := Sizeof( TBitmapInfoHeader ) + ColorsSize;
+ if Strm.Write( fDIBHeader^, Size ) <> DWORD(Size) then Exit; {>>>>>>>>>>>}
+ if Strm.Write( fDIBBits^, BitsSize ) <> DWord( BitsSize ) then Exit; {>>>}
+ Result := True;
+ end;
+begin
+ Pos := Strm.Position;
+ if not WriteBitmap then
+ Strm.Seek( Pos, spBegin );
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TBitmap.CoreSaveToStream(Strm: PStream);
+type TRGBTriple = packed record
+ bRed, bGreen, bBlue: Byte;
+ end;
+var BFH : TBitmapFileHeader;
+ Pos : Integer;
+ function WriteCoreBitmap : Boolean;
+ var ColorsSize, ColorsCount, BitsSize, i: Integer;
+ CH: TBitmapCoreHeader;
+ begin
+ Result := False;
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ HandleType := bmDIB; // convert to DIB if DDB
+ ZeroMemory( @BFH, Sizeof( BFH ) );
+ ColorsSize := 0;
+ ColorsCount := 1 shl fDIBHeader.bmiHeader.biBitCount;
+ with fDIBHeader.bmiHeader do
+ if biBitCount <= 8 then
+ ColorsSize := ColorsCount * Sizeof( TRGBTriple );
+ BFH.bfOffBits := Sizeof( BFH ) + Sizeof( CH ) + ColorsSize;
+ BitsSize := fDIBSize; //ScanLineSize * fHeight;
+ BFH.bfSize := BFH.bfOffBits + DWord( BitsSize );
+ BFH.bfType := $4D42; // 'BM';
+
+ if Strm.Write( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit; {>>>>>>>>}
+ CH.bcSize := Sizeof( CH );
+ CH.bcWidth := Width;
+ CH.bcHeight := Height;
+ CH.bcPlanes := 1;
+ CH.bcBitCount := fDIBHeader.bmiHeader.biBitCount;
+ if Strm.Write( CH, Sizeof( CH ) ) <> Sizeof(CH) then Exit; {>>>>>>>>>>>>>}
+ for i := 0 to ColorsCount-1 do
+ begin
+ if Strm.Write( fDIBHeader.bmiColors[i], 3 ) <> 3 then Exit; {>>>>>>>}
+ end;
+ if Strm.Write( fDIBBits^, BitsSize ) <> DWord( BitsSize ) then Exit; {>>>}
+ Result := True;
+ end;
+begin
+ if (fDIBHeader.bmiHeader.biBitCount > 8)
+ or (fDIBHeader.bmiHeader.biCompression <> 0) then
+ begin
+ SaveToStream( Strm ); Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Pos := Strm.Position;
+ if not WriteCoreBitmap then
+ Strm.Seek( Pos, spBegin );
+end;
+
+procedure TBitmap.RLESaveToStream(Strm: PStream);
+var BFH : TBitmapFileHeader;
+ Pos : Integer;
+ MS: PStream;
+ function CountZeroes( P: PByte; maxBytes: Integer ): Integer;
+ begin
+ Result := 0;
+ while (P^ = 0) and (Result < maxBytes) do
+ begin
+ inc( P );
+ inc( Result );
+ end;
+ end;
+ function CountSame( P: PByte; maxBytes: Integer ): Integer;
+ var B: Byte;
+ begin
+ Result := 1;
+ B := P^;
+ while maxBytes > 1 do
+ begin
+ inc(P);
+ if P^ <> B then break;
+ inc(Result);
+ dec(maxBytes);
+ end;
+ end;
+ function CountSame2( P: PByteArray; maxPixels: Integer ): Integer;
+ var B1, B2: Byte;
+ i: Integer;
+ begin
+ Result := 2;
+ B1 := P[0];
+ B2 := P[1];
+ i := 0;
+ dec( maxPixels, 2 );
+ while maxPixels > 0 do
+ begin
+ inc(i, 2);
+ if P[i] <> B1 then break;
+ inc(Result);
+ dec(maxPixels);
+ if maxPixels = 0 then break;
+ if P[i+1] <> B2 then break;
+ inc(Result);
+ dec(maxPixels);
+ end;
+ end;
+ function CountDiff( P: PByte; maxBytes: Integer; minSame: Integer ): Integer;
+ var Cnt: Integer;
+ begin
+ Result := 1;
+ while (maxBytes > 1) do
+ begin
+ inc(P);
+ dec(maxBytes);
+ Cnt := CountSame( P, maxBytes );
+ if Cnt >= minSame then
+ break;
+ inc( Result );
+ end;
+ end;
+ function CountDiff2( P: PByte; maxPixels: Integer; minSame: Integer ): Integer;
+ var Cnt: Integer;
+ begin
+ Result := 1;
+ while (maxPixels > 1) do
+ begin
+ inc(P);
+ dec(maxPixels);
+ Cnt := CountSame2( Pointer( P ), maxPixels );
+ if Cnt >= minSame then
+ break;
+ inc( Result );
+ end;
+ end;
+ procedure WriteOffset( dx, dy: Integer );
+ var b: Byte;
+ begin
+ while (dx > 0) or (dy > 0) do
+ begin
+ Strm.WriteVal( 0, 1 );
+ Strm.WriteVal( 2, 1 );
+ b := min( dx, 255 );
+ Strm.WriteVal( b, 1 );
+ dec( dx, b );
+ b := min( dy, 255 );
+ Strm.WriteVal( b, 1 );
+ dec( dy, b );
+ end;
+ end;
+ procedure WriteRep( cnt: Integer; Value: Byte );
+ var n: Integer;
+ begin
+ while cnt > 0 do
+ begin
+ n := min( cnt, 255 );
+ dec( cnt, n );
+ while (cnt > 0) and (cnt < 3) do
+ begin
+ inc( cnt );
+ dec( n );
+ end;
+ Strm.WriteVal( n, 1 );
+ Strm.WriteVal( Value, 1 );
+ end;
+ end;
+ procedure WriteRun( P: PByte; cnt: Integer );
+ var n: Integer;
+ begin
+ while cnt > 0 do
+ begin
+ n := min( cnt, 255 );
+ dec( cnt, n );
+ if (cnt < 3) and (n = 255) then
+ begin
+ inc( cnt, 2 );
+ dec( n, 2 );
+ end;
+ if n > 2 then
+ begin
+ Strm.WriteVal( 00, 1 );
+ Strm.WriteVal( n, 1 );
+ Strm.Write( P^, n );
+ inc( P, n );
+ if n and 1 <> 0 then
+ Strm.WriteVal( 00, 1 );
+ end else
+ while n > 0 do
+ begin
+ Strm.WriteVal( 01, 1 );
+ Strm.Write( P^, 1 );
+ inc( P );
+ dec( n );
+ end;
+ end;
+ end;
+ procedure WriteRun2( P: PByteArray; cnt: Integer );
+ var n, i, L: Integer;
+ begin
+ i := 0;
+ while cnt > 0 do
+ begin
+ n := min( cnt, 252 );
+ dec( cnt, n );
+ if (cnt < 3) and (n = 252) then
+ begin
+ inc( n, cnt );
+ cnt := 0;
+ end;
+ if n > 2 then
+ begin
+ Strm.WriteVal( 00, 1 );
+ Strm.WriteVal( n, 1 );
+ L := 0;
+ while n > 0 do
+ begin
+ Strm.WriteVal( P[i] shl 4 or P[i+1], 1 );
+ inc( i, 2 );
+ dec( n, 2 );
+ inc( L );
+ end;
+ if L and 1 <> 0 then
+ Strm.WriteVal( 0, 1 );
+ end else
+ while n > 0 do
+ begin
+ if n = 1 then
+ Strm.WriteVal( 01, 1 )
+ else
+ Strm.WriteVal( 02, 1 );
+ Strm.WriteVal( P[i] shl 4 or P[i+1], 1 );
+ inc( i, 2 );
+ dec( n, 2 );
+ end;
+ end;
+ end;
+ function WriteRLE4: Boolean;
+ var line_len_left, y, cnt: Integer;
+ P, Pnext: PByte;
+ PnextLine: PByte;
+ offX, offY: Integer;
+ begin
+ y := 0;
+ P := MS.Memory;
+ while y < Height do
+ begin
+ line_len_left := Width;
+ PnextLine := P; inc( PnextLine, line_len_left );
+ while line_len_left > 0 do
+ begin
+ if P^ = 0 then
+ begin
+ cnt := CountZeroes( P, line_len_left + (Height-y-1)*Width );
+ if cnt > 3 then
+ begin // generate offset
+ offY := cnt div Width;
+ offX := cnt - offY * Width;
+ if (offX < 0)
+ or (offY = 0) and (offX >= line_len_left)
+ or (line_len_left < offX) then
+ begin
+ inc( P, line_len_left );
+ break;
+ end;
+ if offY > 0 then
+ begin
+ WriteOffset( offX, offY );
+ inc( P, cnt );
+ dec( line_len_left, offX );
+ inc( Y, offY );
+ continue;
+ end;
+ end;
+ end;
+ cnt := CountSame2( Pointer( P ), line_len_left );
+ if cnt >= 3 then
+ begin
+ Pnext := P; inc( Pnext );
+ WriteRep( cnt, (P^ shl 4) or (Pnext^) );
+ inc( P, cnt );
+ dec( line_len_left, cnt );
+ end else
+ begin
+ cnt := CountDiff2( P, line_len_left, 3 );
+ WriteRun2( Pointer( P ), cnt );
+ inc( P, cnt );
+ dec( line_len_left, cnt );
+ end;
+ end;
+ Strm.WriteVal( 0, 1 );
+ if y < Height-1 then
+ Strm.WriteVal( 0, 1 ) // EOL
+ else Strm.WriteVal( 1, 1 ); // EOB
+ inc(y);
+ if ( Integer( P ) - Integer( PnextLine ) ) mod Width <> 0 then
+ begin {$IFNDEF PAS_ONLY}
+ asm
+ nop
+ end;{$ENDIF}
+ end;
+ end;
+ Result := TRUE;
+ end;
+ function WriteRLE8: Boolean;
+ var line_len_left, y, cnt: Integer;
+ P: PByte;
+ //Pnext: PByte;
+ offX, offY: Integer;
+ begin
+ y := 0;
+ P := MS.Memory;
+ while y < Height do
+ begin
+ line_len_left := Width;
+ //Pnext := P; inc( Pnext, line_len_left );
+ while line_len_left > 0 do
+ begin
+ if P^ = 0 then
+ begin
+ cnt := CountZeroes( P, line_len_left + (Height-y-1)*Width );
+ if cnt > 3 then
+ begin // generate offset
+ offY := cnt div Width;
+ offX := cnt - offY * Width;
+ if (offX < 0)
+ or (offY = 0) and (offX >= line_len_left)
+ or (line_len_left < offX) then
+ begin
+ inc( P, line_len_left );
+ break;
+ end;
+ if offY > 0 then
+ begin
+ WriteOffset( offX, offY );
+ inc( P, cnt );
+ dec( line_len_left, offX );
+ inc( Y, offY );
+ continue;
+ end;
+ end;
+ end;
+ cnt := CountSame( P, line_len_left );
+ if cnt >= 2 then
+ begin
+ WriteRep( cnt, P^ );
+ inc( P, cnt );
+ dec( line_len_left, cnt );
+ end else
+ begin
+ cnt := CountDiff( P, line_len_left, 2 );
+ WriteRun( P, cnt );
+ inc( P, cnt );
+ dec( line_len_left, cnt );
+ end;
+ end;
+ Strm.WriteVal( 00, 1 );
+ if y < Height-1 then
+ Strm.WriteVal( 00, 1 ) // EOL
+ else Strm.WriteVal( 01, 1 ); // EOB
+ inc(y);
+ {if P <> Pnext then
+ asm
+ nop
+ end;}
+ end;
+ Result := TRUE;
+ end;
+ function WriteBitmap : Boolean;
+ var ColorsSize, BitsSize : Integer;
+ BIH: TBitmapInfoHeader;
+ x, y: Integer;
+ Line: PByte;
+ Buffer: PByteArray;
+ begin
+ Result := False;
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ HandleType := bmDIB; // convert to DIB if DDB
+ ZeroMemory( @BFH, Sizeof( BFH ) );
+ ColorsSize := 0;
+ with fDIBHeader.bmiHeader do
+ if biBitCount <= 8 then
+ ColorsSize := (1 shl biBitCount) * Sizeof( TRGBQuad );
+ BFH.bfOffBits := Sizeof( BFH ) + Sizeof( TBitmapInfoHeader ) + ColorsSize;
+ BitsSize := fDIBSize; //ScanLineSize * fHeight;
+ BFH.bfSize := BFH.bfOffBits + DWord( BitsSize );
+ BFH.bfType := $4D42; // 'BM';
+ if fDIBHeader.bmiHeader.biCompression <> 0 then
+ begin
+ ColorsSize := 12 + 16*sizeof(TRGBQuad);
+ Inc( BFH.bfOffBits, ColorsSize );
+ end;
+ if Strm.Write( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit; {>>>>>>>>}
+ BIH := fDIBHeader.bmiHeader;
+ MS := NewMemoryStream;
+ if fDIBHeader.bmiHeader.biBitCount = 8 then
+ begin
+ for y := Height-1 downto 0 do
+ begin
+ Line := ScanLine[y];
+ MS.Write( Line^, Width );
+ end;
+ end else
+ begin
+ Buffer := AllocMem( Width );
+ for y := Height-1 downto 0 do
+ begin
+ Line := ScanLine[y];
+ x := 0;
+ while x < Width do
+ begin
+ Buffer[x] := Line^ shr 4;
+ inc( x );
+ if x >= Width then break;
+ Buffer[x] := Line^ and 15;
+ inc( x );
+ inc( Line );
+ end;
+ MS.Write( Buffer^, Width );
+ end;
+ MS.WriteVal( 0, 2 );
+ end;
+ if fDIBHeader.bmiHeader.biBitCount = 8 then
+ BIH.biCompression := BI_RLE8
+ else BIH.biCompression := BI_RLE4;
+ if Strm.Write( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit; {>>>>>>>}
+ if Strm.Write( fDIBHeader.bmiColors, ColorsSize ) <> DWORD(ColorsSize) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if fDIBHeader.bmiHeader.biBitCount = 8 then
+ Result := WriteRLE8
+ else Result := WriteRLE4;
+ MS.Free;
+ end;
+begin
+ Pos := Strm.Position;
+ if (fDIBHeader.bmiHeader.biBitCount <> 4)
+ and (fDIBHeader.bmiHeader.biBitCount <> 8) then
+ begin
+ SaveToStream( Strm ); Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if not WriteBitmap then
+ Strm.Seek( Pos, spBegin );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.SetHandle(const Value: HBitmap);
+var B: tagBitmap;
+ Dib: TDIBSection;
+begin
+ Clear;
+ if Value = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if (WinVer >= wvNT) and
+ (GetObject( Value, Sizeof( Dib ), @ Dib ) = Sizeof( Dib ))
+ and (Dib.dsBmih.biBitCount > 8) then
+ begin
+ fHandle := Value;
+ fHandleType := bmDIB;
+ fDIBHeader := PrepareBitmapHeader( Dib.dsBm.bmWidth, Dib.dsBm.bmHeight,
+ Dib.dsBm.bmBitsPixel );
+ Move( Dib.dsBitfields, fDIBHeader.bmiColors, 3 * 4 );
+ fWidth := Dib.dsBm.bmWidth;
+ fHeight := Dib.dsBm.bmHeight;
+ fDIBBits := Dib.dsBm.bmBits;
+ fDIBSize := Dib.dsBmih.biSizeImage;
+ fDIBAutoFree := true;
+ end
+ else
+ begin
+ if GetObject( Value, Sizeof( B ), @B ) = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>}
+ fHandle := Value;
+ fWidth := B.bmWidth;
+ fHeight := B.bmHeight;
+ fHandleType := bmDDB;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TBitmap.SetWidth(const Value: Integer);
+begin
+ if fWidth = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fWidth := Value;
+ FormatChanged;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.SetHeight(const Value: Integer);
+{$IFNDEF SMALLER_CODE}
+var
+ pf : TPixelFormat;
+{$ENDIF SMALLER_CODE}
+begin
+ if fHeight = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+{$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;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.SetPixelFormat(Value: TPixelFormat);
+begin
+ if PixelFormat = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Value = pfDevice then
+ HandleType := bmDDB
+ else
+ begin
+ fNewPixelFormat := Value;
+ HandleType := bmDIB;
+ FormatChanged;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer;
+begin
+ Result := ((Header.biBitCount * Header.biWidth + 31) shr 3) and $FFFFFFFC;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure FillBmpWithBkColor( Bmp: PBitmap; DC2: HDC; oldWidth, oldHeight: Integer );
+var oldBmp: HBitmap;
+ R: TRect;
+ Br: HBrush;
+begin
+ with Bmp^ do
+ if Color2RGB( fBkColor ) <> 0 then
+ if (oldWidth < fWidth) or (oldHeight < fHeight) then
+ if GetHandle <> 0 then
+ begin
+ oldBmp := SelectObject( DC2, fHandle );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
+ {$ENDIF KOL_ASSERTIONS}
+ Br := CreateSolidBrush( Color2RGB( fBkColor ) );
+ R := MakeRect( oldWidth, oldHeight, fWidth, fHeight );
+ if oldWidth = fWidth then
+ R.Left := 0;
+ if oldHeight = fHeight then
+ R.Top := 0;
+ Windows.FillRect( DC2, R, Br );
+ DeleteObject( Br );
+ SelectObject( DC2, oldBmp );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+const BitCounts: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.FormatChanged;
+// This method is used whenever Width, Height, PixelFormat or HandleType
+// properties are changed.
+// Old image will be drawn here to a new one (excluding cases when
+// old width or height was 0, and / or new width or height is 0).
+// To avoid inserting this code into executable, try not to change
+// properties Width / Height of bitmat after it is created using
+// NewBitmap( W, H ) function or after it is loaded from file, stream or resource.
+var B: tagBitmap;
+ oldBmp, NewHandle: HBitmap;
+ DC0, DC2: HDC;
+ NewHeader: PBitmapInfo;
+ NewBits: Pointer;
+ oldHeight, oldWidth, sizeBits, bitsPixel: Integer;
+ Br: HBrush;
+ N: Integer;
+ NewDIBAutoFree: Boolean;
+ Hndl: THandle;
+begin
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ NewDIBAutoFree := FALSE;
+ fDetachCanvas( @Self );
+ fScanLineSize := 0;
+ fGetDIBPixels := nil;
+ fSetDIBPixels := nil;
+
+ oldWidth := fWidth;
+ oldHeight := fHeight;
+ if fDIBBits <> nil then
+ begin
+ oldWidth := fDIBHeader.bmiHeader.biWidth;
+ oldHeight := Abs(fDIBHeader.bmiHeader.biHeight);
+ end
+ else
+ if fHandle <> 0 then
+ begin
+ if GetObject( fHandle, Sizeof( B ), @ B ) <> 0 then
+ begin
+ oldWidth := B.bmWidth;
+ oldHeight := B.bmHeight;
+ end;
+ end;
+
+ DC2 := CreateCompatibleDC( 0 );
+
+ if fHandleType = bmDDB then
+ begin
+ // New HandleType is bmDDB: old bitmap can be copied using Draw method
+ DC0 := GetDC( 0 );
+ NewHandle := CreateCompatibleBitmap( DC0, fWidth, fHeight );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( NewHandle <> 0, 'Can not create DDB' );
+ {$ENDIF KOL_ASSERTIONS}
+ ReleaseDC( 0, DC0 );
+
+ oldBmp := SelectObject( DC2, NewHandle );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
+ {$ENDIF KOL_ASSERTIONS}
+
+ Br := CreateSolidBrush( Color2RGB( fBkColor ) );
+ FillRect( DC2, MakeRect( 0, 0, fWidth, fHeight ), Br );
+ DeleteObject( Br );
+
+ if fDIBBits <> nil then
+ begin
+ SelectObject( DC2, oldBmp );
+ SetDIBits( DC2, NewHandle, 0, fHeight, fDIBBits, fDIBHeader^, DIB_RGB_COLORS );
+ end
+ else
+ begin
+ Draw( DC2, 0, 0 );
+ SelectObject( DC2, oldBmp );
+ end;
+
+ ClearData; // Image is cleared but fWidth and fHeight are preserved
+ fHandle := NewHandle;
+ end
+ else
+ begin
+ // New format is DIB. GetDIBits applied to transform old data to new one.
+ bitsPixel := BitCounts[ fNewPixelFormat ];
+ if bitsPixel = 0 then
+ begin
+ bitsPixel := BitCounts[DefaultPixelFormat];
+ end;
+
+ NewHandle := 0;
+ NewHeader := PrepareBitmapHeader( fWidth, fHeight, bitsPixel );
+ if fNewPixelFormat = pf16bit then
+ PreparePF16bit( NewHeader );
+
+ sizeBits := CalcScanLineSize( @NewHeader.bmiHeader ) * fHeight;
+
+ NewBits := Pointer( GlobalAlloc( GMEM_FIXED, sizeBits ) );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( NewBits <> nil, 'No memory' );
+ {$ENDIF KOL_ASSERTIONS}
+
+ Hndl := GetHandle;
+ if Hndl = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ N :=
+ GetDIBits( DC2, Hndl, 0, Min( fHeight, oldHeight ),
+ NewBits, NewHeader^, DIB_RGB_COLORS );
+ if N <> Min( fHeight, oldHeight ) then
+ begin
+ GlobalFree( DWORD( NewBits ) );
+ NewBits := nil;
+ NewHandle := CreateDIBSection( DC2, NewHeader^, DIB_RGB_COLORS, NewBits, 0, 0 );
+ NewDIBAutoFree := TRUE;
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( NewHandle <> 0, 'Can not create DIB secion for pf16bit bitmap' );
+ {$ENDIF KOL_ASSERTIONS}
+ oldBmp := SelectObject( DC2, NewHandle );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( oldBmp <> 0, 'Can not select pf16bit to DC' );
+ {$ENDIF KOL_ASSERTIONS}
+ Draw( DC2, 0, 0 );
+ SelectObject( DC2, oldBmp );
+ end;
+
+ ClearData;
+ fDIBSize := sizeBits;
+ fDIBBits := NewBits;
+ fDIBHeader := NewHeader;
+ fHandle := NewHandle;
+ fDIBAutoFree := NewDIBAutoFree;
+
+ end;
+
+ if Assigned( fFillWithBkColor ) then
+ fFillWithBkColor( @Self, DC2, oldWidth, oldHeight );
+
+ DeleteDC( DC2 );
+
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TBitmap.GetScanLine(Y: Integer): Pointer;
+begin
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( (Y >= 0) {and (Y < fHeight)}, 'ScanLine index out of bounds' );
+ ASSERT( fDIBBits <> nil, 'No bits available' );
+ {$ENDIF KOL_ASSERTIONS}
+ Result := nil;
+ if fDIBHeader = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if fDIBHeader.bmiHeader.biHeight > 0 then
+ Y := fHeight - 1 - Y;
+ if fScanLineSize = 0 then
+ ScanLineSize;
+
+ Result := Pointer( Integer( fDIBBits ) + fScanLineSize * Y );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TBitmap.GetScanLineSize: Integer;
+begin
+ Result := 0;
+ if fDIBHeader = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FScanLineSize := CalcScanLineSize( @fDIBHeader.bmiHeader );
+ Result := FScanLineSize;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.CanvasChanged( Sender : PObj );
+begin
+ fBkColor := PCanvas( Sender ).Brush.Color;
+ ClearTransImage;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.Dormant;
+begin
+ RemoveCanvas;
+ if fHandle <> 0 then
+ DeleteObject( ReleaseHandle );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.SetBkColor(const Value: TColor);
+begin
+ if fBkColor = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fBkColor := Value;
+ fFillWithBkColor := FillBmpWithBkColor;
+ if Assigned( fApplyBkColor2Canvas ) then
+ fApplyBkColor2Canvas( @Self );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TBitmap.Assign(SrcBmp: PBitmap): Boolean;
+begin
+ Clear;
+ Result := False;
+ if SrcBmp = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if SrcBmp.Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fWidth := SrcBmp.fWidth;
+ fHeight := SrcBmp.fHeight;
+ fHandleType := SrcBmp.fHandleType;
+ //fNewPixelFormat := SrcBmp.PixelFormat;
+ if SrcBmp.fHandleType = bmDDB then
+ begin
+ fHandle := CopyImage( SrcBmp.fHandle, IMAGE_BITMAP, 0, 0, 0 {LR_COPYRETURNORG} );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( fHandle <> 0, 'Can not copy bitmap image' );
+ {$ENDIF KOL_ASSERTIONS}
+ Result := fHandle <> 0;
+ if not Result then Clear;
+ end
+ else
+ begin
+ GetMem( fDIBHeader, Sizeof(TBitmapInfoHeader) + 256*sizeof(TRGBQuad) );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( fDIBHeader <> nil, 'No memory' );
+ {$ENDIF KOL_ASSERTIONS}
+ Move( SrcBmp.fDIBHeader^, fDIBHeader^, Sizeof(TBitmapInfoHeader) + 256*sizeof(TRGBQuad) );
+ fDIBSize := SrcBmp.fDIBSize;
+ fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED {or GMEM_ZEROINIT}, fDIBSize ) );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( fDIBBits <> nil, 'No memory' );
+ {$ENDIF KOL_ASSERTIONS}
+ Move( SrcBmp.fDIBBits^, fDIBBits^, fDIBSize );
+ Result := True;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.RemoveCanvas;
+begin
+ fDetachCanvas( @Self );
+ fCanvas.Free;
+ fCanvas := nil;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TBitmap.DIBPalNearestEntry(Color: TColor): Integer;
+var I, Diff, D: Integer;
+ C : Integer;
+begin
+ Color := TColor( Color2RGBQuad( Color ) );
+ Result := 0;
+ Diff := MaxInt;
+ for I := 0 to DIBPalEntryCount - 1 do
+ begin
+ C := Color xor PInteger( Integer( @fDIBHeader.bmiColors[ 0 ] )
+ + I * Sizeof( TRGBQuad ) )^;
+ D := TRGBQuad( C ).rgbBlue + TRGBQuad( C ).rgbGreen + TRGBQuad( C ).rgbRed;
+ if D < Diff then
+ begin
+ Diff := D;
+ Result := I;
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TBitmap.GetDIBPalEntries(Idx: Integer): TColor;
+begin
+ Result := TColor(-1);
+ if fDIBBits = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( PixelFormat in [pf1bit..pf8bit], 'Format has no DIB palette entries available' );
+ ASSERT( (Idx >= 0) and (Idx < (1 shl fDIBHeader.bmiHeader.biBitCount)),
+ 'DIB palette index out of bounds' );
+ {$ENDIF KOL_ASSERTIONS}
+ Result := PDWORD( Integer( @fDIBHeader.bmiColors[ 0 ] )
+ + Idx * Sizeof( TRGBQuad ) )^;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TBitmap.GetDIBPalEntryCount: Integer;
+begin
+ Result := 0;
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ case PixelFormat of
+ pf1bit: Result := 2;
+ pf4bit: Result := 16;
+ pf8bit: Result := 256;
+ else;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TBitmap.SetDIBPalEntries(Idx: Integer; const Value: TColor);
+begin
+ if fDIBBits = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Dormant;
+ PDWORD( Integer( @fDIBHeader.bmiColors[ 0 ] )
+ + Idx * Sizeof( TRGBQuad ) )^ := Color2RGB( Value );
+end;
+
+procedure TBitmap.SetHandleType(const Value: TBitmapHandleType);
+begin
+ if fHandleType = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fHandleType := Value;
+ FormatChanged;
+end;
+
+function TBitmap.GetPixelFormat: TPixelFormat;
+begin
+ if (HandleType = bmDDB) or (fDIBBits = nil) then
+ Result := pfDevice
+ else
+ begin
+ Result := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount );
+ if fDIBHeader.bmiHeader.biCompression <> 0 then
+ begin
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS, 'Unsupported bitmap format' );
+ {$ENDIF KOL_ASSERTIONS}
+ if (TColor( fDIBHeader.bmiColors[ 0 ] ) = $F800) and
+ (PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+4 )^ = $7E0) and
+ (PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+8 )^ = $1F) then
+ Result := pf16bit
+ else
+ if (TColor( fDIBHeader.bmiColors[ 0 ] ) = $7C00) and
+ (PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+4 )^ = $3E0) and
+ (PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+8 )^ = $1F) then
+ Result := pf15bit
+ else
+ Result := pfCustom;
+ end;
+ end;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.ClearTransImage;
+begin
+ fTransColor := clNone;
+ fTransMaskBmp.Free;
+ fTransMaskBmp := nil;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+{$IFDEF USE_OLDCONVERT2MASK}
+procedure TBitmap.Convert2Mask(TranspColor: TColor);
+var MonoHandle: HBitmap;
+ SaveMono, SaveFrom: THandle;
+ MonoDC, DCfrom: HDC;
+ SaveBkColor: TColorRef;
+begin
+ if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fDetachCanvas( @Self );
+ MonoHandle := CreateBitmap( fWidth, fHeight, 1, 1, nil );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( MonoHandle <> 0, 'Can not create monochrome bitmap' );
+ {$ENDIF KOL_ASSERTIONS}
+ MonoDC := CreateCompatibleDC( 0 );
+ SaveMono := SelectObject( MonoDC, MonoHandle );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( SaveMono <> 0, 'Can not select bitmap to DC' );
+ {$ENDIF KOL_ASSERTIONS}
+ DCfrom := CreateCompatibleDC( 0 );
+ SaveFrom := SelectObject( DCfrom, fHandle );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( SaveFrom <> 0, 'Can not select source bitmap to DC' );
+ {$ENDIF KOL_ASSERTIONS}
+ TranspColor := Color2RGB( TranspColor );
+ SaveBkColor := Windows.SetBkColor( DCfrom, TranspColor );
+ BitBlt( MonoDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, SRCCOPY );
+ {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
+ Windows.SetBkColor( DCfrom, SaveBkColor );
+ SelectObject( DCfrom, SaveFrom );
+ DeleteDC( DCfrom );
+ SelectObject( MonoDC, SaveMono );
+ DeleteDC( MonoDC );
+ ///ReleaseDC( 0, DC0 );
+ ClearData;
+ fHandle := MonoHandle;
+ fHandleType := bmDDB;
+end;
+{$ELSE NOT USE_OLDCONVERT2MASK} //Pascal
+procedure TBitmap.Convert2Mask(TranspColor: TColor);
+var Y, X, i: Integer;
+ Src, Dst: PByte;
+ W: Word;
+ TmpMsk: PBitmap;
+ B, C: Byte;
+ TranspColor32: TColor;
+begin
+ HandleType := bmDIB;
+ if PixelFormat < pf4bit then
+ PixelFormat := pf4bit;
+ if PixelFormat > pf32bit then
+ PixelFormat := pf32bit;
+ TranspColor := Color2RGB( TranspColor ) and $FFFFFF;
+ TranspColor32 := TColor( Color2RGBQuad( TranspColor ) );
+ TmpMsk := NewDIBBitmap( fWidth, fHeight, pf1bit );
+ TmpMsk.DIBPalEntries[ 1 ] := $FFFFFF;
+ for Y := 0 to fHeight-1 do
+ begin
+ Src := ScanLine[ Y ];
+ Dst := TmpMsk.ScanLine[ Y ];
+ B := 0; C := 8;
+ CASE PixelFormat OF
+ pf4bit:
+ begin
+ W := 16;
+ for i := 0 to 15 do
+ if DIBPalEntries[ i ] = TranspColor32 then
+ begin
+ W := i; break;
+ end;
+ for X := 0 to (fWidth div 2)-1 do
+ begin
+ B := B shl 1;
+ if Src^ shr 4 = W then inc( B );
+ B := B shl 1;
+ if Src^ and $0F = W then inc( B );
+ Inc( Src );
+ Dec( C, 2 );
+ if C = 0 then
+ begin
+ Dst^ := B;
+ Inc( Dst );
+ C := 8;
+ end;
+ end;
+ end;
+ pf8bit:
+ begin
+ W := 256;
+ for i := 0 to 255 do
+ if DIBPalEntries[ i ] = TranspColor32 then
+ begin
+ W := i; break;
+ end;
+ for X := 0 to fWidth-1 do
+ begin
+ B := B shl 1;
+ if Src^ = W then inc( B );
+ Inc( Src );
+ Dec( C );
+ if C = 0 then
+ begin
+ Dst^ := B;
+ Inc( Dst );
+ C := 8;
+ end;
+ end;
+ end;
+ pf15bit:
+ begin
+ W := Color2Color15( TranspColor );
+ for X := 0 to fWidth-1 do
+ begin
+ B := B shl 1;
+ if PWord( Src )^ = W then inc( B );
+ Inc( Src, 2 );
+ Dec( C );
+ if C = 0 then
+ begin
+ Dst^ := B;
+ Inc( Dst );
+ C := 8;
+ end;
+ end;
+ end;
+ pf16bit:
+ begin
+ W := Color2Color16( TranspColor );
+ for X := 0 to fWidth-1 do
+ begin
+ B := B shl 1;
+ if PWord( Src )^ = W then inc( B );
+ Inc( Src, 2 );
+ Dec( C );
+ if C = 0 then
+ begin
+ Dst^ := B;
+ Inc( Dst );
+ C := 8;
+ end;
+ end;
+ end;
+ pf24bit:
+ begin
+ for X := 0 to fWidth-1 do
+ begin
+ B := B shl 1;
+ if PInteger( Src )^ and $FFFFFF = TranspColor32 then inc( B );
+ Inc( Src, 3 );
+ Dec( C );
+ if C = 0 then
+ begin
+ Dst^ := B;
+ Inc( Dst );
+ C := 8;
+ end;
+ end;
+ end;
+ pf32bit:
+ begin
+ for X := 0 to fWidth-1 do
+ begin
+ B := B shl 1;
+ if PInteger( Src )^ and $FFFFFF = TranspColor32 then inc( B );
+ Inc( Src, 4 );
+ Dec( C );
+ if C = 0 then
+ begin
+ Dst^ := B;
+ Inc( Dst );
+ C := 8;
+ end;
+ end;
+ end;
+ END;
+ if (C > 0) and (C < 8) then
+ begin
+ while C > 0 do
+ begin
+ B := B shl 1;
+ dec( C );
+ end;
+ Dst^ := B;
+ end;
+ end;
+ Assign( TmpMsk );
+ TmpMsk.Free;
+end;
+{$ENDIF USE_OLDCONVERT2MASK} //Pascal
+{$ENDIF PAS_VERSION}
+
+procedure TBitmap.Invert;
+var R: TRect;
+begin
+ //BitBlt( Canvas.Handle, 0, 0, Width, Height, Canvas.Handle, 0, 0, DSTINVERT )
+ R := BoundsRect;
+ InvertRect(Canvas.Handle, R);
+end;
+
+procedure TBitmap.DIBDrawRect( DC: HDC; X, Y: Integer; const R: TRect );
+begin
+ if fDIBBits = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ StretchDIBits( DC, X, Y, R.Right - R.Left, R.Bottom - R.Top,
+ R.Left, fHeight - R.Bottom, R.Right - R.Left, R.Bottom - R.Top,
+ fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure _RotateBitmapMono( var DstBmp: PBitmap; SrcBmp: PBitmap );
+var X, Y, Z, Shf, Wbytes, BytesPerDstLine: Integer;
+ Src, Dst, Dst1: PByte;
+ Tmp: Byte;
+begin
+
+ DstBmp := NewDIBBitmap( SrcBmp.fHeight, (SrcBmp.fWidth + 7) and not 7, pf1bit );
+ Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 2 * Sizeof( TRGBQuad ) );
+
+ // Calculate ones:
+ Dst := DstBmp.ScanLine[ 0 ];
+ BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst );
+ Wbytes := (SrcBmp.fWidth + 7) shr 3;
+
+ Inc( Dst, (DstBmp.fWidth - 1) shr 3 );
+ Shf := (DstBmp.fWidth - 1) and 7;
+
+ // Rotating bits:
+ for Y := 0 to SrcBmp.fHeight - 1 do
+ begin
+ Src := SrcBmp.ScanLine[ Y ];
+ Dst1 := Dst;
+ for X := Wbytes downto 1 do
+ begin
+ Tmp := Src^;
+ Inc( Src );
+ for Z := 8 downto 1 do
+ begin
+ Dst1^ := Dst1^ or ( (Tmp and $80) shr Shf );
+ Tmp := Tmp shl 1;
+ Inc( Dst1, BytesPerDstLine );
+ end;
+ end;
+ Dec( Shf );
+ if Shf < 0 then
+ begin
+ Shf := 7;
+ Dec( Dst );
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure _RotateBitmap4bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
+var X, Y, Shf, Wbytes, BytesPerDstLine: Integer;
+ Src, Dst, Dst1: PByte;
+ Tmp: Byte;
+begin
+ DstBmp := NewDIBBitmap( SrcBmp.fHeight, (SrcBmp.fWidth + 1) and not 1, pf4bit );
+ Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 16 * Sizeof( TRGBQuad ) );
+
+ // Calculate ones:
+ Dst := DstBmp.ScanLine[ 0 ];
+ BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst );
+ Wbytes := (SrcBmp.fWidth + 1) shr 1;
+ Inc( Dst, (DstBmp.fWidth - 1) shr 1 );
+ Shf := ((DstBmp.fWidth - 1) and 1) shl 2;
+
+ // Rotating bits:
+ for Y := 0 to SrcBmp.fHeight - 1 do
+ begin
+ Src := SrcBmp.ScanLine[ Y ];
+ Dst1 := Dst;
+ for X := Wbytes downto 1 do
+ begin
+ Tmp := Src^;
+ Inc( Src );
+ Dst1^ := Dst1^ or ( (Tmp and $F0) shr Shf );
+ Inc( Dst1, BytesPerDstLine );
+ Dst1^ := Dst1^ or ( ((Tmp shl 4) and $F0) shr Shf );
+ Inc( Dst1, BytesPerDstLine );
+ end;
+ Dec( Shf, 4 );
+ if Shf < 0 then
+ begin
+ Shf := 4;
+ Dec( Dst );
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure _RotateBitmap8bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
+var X, Y, Wbytes, BytesPerDstLine: Integer;
+ Src, Dst, Dst1: PByte;
+ Tmp: Byte;
+begin
+
+ DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );
+ Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 256 * Sizeof( TRGBQuad ) );
+
+ // Calculate ones:
+ Wbytes := SrcBmp.fWidth;
+ Dst := DstBmp.ScanLine[ 0 ];
+ BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst );
+
+ Inc( Dst, DstBmp.fWidth - 1 );
+
+ // Rotating bits:
+ for Y := 0 to SrcBmp.fHeight - 1 do
+ begin
+ Src := SrcBmp.ScanLine[ Y ];
+ Dst1 := Dst;
+ for X := Wbytes downto 1 do
+ begin
+ Tmp := Src^;
+ Inc( Src );
+ Dst1^ := Tmp;
+ Inc( Dst1, BytesPerDstLine );
+ end;
+ Dec( Dst );
+ end;
+
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure _RotateBitmap16bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
+var X, Y, Wwords, BytesPerDstLine: Integer;
+ Src, Dst, Dst1: PWord;
+ Tmp: Word;
+begin
+ DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );
+ Wwords := SrcBmp.fWidth;
+ Dst := DstBmp.ScanLine[ 0 ];
+ BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst );
+ Inc( Dst, DstBmp.fWidth - 1 );
+
+ // Rotating bits:
+ for Y := 0 to SrcBmp.fHeight - 1 do
+ begin
+ Src := SrcBmp.ScanLine[ Y ];
+ Dst1 := Dst;
+ for X := Wwords downto 1 do
+ begin
+ Tmp := Src^;
+ Inc( Src );
+ Dst1^ := Tmp;
+ Inc( PByte(Dst1), BytesPerDstLine );
+ end;
+ Dec( Dst );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure _RotateBitmap2432bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
+var X, Y, Wwords, BytesPerDstLine, IncW: Integer;
+ Src, Dst, Dst1: PDWord;
+ Tmp: DWord;
+begin
+
+ DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );
+
+ // Calculate ones:
+ IncW := 4;
+ if DstBmp.PixelFormat = pf24bit then
+ IncW := 3;
+ Wwords := SrcBmp.fWidth;
+ Dst := DstBmp.ScanLine[ 0 ];
+ BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst );
+
+ Inc( PByte(Dst), (DstBmp.fWidth - 1) * IncW );
+
+ // Rotating bits:
+ for Y := 0 to SrcBmp.fHeight - 1 do
+ begin
+ Src := SrcBmp.ScanLine[ Y ];
+ Dst1 := Dst;
+ for X := Wwords downto 1 do
+ begin
+ Tmp := Src^ and $FFFFFF;
+ Inc( PByte(Src), IncW );
+ Dst1^ := Dst1^ or Tmp;
+ Inc( PByte(Dst1), BytesPerDstLine );
+ end;
+ Dec( PByte(Dst), IncW );
+ end;
+
+end;
+{$ENDIF PAS_VERSION}
+
+type
+ TRotateBmpRefs = packed record
+ proc_RotateBitmapMono: procedure( var Dst: PBitmap; Src: PBitmap );
+ proc_RotateBitmap4bit: procedure( var Dst: PBitmap; Src: PBitmap );
+ proc_RotateBitmap8bit: procedure( var Dst: PBitmap; Src: PBitmap );
+ proc_RotateBitmap16bit: procedure( var Dst: PBitmap; Src: PBitmap );
+ proc_RotateBitmap2432bit: procedure( var Dst: PBitmap; Src: PBitmap );
+ end;
+
+var
+ RotateProcs: TRotateBmpRefs;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure _RotateBitmapRight( SrcBmp: PBitmap );
+var DstBmp: PBitmap;
+ RotateProc: procedure( var DstBmp: PBitmap; SrcBmp: PBitmap );
+begin
+ if SrcBmp.fHandleType <> bmDIB then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ case SrcBmp.PixelFormat of
+ pf1bit: RotateProc := RotateProcs.proc_RotateBitmapMono;
+ pf4bit: RotateProc := RotateProcs.proc_RotateBitmap4bit;
+ pf8bit: RotateProc := RotateProcs.proc_RotateBitmap8bit;
+ pf15bit, pf16bit: RotateProc := RotateProcs.proc_RotateBitmap16bit;
+ else RotateProc := RotateProcs.proc_RotateBitmap2432bit;
+ end;
+ if not Assigned( RotateProc ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ RotateProc( DstBmp, SrcBmp );
+ if DstBmp.fHeight > SrcBmp.fWidth then
+ begin
+ DstBmp.fDIBSize := DstBmp.fScanLineSize * SrcBmp.fWidth;
+ if DstBmp.fDIBHeader.bmiHeader.biHeight > 0 then
+ Move( DstBmp.ScanLine[ SrcBmp.fWidth - 1 ]^, DstBmp.ScanLine[ DstBmp.fHeight - 1 ]^,
+ DstBmp.fDIBSize );
+ DstBmp.fHeight := SrcBmp.fWidth;
+ DstBmp.fDIBHeader.bmiHeader.biHeight := DstBmp.fHeight;
+ end;
+
+ SrcBmp.ClearData;
+
+ SrcBmp.fDIBHeader := DstBmp.fDIBHeader;
+ DstBmp.fDIBHeader := nil;
+
+ SrcBmp.fDIBBits := DstBmp.fDIBBits;
+ DstBmp.fDIBBits := nil;
+ SrcBmp.fDIBAutoFree := DstBmp.fDIBAutoFree;
+
+ SrcBmp.fDIBSize := DstBmp.fDIBSize;
+
+ SrcBmp.fWidth := DstBmp.fWidth;
+ SrcBmp.fHeight := DstBmp.fHeight;
+ DstBmp.Free;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TBitmap.RotateRight;
+const AllRotators: TRotateBmpRefs = (
+ proc_RotateBitmapMono: _RotateBitmapMono;
+ proc_RotateBitmap4bit: _RotateBitmap4bit;
+ proc_RotateBitmap8bit: _RotateBitmap8bit;
+ proc_RotateBitmap16bit: _RotateBitmap16bit;
+ proc_RotateBitmap2432bit: _RotateBitmap2432bit );
+begin
+ RotateProcs := AllRotators;
+ _RotateBitmapRight( @Self );
+end;
+
+procedure _RotateBitmapLeft( Src: PBitmap );
+begin
+ _RotateBitmapRight( Src );
+ _RotateBitmapRight( Src );
+ _RotateBitmapRight( Src );
+end;
+
+procedure TBitmap.RotateLeft;
+begin
+ RotateRight;
+ _RotateBitmapRight( @Self );
+ _RotateBitmapRight( @Self );
+end;
+
+procedure TBitmap.RotateLeftMono;
+begin
+ if PixelFormat <> pf1bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ RotateProcs.proc_RotateBitmapMono := _RotateBitmapMono;
+ _RotateBitmapRight( @Self );
+end;
+
+procedure TBitmap.RotateRightMono;
+begin
+ if PixelFormat <> pf1bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ RotateProcs.proc_RotateBitmapMono := _RotateBitmapMono;
+ _RotateBitmapLeft( @Self );
+end;
+
+procedure TBitmap.RotateLeft16bit;
+begin
+ if PixelFormat <> pf16bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ RotateProcs.proc_RotateBitmap16bit := _RotateBitmap16bit;
+ _RotateBitmapLeft( @Self );
+end;
+
+procedure TBitmap.RotateLeft4bit;
+begin
+ if PixelFormat <> pf4bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ RotateProcs.proc_RotateBitmap4bit := _RotateBitmap4bit;
+ _RotateBitmapLeft( @Self );
+end;
+
+procedure TBitmap.RotateLeft8bit;
+begin
+ if PixelFormat <> pf8bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ RotateProcs.proc_RotateBitmap8bit := _RotateBitmap8bit;
+ _RotateBitmapLeft( @Self );
+end;
+
+procedure TBitmap.RotateLeftTrueColor;
+begin
+ if not (PixelFormat in [ pf24bit, pf32bit ]) then Exit; {>>>>>>>>>>>>>>>>>>>>}
+ RotateProcs.proc_RotateBitmap2432bit := _RotateBitmap2432bit;
+ _RotateBitmapLeft( @Self );
+end;
+
+procedure TBitmap.RotateRight16bit;
+begin
+ if PixelFormat <> pf16bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ RotateProcs.proc_RotateBitmap16bit := _RotateBitmap16bit;
+ _RotateBitmapRight( @Self );
+end;
+
+procedure TBitmap.RotateRight4bit;
+begin
+ if PixelFormat <> pf4bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ RotateProcs.proc_RotateBitmap4bit := _RotateBitmap4bit;
+ _RotateBitmapRight( @Self );
+end;
+
+procedure TBitmap.RotateRight8bit;
+begin
+ if PixelFormat <> pf8bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ RotateProcs.proc_RotateBitmap8bit := _RotateBitmap8bit;
+ _RotateBitmapRight( @Self );
+end;
+
+procedure TBitmap.RotateRightTrueColor;
+begin
+ if not (PixelFormat in [ pf24bit, pf32bit ]) then Exit; {>>>>>>>>>>>>>>>>>>>>}
+ RotateProcs.proc_RotateBitmap2432bit := _RotateBitmap2432bit;
+ _RotateBitmapRight( @Self );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TBitmap.GetPixels(X, Y: Integer): TColor;
+var DC: HDC;
+ Save: THandle;
+begin
+ Result := clNone;
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fDetachCanvas( @Self );
+ DC := CreateCompatibleDC( 0 );
+ Save := SelectObject( DC, GetHandle );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( Save <> 0, 'Can not select bitmap to DC' );
+ {$ENDIF KOL_ASSERTIONS}
+ Result := Windows.GetPixel( DC, X, Y );
+ SelectObject( DC, Save );
+ DeleteDC( DC );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.SetPixels(X, Y: Integer; const Value: TColor);
+var DC: HDC;
+ Save: THandle;
+begin
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fDetachCanvas( @Self );
+ DC := CreateCompatibleDC( 0 );
+ Save := SelectObject( DC, GetHandle );
+ {$IFDEF KOL_ASSERTIONS}
+ ASSERT( Save <> 0, 'Can not select bitmap to DC' );
+ {$ENDIF KOL_ASSERTIONS}
+ Windows.SetPixel( DC, X, Y, Color2RGB( Value ) );
+ SelectObject( DC, Save );
+ DeleteDC( DC );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function _GetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer ): TColor;
+var Pixel: Byte;
+begin
+ Pixel := PByte( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta
+ + (X div (Bmp.fPixelsPerByteMask + 1)) )^;
+ Pixel := ( Pixel shr ( (Bmp.fPixelsPerByteMask - (X and Bmp.fPixelsPerByteMask))
+ * Bmp.fDIBHeader.bmiHeader.biBitCount ) )
+ and Bmp.fPixelMask;
+ Result := TColor( Color2RGBQuad( TColor( PRGBQuad( DWORD(@Bmp.fDIBHeader.bmiColors[ 0 ])
+ + Pixel * Sizeof( TRGBQuad ) )^ ) ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function _GetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer ): TColor;
+var Pixel: Word;
+begin
+ Pixel := PWord( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta + X * 2 )^;
+ if Bmp.fPixelMask = 15 then
+ Result := (Pixel shr 7) and $F8 or (Pixel shl 6) and $F800
+ or (Pixel shl 19) and $F80000
+ else
+ Result := (Pixel shr 8) and $F8 or (Pixel shl 5) and $FC00
+ or (Pixel shl 19) and $F80000;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function _GetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer ): TColor;
+var Pixel: DWORD;
+begin
+ Pixel := PDWORD( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta +
+ X * Bmp.fBytesPerPixel )^ and $FFFFFF;
+ Result := TColor( Color2RGBQuad( TColor( Pixel ) ) );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+function _GetDIBPixelsTrueColorAlpha( Bmp: PBitmap; X, Y: Integer ): TColor;
+var Pixel: DWORD;
+ RGB: TRGBQuad;
+ blue, red: Byte;
+begin
+ Pixel := PDWORD( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta +
+ X * Bmp.fBytesPerPixel )^;
+ RGB := TRGBQuad(Pixel);
+ blue := RGB.rgbRed;
+ red := RGB.rgbBlue;
+ RGB.rgbBlue := blue;
+ RGB.rgbRed := red;
+ Result := TColor( RGB );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TBitmap.GetDIBPixels(X, Y: Integer): TColor;
+begin
+ if not Assigned( fGetDIBPixels ) then
+ begin
+ if fHandleType = bmDIB then
+ begin
+ fScanLine0 := ScanLine[ 0 ];
+ fScanLineDelta := Integer(ScanLine[ 1 ]) - Integer(fScanLine0);
+ case PixelFormat of
+ pf1bit:
+ begin
+ fPixelMask := $01;
+ fPixelsPerByteMask := 7;
+ fGetDIBPixels := _GetDIBPixelsPalIdx;
+ end;
+ pf4bit:
+ begin
+ fPixelMask := $0F;
+ fPixelsPerByteMask := 1;
+ fGetDIBPixels := _GetDIBPixelsPalIdx;
+ end;
+ pf8bit:
+ begin
+ fPixelMask := $FF;
+ fPixelsPerByteMask := 0;
+ fGetDIBPixels := _GetDIBPixelsPalIdx;
+ end;
+ pf15bit:
+ begin
+ fPixelMask := 15;
+ fGetDIBPixels := _GetDIBPixels16bit;
+ end;
+ pf16bit:
+ begin
+ fPixelMask := 16;
+ fGetDIBPixels := _GetDIBPixels16bit;
+ end;
+ pf24bit:
+ begin
+ fPixelsPerByteMask := 0;
+ fBytesPerPixel := 3;
+ fGetDIBPixels := _GetDIBPixelsTrueColor;
+ end;
+ pf32bit:
+ begin
+ fPixelsPerByteMask := 1;
+ fBytesPerPixel := 4;
+ fGetDIBPixels := {$IFDEF DIBPixels32bitWithAlpha} _GetDIBPixelsTrueColorAlpha
+ {$ELSE} _GetDIBPixelsTrueColor {$ENDIF};
+ end;
+ else;
+ end;
+ end;
+ if not Assigned( fGetDIBPixels ) then
+ begin
+ Result := Pixels[ X, Y ]; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ Result := fGetDIBPixels( @Self, X, Y );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure _SetDIBPixels1bit( Bmp: PBitmap; X, Y: Integer; Value: TColor );
+var Pixel: Byte;
+ Pos: PByte;
+ Shf: Integer;
+begin
+ Value := Color2RGB( Value );
+ if ((Value shr 16) and $FF) + ((Value shr 8) and $FF) + (Value and $FF)
+ < 255 * 3 div 2 then Pixel := 0 else Pixel := $80;
+ Pos := PByte( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta + X div 8 );
+ Shf := X and 7;
+ Pos^ := Pos^ and ($FF7F shr Shf) or (Pixel shr Shf);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure _SetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer; Value: TColor );
+var Pixel: Byte;
+ Pos: PByte;
+ Shf: Integer;
+begin
+ Pixel := Bmp.DIBPalNearestEntry( Value );
+ Pos := PByte( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta
+ + X div (Bmp.fPixelsPerByteMask + 1) );
+ Shf := (Bmp.fPixelsPerByteMask - (X and Bmp.fPixelsPerByteMask))
+ * Bmp.fDIBHeader.bmiHeader.biBitCount;
+ Pos^ := Pos^ and not (Bmp.fPixelMask shl Shf) or (Pixel shl Shf);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure _SetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer; Value: TColor );
+var RGB16: Word;
+ Pos: PWord;
+begin
+ Value := Color2RGB( Value );
+ if Bmp.fPixelMask = 15 then
+ RGB16 := (Value shr 19) and $001F or (Value shr 6) and $03E0
+ or (Value shl 7) and $7C00
+ else
+ RGB16 := (Value shr 19) and $001F or (Value shr 5) and $07E0
+ or (Value shl 8) and $F800;
+ Pos := PWord( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta + X * 2 );
+ Pos^ := RGB16;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure _SetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer; Value: TColor );
+var RGB: TRGBQuad;
+ Pos: PDWord;
+begin
+ RGB := Color2RGBQuad( Value );
+ Pos := PDWORD( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta
+ + X * Bmp.fBytesPerPixel );
+ Pos^ := Pos^ and $FF000000 or DWORD(RGB);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+procedure _SetDIBPixelsTrueColorAlpha( Bmp: PBitmap; X, Y: Integer; Value: TColor );
+var RGB: TRGBQuad;
+ Pos: PDWord;
+ blue, red: Byte;
+begin
+ RGB := TRGBQuad(Value);
+ blue := RGB.rgbRed;
+ red := RGB.rgbBlue;
+ RGB.rgbBlue := blue;
+ RGB.rgbRed := red;
+ Pos := PDWORD( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta
+ + X * Bmp.fBytesPerPixel );
+ Pos^ := Pos^ or DWORD(RGB);
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.SetDIBPixels(X, Y: Integer; const Value: TColor);
+begin
+ if not Assigned( fSetDIBPixels ) then
+ begin
+ if fHandleType = bmDIB then
+ begin
+ fScanLine0 := ScanLine[ 0 ];
+ fScanLineDelta := Integer(ScanLine[ 1 ]) - Integer(fScanLine0);
+ case PixelFormat of
+ pf1bit:
+ begin
+ //fPixelMask := $01;
+ //fPixelsPerByteMask := 7;
+ fSetDIBPixels := _SetDIBPixels1bit;
+ end;
+ pf4bit:
+ begin
+ fPixelMask := $0F;
+ fPixelsPerByteMask := 1;
+ fSetDIBPixels := _SetDIBPixelsPalIdx;
+ end;
+ pf8bit:
+ begin
+ fPixelMask := $FF;
+ fPixelsPerByteMask := 0;
+ fSetDIBPixels := _SetDIBPixelsPalIdx;
+ end;
+ pf15bit:
+ begin
+ fPixelMask := 15;
+ fSetDIBPixels := _SetDIBPixels16bit;
+ end;
+ pf16bit:
+ begin
+ fPixelMask := 16;
+ fSetDIBPixels := _SetDIBPixels16bit;
+ end;
+ pf24bit:
+ begin
+ fPixelsPerByteMask := 0;
+ fBytesPerPixel := 3;
+ fSetDIBPixels := _SetDIBPixelsTrueColor;
+ end;
+ pf32bit:
+ begin
+ fPixelsPerByteMask := 1;
+ fBytesPerPixel := 4;
+ fSetDIBPixels := {$IFDEF DIBPixels32bitWithAlpha} _SetDIBPixelsTrueColorAlpha
+ {$ELSE} _SetDIBPixelsTrueColor {$ENDIF};
+ end;
+ else;
+ end;
+ end;
+ if not Assigned( fSetDIBPixels ) then
+ begin
+ Pixels[ X, Y ] := Value; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ fSetDIBPixels( @Self, X, Y, Value );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.FlipVertical;
+var DC: HDC;
+ Save: THandle;
+ TmpScan: PByte;
+ Y: Integer;
+begin
+ if fHandle <> 0 then
+ begin
+ fDetachCanvas( @Self );
+ DC := CreateCompatibleDC( 0 );
+ Save := SelectObject( DC, fHandle );
+ StretchBlt( DC, 0, fHeight - 1, fWidth, -fHeight, DC, 0, 0, fWidth, fHeight, SRCCOPY );
+ SelectObject( DC, Save );
+ DeleteDC( DC );
+ end
+ else
+ if fDIBBits <> nil then
+ begin
+ GetMem( TmpScan, ScanLineSize );
+ for Y := 0 to fHeight div 2-1 do
+ begin
+ Move( ScanLine[ Y ]^, TmpScan^, fScanLineSize );
+ Move( ScanLine[ fHeight - Y - 1 ]^, ScanLine[ Y ]^, fScanLineSize );
+ Move( TmpScan^, ScanLine[ fHeight - Y - 1 ]^, fScanLineSize );
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.FlipHorizontal;
+var DC: HDC;
+ Save: THandle;
+begin
+ if GetHandle <> 0 then
+ begin
+ fDetachCanvas( @Self );
+ DC := CreateCompatibleDC( 0 );
+ Save := SelectObject( DC, fHandle );
+ StretchBlt( DC, fWidth - 1, 0, -fWidth, fHeight, DC, 0, 0, fWidth, fHeight, SRCCOPY );
+ SelectObject( DC, Save );
+ DeleteDC( DC );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TBitmap.CopyRect(const DstRect: TRect; SrcBmp: PBitmap;
+ const SrcRect: TRect);
+var DCsrc, DCdst: HDC;
+ SaveSrc, SaveDst: THandle;
+begin
+ if (GetHandle = 0) or (SrcBmp.GetHandle = 0) then Exit; {>>>>>>>>>>>>>>>>>>>>}
+ fDetachCanvas( @Self );
+ SrcBmp.fDetachCanvas( SrcBmp );
+ DCsrc := CreateCompatibleDC( 0 );
+ SaveSrc := SelectObject( DCsrc, SrcBmp.fHandle );
+ DCdst := DCsrc;
+ SaveDst := 0;
+ if SrcBmp <> @Self then
+ begin
+ DCdst := CreateCompatibleDC( 0 );
+ SaveDst := SelectObject( DCdst, fHandle );
+ end;
+ StretchBlt( DCdst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
+ DstRect.Bottom - DstRect.Top, DCsrc, SrcRect.Left, SrcRect.Top,
+ SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top,
+ SRCCOPY );
+ if SrcBmp <> @Self then
+ begin
+ SelectObject( DCdst, SaveDst );
+ DeleteDC( DCdst );
+ end;
+ SelectObject( DCsrc, SaveSrc );
+ DeleteDC( DCsrc );
+end;
+{$ENDIF PAS_VERSION}
+
+function TBitmap.CopyToClipboard: Boolean;
+var DibMem: PAnsiChar;
+ HdrSize: Integer;
+ Gbl: HGlobal;
+ //Mem: PStream;
+ //Sz: Integer;
+ //Pt: Pointer;
+ Restore_Compression: Integer;
+begin
+ Result := FALSE;
+ if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if not OpenClipboard( Applet.GetWindowHandle ) then Exit; {>>>>>>>>>>>>>>>>>>}
+ if EmptyClipboard then
+ begin
+ HandleType := bmDIB;
+ HdrSize := sizeof( TBitmapInfoHeader );
+ Restore_Compression := -1;
+ TRY
+ if fDIBHeader.bmiHeader.biBitCount <= 8 then
+ Inc( HdrSize,
+ (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad ) )
+ else
+ begin
+ if fDIBHeader.bmiHeader.biCompression = BI_RGB then
+ begin
+ CASE fDIBHeader.bmiHeader.biBitCount OF
+ {24,} 32:
+ begin
+ Restore_Compression := fDIBHeader.bmiHeader.biCompression;
+ fDIBHeader.bmiHeader.biCompression := BI_BITFIELDS;
+ PDWORD( @ fDIBHeader.bmiColors[ 0 ] )^ := $FF0000;
+ PDWORD( Integer( @ fDIBHeader.bmiColors[ 0 ] ) + 4 )^ := $FF00;
+ PDWORD( Integer( @ fDIBHeader.bmiColors[ 0 ] ) + 8 )^ := $FF;
+ Inc( HdrSize, 12 );
+ end;
+ END;
+ end;
+ end;
+ Gbl := GlobalAlloc( GMEM_MOVEABLE, HdrSize + fDIBSize );
+ DibMem := GlobalLock( Gbl );
+ if DibMem <> nil then
+ begin
+ Move( fDIBHeader^, DibMem^, HdrSize );
+ Move( fDIBBits^, Pointer( Integer( DibMem ) + HdrSize )^, fDIBSize );
+ if not GlobalUnlock( Gbl ) and (GetLastError = NO_ERROR) then
+ begin
+ Result := SetClipboardData( CF_DIB, Gbl ) <> 0;
+ end;
+ end;
+ FINALLY
+ if Restore_Compression >= 0 then
+ fDIBHeader.bmiHeader.biCompression := Restore_Compression;
+ END;
+
+ end;
+ CloseClipboard;
+end;
+
+function TBitmap.PasteFromClipboard: Boolean;
+var Gbl: HGlobal;
+ Size {, HdrSize}: Integer;
+ Mem: PAnsiChar;
+ Strm: PStream;
+begin
+ Result := FALSE;
+ if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if not OpenClipboard( Applet.GetWindowHandle ) then Exit; {>>>>>>>>>>>>>>>>>>}
+ TRY
+ if IsClipboardFormatAvailable( CF_DIB ) then
+ begin
+ Gbl := GetClipboardData( CF_DIB );
+ if Gbl <> 0 then
+ begin
+ Size := GlobalSize( Gbl );
+ Mem := GlobalLock( Gbl );
+ TRY
+ if (Size > 0) and (Mem <> nil) then
+ begin
+ Strm := NewMemoryStream;
+ Strm.Write( Mem^, Size );
+ Strm.Position := 0;
+ LoadFromStreamEx( Strm );
+ Strm.Free;
+ Result := not Empty;
+ end;
+ FINALLY
+ GlobalUnlock( Gbl );
+ END;
+ end;
+ end;
+ FINALLY
+ CloseClipboard;
+ END;
+end;
+
+///////////////////////////////////////////////////////////////////////
+// I C O N
+///////////////////////////////////////////////////////////////////////
+
+{ -- icon -- }
+
+function NewIcon: PIcon;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TIcon';
+ {$ENDIF}
+ {$IFDEF ICON_DIFF_WH}
+ Result.FWidth := 32;
+ Result.FHeight := 32;
+ {$ELSE}
+ Result.FSize := 32;
+ {$ENDIF}
+end;
+
+{ TIcon }
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TIcon.Clear;
+begin
+ if fHandle <> 0 then
+ begin
+ if not FShareIcon then
+ DestroyIcon( fHandle );
+ fHandle := 0;
+ end;
+ fShareIcon := False;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_LOCAL}
+ {$UNDEF ASM_LOCAL}
+{$ENDIF}
+
+{$IFNDEF ICON_DIFF_WH}
+ {$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF}
+{$ENDIF}
+
+{$IFDEF ASM_LOCAL}
+{$ELSE PAS_VERSION} //Pascal
+function TIcon.Convert2Bitmap(TranColor: TColor): HBitmap;
+var DC0, DC2: HDC;
+ Save: THandle;
+ Br: HBrush;
+begin
+ Result := 0;
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ DC0 := GetDC( 0 );
+ DC2 := CreateCompatibleDC( DC0 );
+ {$IFDEF ICON_DIFF_WH}
+ Result := CreateCompatibleBitmap( DC0, fWidth, fHeight );
+ {$ELSE}
+ Result := CreateCompatibleBitmap( DC0, fSize, fSize );
+ {$ENDIF}
+ Save := SelectObject( DC2, Result );
+ Br := CreateSolidBrush( Color2RGB( TranColor ) );
+ {$IFDEF ICON_DIFF_WH}
+ FillRect( DC2, MakeRect( 0, 0, fWidth, fHeight ), Br );
+ {$ELSE}
+ FillRect( DC2, MakeRect( 0, 0, fSize, fSize ), Br );
+ {$ENDIF}
+ DeleteObject( Br );
+ Draw( DC2, 0, 0 );
+ SelectObject( DC2, Save );
+ DeleteDC( DC2 );
+ ReleaseDC( 0, DC0 );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+destructor TIcon.Destroy;
+begin
+ Clear;
+ inherited;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TIcon.Draw(DC: HDC; X, Y: Integer);
+begin
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF ICON_DIFF_WH}
+ DrawIconEx( DC, X, Y, fHandle, fWidth, fHeight, 0, 0, DI_NORMAL );
+ {$ELSE}
+ DrawIconEx( DC, X, Y, fHandle, fSize, fSize, 0, 0, DI_NORMAL );
+ {$ENDIF}
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TIcon.StretchDraw(DC: HDC; Dest: TRect);
+begin
+ if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ DrawIconEx( DC, Dest.Left, Dest.Top, FHandle, Dest.Right - Dest.Left,
+ Dest.Bottom - Dest.Top, 0, 0, DI_NORMAL );
+end;
+{$ENDIF PAS_VERSION}
+
+function TIcon.GetEmpty: Boolean;
+begin
+ Result := (fHandle = 0)
+ {$IFDEF ICONLOAD_PRESERVEBMPS}
+ and ((ImgBmp = nil) or ImgBmp.Empty)
+ {$ENDIF ICONLOAD_PRESERVEBMPS}
+ ;
+end;
+
+function TIcon.GetHotSpot: TPoint;
+var II : TIconInfo;
+begin
+ Result := MakePoint( 0, 0 );
+ if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ GetIconInfo( FHandle, II );
+ Result.x := II.xHotspot;
+ Result.y := II.yHotspot;
+ if II.hbmMask <> 0 then
+ DeleteObject( II.hbmMask );
+ if II.hbmColor <> 0 then
+ DeleteObject( II.hbmColor );
+end;
+
+procedure TIcon.LoadFromFile(const FileName: KOLString);
+var Strm : PStream;
+begin
+ Strm := NewReadFileStream( Filename );
+ LoadFromStream( Strm );
+ Strm.Free;
+end;
+
+procedure TIcon.LoadFromStream(Strm: PStream);
+var DesiredSize : Integer;
+ Pos : DWord;
+ Mem : PStream;
+ {$IFNDEF ICONLOAD_PRESERVEBMPS}
+ ImgBmp, MskBmp : PBitmap;
+ {$ENDIF ICONLOAD_PRESERVEBMPS}
+ TmpBmp: PBitmap;
+ function ReadIcon : Boolean;
+ var IH : TIconHeader;
+ IDI, FoundIDI : TIconDirEntry;
+ I, J, SumSz, FoundSz, D : Integer;
+ II : TIconInfo;
+ BIH : TBitmapInfoheader;
+ SzImg: DWORD;
+ begin
+ Result := False;
+ if Strm.Read( IH, Sizeof( IH ) ) <> Sizeof( IH ) then Exit; {>>>>>>>>>>>>>}
+ if (IH.idReserved = Sizeof( TBitmapInfoHeader )) then
+ begin
+ Strm.Position := Strm.Position - Sizeof( IH );
+ {$IFDEF ICON_DIFF_WH} fWidth := 0;
+ fHeight := 0;
+ {$ELSE} fSize := 0;
+ {$ENDIF}
+ SumSz := 0;
+ end
+ else
+ if (IH.idReserved = 0) and ((IH.idType = 1) or (IH.idType = 2)) and
+ (IH.idCount >= 1) then
+ begin
+ if (IH.idReserved <> 0) or ((IH.idType <> 1) and (IH.idType <> 2)) or
+ (IH.idCount < 1) or (IH.idCount >= 1024) then Exit; {>>>>>>>>>>>>>>>>}
+ SumSz := Sizeof( IH );
+ FoundSz := 1000000;
+ for I := 1 to IH.idCount do
+ begin
+ if Strm.Read( IDI, Sizeof( IDI ) ) <> Sizeof( IDI ) then Exit; {>>>>>}
+ Inc( SumSz, IDI.dwBytesInRes + Sizeof( IDI ) );
+ D := IDI.bWidth - DesiredSize;
+ if D < 0 then D := -D;
+ if D < FoundSz then
+ begin
+ FoundSz := D;
+ FoundIDI := IDI;
+ end;
+ end;
+ if FoundSz = 1000000 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Strm.Position := Integer( Pos ) + FoundIDI.dwImageOffset;
+ {$IFDEF ICON_DIFF_WH} fWidth := FoundIDI.bWidth;
+ fHeight := FoundIDI.bHeight;
+ {$ELSE} fSize := FoundIDI.bWidth;
+ {$ENDIF}
+ end else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if Strm.Read( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit; {>>>>>>>>>>}
+ {$IFDEF ICON_DIFF_WH}
+ fWidth := BIH.biWidth;
+ BIH.biHeight := BIH.biHeight div 2; // fSize;
+ fHeight := BIH.biHeight;
+ {$ELSE}
+ fSize := BIH.biWidth;
+ BIH.biHeight := BIH.biHeight div 2; // fSize;
+ {$ENDIF}
+ Mem := NewMemoryStream;
+ if (FoundIDI.bColorCount >= 2) or (FoundIDI.bReserved = 1) or
+ (FoundIDI.bColorCount = 0) then
+ begin
+ I := 0;
+ SzImg := ((BIH.biBitCount * BIH.biWidth + 31) div 32) * 4 * BIH.biHeight;
+ if (BIH.biSizeImage > 0) and (SzImg > BIH.biSizeImage) then
+ SzImg := BIH.biSizeImage;
+ if BIH.biBitCount <= 8 then
+ begin
+ I := (1 shl BIH.biBitCount) * Sizeof( TRGBQuad );
+ end;
+ Mem.Write( BIH, Sizeof( BIH ) );
+ if I > 0 then
+ begin
+ if Stream2Stream( Mem, Strm, I ) <> DWORD(I) then Exit; {>>>>>>>>>>>>}
+ end
+ else
+ if BIH.biBitCount = 16 then
+ begin
+ if BIH.biCompression = BI_BITFIELDS then // + by mdw - fix for
+ Stream2Stream(Mem, Strm, 12) // 16 bit per pixels
+ else
+ for I := 0 to 2 do
+ begin
+ J := InitColors[ I ];
+ Mem.Write( J, 4 );
+ end;
+ end;
+ I := Stream2Stream( Mem, Strm, SzImg );
+ if I <> Integer( SzImg ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF ICON_DIFF_WH}
+ ImgBmp := NewBitmap( fWidth, fHeight );
+ {$ELSE}
+ ImgBmp := NewBitmap( fSize, fSize );
+ {$ENDIF}
+ {$IFDEF ICONLOAD_PRESERVEBMPS}
+ Add2AutoFree( ImgBmp );
+ {$ENDIF ICONLOAD_PRESERVEBMPS}
+ Mem.Seek( 0, spBegin );
+ {$IFDEF LOADEX}
+ ImgBmp.LoadFromStreamEx( Mem );
+ {$ELSE}
+ ImgBmp.LoadFromStream( Mem );
+ {$ENDIF}
+ if ImgBmp.Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end
+ else
+ begin
+ Mem.Write( BIH, Sizeof( BIH ) );
+ end;
+
+ BIH.biBitCount := 1;
+ BIH.biPlanes := 1;
+ BIH.biClrUsed := 0;
+ BIH.biCompression := 0;
+ Mem.Seek( 0, spBegin );
+ BIH.biSizeImage := ((BIH.biWidth + 31) div 32) * 4 * BIH.biHeight;
+ Mem.Write( BIH, Sizeof( BIH ) );
+ I := 0;
+ Mem.Write( I, Sizeof( I ) );
+ I := $FFFFFF;
+ Mem.Write( I, Sizeof( I ) );
+ I := BIH.biSizeImage;
+ J := Stream2Stream( Mem, Strm, I );
+ while J < I do
+ begin
+ D := 0;
+ Mem.Write( D, 4 );
+ Inc( J, 4 );
+ end;
+
+ {$IFDEF ICON_DIFF_WH}
+ MskBmp := NewBitmap( fWidth, fHeight );
+ {$ELSE}
+ MskBmp := NewBitmap( fSize, fSize );
+ {$ENDIF}
+ {$IFDEF ICONLOAD_PRESERVEBMPS}
+ Add2AutoFree( MskBmp );
+ {$ENDIF ICONLOAD_PRESERVEBMPS}
+ Mem.Seek( 0, spBegin );
+ {$IFDEF LOADEX}
+ MskBmp.LoadFromStreamEx( Mem );
+ {$ELSE}
+ MskBmp.LoadFromStream( Mem );
+ {$ENDIF}
+
+ {$IFDEF ICONLOAD_PRESERVEBMPS}
+ Result := TRUE;
+ if not Only_Bmp then
+ {$ENDIF ICONLOAD_PRESERVEBMPS}
+ begin
+ II.fIcon := True;
+ II.xHotspot := 0;
+ II.yHotspot := 0;
+ II.hbmMask := 0;
+ if Assigned( MskBmp ) and not MskBmp.Empty then
+ II.hbmMask := MskBmp.Handle;
+ II.hbmColor := 0;
+ if ImgBmp <> nil then
+ II.hbmColor := ImgBmp.Handle;
+ fHandle := CreateIconIndirect( II );
+ if SumSz > 0 then
+ Strm.Seek( Integer( Pos ) + SumSz, spBegin );
+ Result := fHandle <> 0;
+ end;
+
+ end;
+begin
+ DesiredSize := Size;
+ if DesiredSize = 0 then
+ DesiredSize := GetSystemMetrics( SM_CXICON );
+ Clear;
+ Pos := Strm.Position;
+
+ Mem := nil;
+ {$IFDEF ICONLOAD_PRESERVEBMPS}
+ if ImgBmp <> nil then
+ begin
+ RemoveFromAutoFree( ImgBmp );
+ RemoveFromAutoFree( MskBmp );
+ Free_And_Nil( ImgBmp );
+ Free_And_Nil( MskBmp );
+ end;
+ {$ELSE}
+ ImgBmp := nil;
+ MskBmp := nil;
+ {$ENDIF ICONLOAD_PRESERVEBMPS}
+ TmpBmp := nil;
+
+ if not ReadIcon then
+ begin
+ Clear;
+ Strm.Seek( Pos, spBegin );
+ end;
+
+ Mem.Free;
+ {$IFNDEF ICONLOAD_PRESERVEBMPS}
+ ImgBmp.Free;
+ MskBmp.Free;
+ {$ENDIF ICONLOAD_PRESERVEBMPS}
+ TmpBmp.Free;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TIcon.SaveToFile(const FileName: KOLString);
+begin
+ SaveIcons2File( [ @Self ], FileName );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TIcon.SaveToStream(Strm: PStream);
+begin
+ SaveIcons2Stream( [ @Self ], Strm );
+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;
+begin
+ if FHandle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Clear;
+ FHandle := Value;
+ if Value <> 0 then
+ begin
+ GetIconInfo( FHandle, II );
+ GetObject( II.hbmMask, Sizeof( B ), @B );
+ {$IFDEF ICON_DIFF_WH}
+ fWidth := B.bmWidth;
+ fHeight := B.bmHeight;
+ {$ELSE}
+ fSize := B.bmWidth;
+ {$ENDIF}
+ if II.hbmMask <> 0 then
+ DeleteObject( II.hbmMask );
+ if II.hbmColor <> 0 then
+ DeleteObject( II.hbmColor );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TIcon.SetHandleEx(NewHandle: HIcon);
+begin
+ if FHandle = NewHandle then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Clear;
+ FHandle := NewHandle;
+end;
+
+procedure TIcon.SetSize(const Value: Integer);
+begin
+ {$IFDEF ICON_DIFF_WH}
+ if (fWidth = Value) and (fHeight = Value) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>}
+ {$ELSE}
+ if FSize = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$ENDIF}
+ Clear;
+ {$IFDEF ICON_DIFF_WH}
+ fWidth := Value;
+ fHeight := Value;
+ {$ELSE}
+ FSize := Value;
+ {$ENDIF}
+end;
+
+{$IFDEF ICON_DIFF_WH}
+function TIcon.GetIconSize: Integer;
+begin
+ Result := Max( fWidth, fHeight );
+end;
+{$ENDIF}
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function ColorBits( ColorsCount : Integer ) : Integer;
+var I : Integer;
+begin
+ for I := 1 to 6 do
+ begin
+ Result := PossibleColorBits[ I ];
+ if (1 shl Result) >= ColorsCount then break;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function SaveIcons2StreamEx( const BmpHandles: array of HBitmap; Strm: PStream ): Boolean;
+var I, Off : Integer;
+ IDI : TIconDirEntry;
+ BIH : TBitmapInfoHeader;
+ B: TagBitmap;
+ function RGBArraySize : Integer;
+ begin
+ Result := 0;
+ if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then
+ Result := (IDI.bColorCount + (IDI.bReserved shl 8)) * Sizeof( TRGBQuad );
+ end;
+ function ColorDataSize( W, H: Integer ) : Integer;
+ var N: Integer;
+ begin
+ if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then
+ N := (ColorBits( IDI.bColorCount + (IDI.bReserved shl 8) ) )
+ else
+ begin
+ N := IDI.wBitCount;
+ end;
+ Result := ((N * W + 31) div 32) * 4
+ * H;
+ end;
+ function MaskDataSize( W, H: Integer ) : Integer;
+ begin
+ Result := ((W + 31) div 32) * 4 * H;
+ end;
+var BColor, BMask: HBitmap;
+ W, H: Integer;
+ ImgBmp, MskBmp: PBitmap;
+ IH : TIconHeader;
+ Colors : PList;
+begin
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( (High(BmpHandles) >= 0) and (High(BmpHandles) and 1 <> 0),
+ 'Incorrect parameters count in call to SaveIcons2StreamEx' );
+ {$ENDIF KOL_ASSERTIONS}
+ Result := False;
+ IH.idReserved := 0;
+ IH.idType := 1;
+ IH.idCount := (High( BmpHandles )+1) div 2;
+ if Strm.Write( IH, Sizeof( IH ) ) <> Sizeof( IH ) then Exit; {>>>>>>>>>>>>>>>}
+ Off := Sizeof( IH ) + IH.idCount * Sizeof( IDI );
+ Colors := NewList;
+ ImgBmp := NewBitmap( 0, 0 );
+ MskBmp := NewBitmap( 0, 0 );
+ TRY
+
+ for I := 0 to High( BmpHandles ) div 2 do
+ begin
+ BColor := BmpHandles[ I * 2 ];
+ BMask := BmpHandles[ I * 2 + 1 ];
+ if (BColor = 0) and (BMask = 0) then break;
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( BMask <> 0, 'Mask bitmap not provided for saving icons in SaveIcons2StreamEx' );
+ {$ENDIF KOL_ASSERTIONS}
+ GetObject( BMask, Sizeof( B ), @ B );
+ W := B.bmWidth;
+ H := B.bmHeight;
+ if BColor <> 0 then
+ begin
+ GetObject( BColor, Sizeof( B ), @B );
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( (B.bmWidth = W) and (B.bmHeight = H),
+ 'Mask bitmap size must much color bitmap size in SaveIcons2StreamEx' );
+ {$ENDIF KOL_ASSERTIONS}
+ end;
+ ZeroMemory( @IDI, Sizeof( IDI ) );
+
+ IDI.bWidth := W;
+ IDI.bHeight := H;
+ if BColor = 0 then
+ IDI.bColorCount := 2
+ else
+ begin
+ ImgBmp.Handle := CopyImage( BColor, IMAGE_BITMAP, W, H,
+ LR_CREATEDIBSECTION );
+ ZeroMemory( @BIH, Sizeof( BIH ) );
+ BIH.biSize := Sizeof( BIH );
+ GetObject( ImgBmp.Handle, Sizeof( B ), @B );
+ if (B.bmPlanes = 1) and (B.bmBitsPixel >= 15) then
+ begin
+ IDI.bColorCount := 0;
+ IDI.bReserved := 0;
+ IDI.wBitCount := B.bmBitsPixel;
+ end
+ else
+ if B.bmPlanes * (1 shl B.bmBitsPixel) < 16 then
+ begin
+ ImgBmp.PixelFormat := pf1bit;
+ IDI.bColorCount := 2;
+ end
+ else
+ if B.bmPlanes * (1 shl B.bmBitsPixel) < 256 then
+ begin
+ ImgBmp.PixelFormat := pf4bit;
+ IDI.bColorCount := 16;
+ end
+ else
+ begin
+ ImgBmp.PixelFormat := pf8bit;
+ IDI.bColorCount := 0;
+ IDI.bReserved := 1;
+ end;
+ end;
+ Colors.Add( Pointer(IDI.bColorCount + (IDI.bReserved shl 8)) );
+ IDI.dwBytesInRes := Sizeof( BIH ) + RGBArraySize +
+ ColorDataSize( W, H ) + MaskDataSize( W, H );
+ IDI.dwImageOffset := Off;
+ if Strm.Write( IDI, Sizeof( IDI ) ) <> Sizeof( IDI ) then Exit; {>>>>>>>>}
+ Inc( Off, IDI.dwBytesInRes );
+ end;
+ for I := 0 to High( BmpHandles ) div 2 do
+ begin
+ BColor := BmpHandles[ I * 2 ];
+ BMask := BmpHandles[ I * 2 + 1 ];
+ if (BColor = 0) and (BMask = 0) then break;
+ GetObject( BMask, Sizeof( B ), @ B );
+ W := B.bmWidth;
+ H := B.bmHeight;
+
+ ZeroMemory( @BIH, Sizeof( BIH ) );
+ BIH.biSize := Sizeof( BIH );
+ BIH.biWidth := W;
+ BIH.biHeight := H;
+ if BColor <> 0 then
+ BIH.biHeight := W * 2;
+ BIH.biPlanes := 1;
+ PWord( @ IDI.bColorCount )^ := DWord( Colors.Items[ I ] );
+ if IDI.wBitCount = 0 then
+ IDI.wBitCount := ColorBits( PWord( @ IDI.bColorCount )^ );
+ BIH.biBitCount := IDI.wBitCount;
+ BIH.biSizeImage := Sizeof( BIH ) + ColorDataSize( W, H ) + MaskDataSize( W, H );
+ if Strm.Write( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit; {>>>>>>>>}
+ if BColor <> 0 then
+ begin
+
+ ImgBmp.Handle := CopyImage( BColor, IMAGE_BITMAP, W, H, 0 );
+ case BIH.biBitCount of
+ 1 : ImgBmp.PixelFormat := pf1bit;
+ 4 : ImgBmp.PixelFormat := pf4bit;
+ 8 : ImgBmp.PixelFormat := pf8bit;
+ 16: ImgBmp.PixelFormat := pf16bit;
+ 24: ImgBmp.PixelFormat := pf24bit;
+ 32: ImgBmp.PixelFormat := pf32bit;
+ end;
+ end
+ else
+ begin
+ ImgBmp.Handle := CopyImage( BMask, IMAGE_BITMAP, W, H, 0 );
+ ImgBmp.PixelFormat := pf1bit;
+ end;
+ if ImgBmp.FDIBBits <> nil then
+ begin
+ if Strm.Write( Pointer(Integer(ImgBmp.FDIBHeader) + Sizeof(TBitmapInfoHeader))^,
+ PWord( @ IDI.bColorCount )^ * Sizeof( TRGBQuad ) ) <>
+ PWord( @ IDI.bColorCount )^ * Sizeof( TRGBQuad ) then Exit; {>>>>>>>}
+ if Strm.Write( ImgBmp.FDIBBits^, ColorDataSize( W, H ) ) <>
+ DWord( ColorDataSize( W, H ) ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ MskBmp.Handle := CopyImage( BMask, IMAGE_BITMAP, W, H, 0 );
+
+ MskBmp.PixelFormat := pf1bit;
+ if Strm.Write( MskBmp.FDIBBits^, MaskDataSize( W, H ) ) <>
+ DWord( MaskDataSize( W, H ) ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+
+ FINALLY
+ Colors.Free;
+ ImgBmp.Free;
+ MskBmp.Free;
+ END;
+ Result := True;
+end;
+
+{$IFDEF FPC}
+ {$DEFINE _D3orFPC}
+{$ENDIF}
+{$IFDEF _D2orD3}
+ {$DEFINE _D3orFPC}
+{$ENDIF}
+procedure SaveIcons2Stream( const Icons : array of PIcon; Strm : PStream );
+var I, J, Pos : Integer;
+ {$IFDEF _D3orFPC}
+ Bitmaps: array[ 0..63 ] of HBitmap;
+ {$ELSE DELPHI}
+ Bitmaps: array of HBitmap;
+ {$ENDIF FPC/DELPHI}
+ II: TIconInfo;
+ Bmp: HBitmap;
+begin
+ for I := 0 to High( Icons ) do
+ begin
+ if Icons[ I ].Handle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ for J := I + 1 to High( Icons ) do
+ if Icons[ I ].Size = Icons[ J ].Size then Exit; {>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Pos := Strm.Position;
+
+ {$IFDEF _D3orFPC}
+ for I := 0 to High( Bitmaps ) do
+ Bitmaps[ I ] := 0;
+ {$ELSE DELPHI}
+ SetLength( Bitmaps, Length( Icons ) * 2 );
+ {$ENDIF FPC/DELPHI}
+ for I := 0 to High( Icons ) do
+ begin
+ GetIconInfo( Icons[ I ].Handle, II );
+ Bitmaps[ I * 2 ] := II.hbmColor;
+ Bitmaps[ I * 2 + 1 ] := II.hbmMask;
+ end;
+
+ if not SaveIcons2StreamEx( Bitmaps, Strm ) then
+ Strm.Seek( Pos, spBegin );
+
+ for I := 0 to High( Bitmaps ) do
+ begin
+ Bmp := Bitmaps[ I ];
+ if Bmp <> 0 then
+ DeleteObject( Bmp );
+ end;
+end;
+
+procedure SaveIcons2File( const Icons : array of PIcon; const FileName : KOLString );
+var Strm: PStream;
+begin
+ Strm := NewWriteFileStream( FileName );
+ SaveIcons2Stream( Icons, Strm );
+ Strm.Free;
+end;
+
+procedure TIcon.LoadFromExecutable(const FileName: KOLString; IconIdx: Integer);
+var I: Integer;
+begin
+ Clear;
+ I := ExtractIcon( hInstance, PKOLChar( FileName ), IconIdx );
+ if I > 1 then
+ Handle := I;
+end;
+
+function GetFileIconCount( const FileName: KOLString ): Integer;
+begin
+ Result := ExtractIcon( hInstance, PKOLChar( FileName ), DWORD(-1) );
+end;
+
+procedure TIcon.LoadFromResourceID(Inst, ResID, DesiredSize: Integer);
+begin
+ LoadFromResourceName( Inst, MAKEINTRESOURCE( ResID ), DesiredSize );
+end;
+
+procedure TIcon.LoadFromResourceName(Inst: Integer; ResName: PKOLChar; DesiredSize: Integer);
+begin
+ Handle := LoadImage( Inst, ResName, IMAGE_ICON, DesiredSize, DesiredSize, $8000 {LR_SHARED} );
+ if fHandle <> 0 then FShareIcon := True;
+end;
+
+function LoadImgIcon( RsrcName: PKOLChar; Size: Integer ): HIcon;
+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;
+ procedure DoAlign( Allowed: TAligns );
+ var I, W, H: Integer;
+ C: PControl;
+ R, R1: TRect;
+ ChgPos, ChgSiz: Boolean;
+ begin
+ for I := 0 to P.fChildren.fCount - 1 do
+ begin
+ 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}
+ {$IFDEF CREATE_HIDDEN}
+ or
+ {$IFDEF USE_FLAGS} (G4_CreateHidden in fFlagsG4)
+ {$ELSE} fCreateHidden {$ENDIF}
+ {$ENDIF CREATE_HIDDEN}
+ ))
+ or(not(fAlign in Allowed)) then continue;
+ if {$IFDEF USE_FLAGS} not(G4_NotUseAlign in fFlagsG4)
+ {$ELSE} not fNotUseAlign {$ENDIF} then
+ begin
+ R := BoundsRect;
+ R1 := R;
+ W := R.Right - R.Left;
+ H := R.Bottom - R.Top;
+ case FAlign of
+ caTop:
+ begin
+ OffsetRect( R, 0, -R.Top + CR.Top + P.Margin );
+ Inc( CR.Top, H + P.Margin );
+ R.Left := CR.Left + P.Margin;
+ R.Right := CR.Right - P.Margin;
+ end;
+ caBottom:
+ begin
+ OffsetRect( R, 0, -R.Bottom + CR.Bottom - P.Margin );
+ Dec( CR.Bottom, H + P.Margin );
+ R.Left := CR.Left + P.Margin;
+ R.Right := CR.Right - P.Margin;
+ end;
+ caLeft:
+ begin
+ OffsetRect( R, -R.Left + CR.Left + P.Margin, 0 );
+ Inc( CR.Left, W + P.Margin );
+ R.Top := CR.Top + P.Margin;
+ R.Bottom := CR.Bottom - P.Margin;
+ end;
+ caRight:
+ begin
+ OffsetRect( R, -R.Right + CR.Right - P.Margin, 0 );
+ Dec( CR.Right, W + P.Margin );
+ R.Top := CR.Top + P.Margin;
+ R.Bottom := CR.Bottom - P.Margin;
+ end;
+ caClient:
+ begin
+ R := CR;
+ InflateRect( R, -P.Margin, -P.Margin );
+ end;
+ end;
+ if R.Right < R.Left then R.Right := R.Left;
+ if R.Bottom < R.Top then R.Bottom := R.Top;
+ ChgPos := (R.Left <> R1.Left) or (R.Top <> R1.Top);
+ ChgSiz := (R.Right - R.Left <> W) or (R.Bottom - R.Top <> H);
+ if ChgSiz then
+ begin
+ exclude(fAligning,oaWaitAlign);
+ include(fAligning,oaFromSelf);
+ 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);
+ end;
+ end;
+ end;
+
+begin
+ exclude(P.fAligning,oaWaitAlign);
+ include(P.fAligning,oaAligning);
+ CR := P.ClientRect;
+ DoAlign( [ caTop, caBottom ] );
+ DoAlign( [ caLeft, caRight ] );
+ DoAlign( [ caClient,caNone ] );
+ exclude(P.fAligning,oaAligning);
+end;
+
+{$IFDEF ASM_TLIST}
+procedure AlignChildrenProc(Sender: PObj);
+const AlignModes = (1 shl byte(caBottom))+(1 shl byte(caTop))+
+ (((1 shl byte(caRight)) +(1 shl byte(caLeft)))shl 8)+
+ (((1 shl byte(caClient))+(1 shl byte(caNone)))shl 16);
+asm //cmd //opd
+ TEST EAX,EAX
+ JZ @@21
+ CMP [EAX].TControl.fParent,0
+ SETZ DL
+ {$IFDEF USE_FLAGS}
+ TEST [EAX].TControl.fFlagsG3, (1 shl G3_IsForm)
+ SETNZ DH
+ OR DL, DH
+ {$ELSE}
+ OR DL,[EAX].TControl.fIsForm
+ {$ENDIF}
+ BTR dword ptr[EAX].TControl.fAligning,oaFromSelf
+ JA @@20
+ OR byte ptr[EAX].TControl.fAligning,(1 shl oaWaitAlign)
+ MOV EAX,[EAX].TControl.fParent
+@@20: TEST EAX, EAX
+ JZ @@21
+ CALL @@ToBeAlign
+ JNZ @@DoAlign
+@@21: RETN
+
+@@ToBeAlign:
+ {$IFDEF USE_FLAGS}
+ TEST [EAX].TControl.fStyle.f3_Style, 1 shl F3_Visible
+ SETNZ DL
+ {$ELSE}
+ MOV DL,[EAX].TControl.fVisible
+ {$ENDIF}
+ {$IFDEF USE_FLAGS}
+ TEST [EAX].TControl.fFlagsG3, 1 shl G3_IsForm
+ SETNZ DH
+ OR DL, DH
+ TEST [EAX].TControl.fFlagsG4, (1 shl G4_CreateHidden)
+ SETNZ DH
+ OR DL, DH
+ {$ELSE}
+ OR DL,[EAX].TControl.fCreateHidden
+ {$ENDIF}
+ JE @@10
+ {$IFDEF USE_FLAGS}
+ TEST [EAX].TControl.fFlagsG3, 1 shl G3_IsForm
+ SETNZ DH
+ AND DL, DH
+ {$ELSE}
+ AND DL,[EAX].TControl.fIsForm
+ {$ENDIF}
+ JNE @@12
+ CMP dword ptr[EAX].TControl.fParent,0
+ JE @@11
+ PUSH EAX
+ MOV EAX,[EAX].TControl.fParent
+ CALL @@ToBeAlign
+ POP EAX
+@@10: XOR DL,1
+//!!! Important: oaWaitAlign=0
+ OR [EAX].TControl.fAligning,DL
+@@11: XOR DL,1
+@@12: RETN
+
+@@DoAlign:
+ //CALL AlignChildrenProc_
+ //RET
+ PUSH EBP
+ PUSH EBX
+ PUSH ESI
+ PUSH EDI
+ PUSH AlignModes //00210A14h
+ SUB ESP,030h
+ MOV EBX,EAX
+ AND byte ptr[EBX].TControl.fAligning,not(1 shl oaWaitAlign)
+ OR byte ptr[EBX].TControl.fAligning,(1 shl oaAligning)
+ LEA EDX,[ESP+20h] //@CR
+ CALL TControl.ClientRect
+@@Main:
+ MOV EAX,[EBX].TControl.fChildren
+ MOV EDI,[EAX].TList.fCount
+ MOV EBP,[EAX].TList.fItems
+ JMP @@entry
+@@loop:
+ MOV ESI,[EBP]
+ {$IFDEF USE_FLAGS}
+ MOV AL,[ESI].TControl.fStyle.f3_Style
+ SHR AL, F3_Visible
+ OR AL,[ESI].TControl.fFlagsG4
+ AND AL, 1 shl G4_CreateHidden // G4_CreateHidden = 0 !!!
+ {$ELSE}
+ MOV AL,[ESI].TControl.fVisible
+ OR AL,[ESI].TControl.fCreateHidden
+ {$ENDIF}
+ JZ @@continue
+ MOVZX EAX,[ESI].TControl.fAlign
+ BT [ESP+30h],EAX //Allowed
+ JNC @@continue
+ {$IFDEF USE_FLAGS}
+ TEST [ESI].TControl.fFlagsG4, 1 shl G4_NotUseAlign
+ {$ELSE}
+ CMP byte ptr[ESI].TControl.fNotUseAlign,0
+ {$ENDIF}
+ JNE @@align
+ MOV EDX,ESP //@R
+ MOV EAX,ESI //C
+ CALL TControl.GetBoundsRect
+ MOV EAX,[ESP+0Ch] //R.Bottom
+ MOV [ESP+1Ch],EAX //H
+ MOV EAX,[ESP+08h] //R.Right
+ MOV [ESP+18h],EAX //W
+ MOV EAX,[ESP+04h] //R.Top
+ MOV [ESP+14h],EAX //R1.Top
+ SUB [ESP+1Ch],EAX //H
+ MOV EAX,[ESP] //R.Left
+ MOV [ESP+10h],EAX //R1.Left
+ SUB [ESP+18h],EAX //W
+ MOVSX EDX,[EBX].TControl.fMargin
+ MOVZX ECX,byte ptr[ESI].TControl.fAlign
+//!!! Order of caXXX-constants is important
+ LOOP @@caTop
+ MOV EAX,[ESP+20h] //CR.Left
+ SUB EAX,[ESP] //R.Left
+ ADD EAX,EDX //+Margin
+ MOV ECX,[ESP+18h] //W
+ ADD ECX,EDX //+Margin
+ ADD [ESP+20h],ECX //CR.Left
+ JMP @@00
+@@caTop:
+ LOOP @@caRight
+ MOV EAX,[ESP+24h] //CR.Top
+ SUB EAX,[ESP+04h] //R.Top
+ ADD EAX,EDX //+Margin
+ MOV ECX,[ESP+1Ch] //H
+ ADD ECX,EDX //+Margin
+ ADD [ESP+24h],ECX //CR.Top
+ JMP @@01
+@@caRight:
+ LOOP @@caBottom
+ MOV EAX,[ESP+28h] //CR.Right
+ SUB EAX,[ESP+08h] //R.Right
+ SUB EAX,EDX //-Margin
+ MOV ECX,[ESP+18h] //W
+ ADD ECX,EDX //+Margin
+ SUB [ESP+28h],ECX //CR.Right
+@@00: ADD [ESP],EAX //R.Left
+ ADD [ESP+08h],EAX //R.Right
+ MOV EAX,[ESP+2Ch] //CR.Bottom
+ SUB EAX,EDX //+Margin
+ MOV [ESP+0Ch],EAX //R.Bottom
+ ADD EDX,[esp+24h] //Margin+CR.Top
+ MOV [ESP+04h],edx //R.Top
+ JMP @@caNone
+@@caBottom:
+ LOOP @@caClient
+ MOV EAX,[ESP+2Ch] //CR.Bottom
+ SUB EAX,[ESP+0Ch] //R.Bottom
+ SUB EAX,EDX //-Margin
+ MOV ECX,[ESP+1Ch] //H
+ ADD ECX,EDX //+Margin
+ SUB [ESP+2Ch],ECX //CR.Bottom
+@@01: ADD [ESP+04h],EAX //R.Top
+ ADD [ESP+0Ch],EAX //R.Bottom
+ MOV EAX,[ESP+28h] //CR.Right
+ SUB EAX,EDX //-Margin
+ MOV [esp+08h],EAX //R.Right
+ ADD EDX,[ESP+20h] //Margin+CR.Left
+ MOV [ESP],EDX //R.Left
+ JMP @@caNone
+@@caClient:
+ LOOP @@caNone
+ MOV EAX,[ESP+2Ch] //CR.Bottom
+ SUB EAX,EDX //-Margin
+ MOV [ESP+0Ch],EAX //R.Bottom
+ MOV EAX,[ESP+28h] //CR.Right
+ SUB EAX,EDX //-Margin
+ MOV [ESP+08h],EAX //R.Right
+ MOV EAX,[ESP+24h] //CR.Top
+ ADD EAX,EDX //+Margin
+ MOV [ESP+04h],EAX //R.Top
+ ADD EDX,[ESP+20h] //Margin+CR.Left
+ MOV [ESP],EDX //R.Left
+@@caNone:
+ MOV EAX,[ESP] //R.Left
+ CMP EAX,[ESP+08h] //R.Right
+ JLE @@02 //CMOVG ???
+ MOV [ESP+08h],EAX //R.Right
+@@02: MOV EAX,[ESP+04h] //R.Top
+ CMP EAX,[ESP+0Ch] //R.Bottom
+ JLE @@03 //CMOVG ???
+ MOV [ESP+0Ch],EAX //R.Bottom
+@@03: MOV EDX,[ESP] //R.Left
+ SUB EDX,[ESP+10h] //R1.Left
+ MOV EAX,[ESP+04h] //R.Top
+ SUB EAX,[ESP+14h] //R1.Top
+ OR EDX,EAX //ChgPos
+ MOV ECX,[ESP+08h] //R.Right
+ SUB ECX,[ESP] //R.Left
+ SUB ECX,[ESP+18h] //W
+ MOV EAX,[ESP+0Ch] //R.Bottom
+ SUB EAX,[ESP+04h] //R.Top
+ SUB EAX,[ESP+1Ch] //H
+ OR EAX,ECX
+ JZ @@04
+ AND byte ptr[ESI].TControl.fAligning,not(1 shl oaWaitAlign)
+ OR byte ptr[ESI].TControl.fAligning,(1 shl oaFromSelf)
+@@04: OR EAX,EDX
+ JZ @@align
+ MOV EDX,ESP //@R
+ MOV EAX,ESI //C
+ CALL TControl.SetBoundsRect
+@@align:
+ TEST byte ptr[ESI].TControl.fAligning,(1 shl oaWaitAlign)
+ JZ @@continue
+ MOV EAX,ESI //C
+ CALL @@DoAlign
+@@continue:
+ TEST byte ptr[EBX].TControl.fAligning,(1 shl oaAligning)
+ JZ @@exit
+ ADD EBP,4
+@@entry:
+ DEC EDI
+ JGE @@loop
+ SHR dword ptr[ESP+30h],8 //Allowed
+ JNZ @@Main
+ AND byte ptr[EBX].TControl.fAligning,not(1 shl oaAligning)
+@@exit:
+ ADD ESP,34h
+ POP EDI
+ POP ESI
+ POP EBX
+ POP EBP
+end;
+{$ELSE PAS_VERSION} // Pascal
+procedure AlignChildrenProc(Sender: PObj);
+ function ToBeAlign( S: PControl ):Boolean;
+ begin
+ {$IFDEF USE_FLAGS}
+ Result := (
+ (F3_Visible in S.fStyle.f3_Style)
+ or (
+ (G3_IsForm in S.fFlagsG3) // так надо!
+ {$IFDEF CREATE_HIDDEN}
+ or (G4_CreateHidden in S.fFlagsG4)
+ {$ENDIF CREATE_HIDDEN}
+ ) )
+ and ( (G3_IsForm in S.fFlagsG3)
+ or (S.fParent=nil) or ToBeAlign(S.fParent)
+ );
+ {$ELSE}
+ Result := (
+ S.fVisible
+ {$IFDEF CREATE_HIDDEN}
+ or (
+ S.fCreateHidden
+ )
+ {$ENDIF CREATE_HIDDEN}
+ )
+ and ( S.fIsForm
+ or (S.fParent=nil) or ToBeAlign(S.fParent)
+ );
+ {$ENDIF}
+ if not Result then include(S.fAligning,oaWaitAlign);
+ end;
+var fromSelf: Boolean;
+ S: PControl;
+begin
+ if Sender = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ S := Pointer( Sender );
+ fromSelf := oaFromSelf in S.fAligning;
+ Exclude( S.fAligning, oaFromSelf );
+ if ( (S.fParent = nil)
+ or {$IFDEF USE_FLAGS} (G3_IsForm in S.fFlagsG3)
+ {$ELSE} (S.fIsForm) {$ENDIF} ) and (not fromSelf) then
+ else
+ begin
+ include(S.fAligning, oaWaitAlign);
+ S := S.Parent;
+ end;
+ if (S <> nil) and ToBeAlign(S) then
+ AlignChildrenProc_(S);
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF OLD_ALIGN}
+
+procedure TControl.Set_Align(const Value: TControlAlign);
+begin
+ Global_Align := AlignChildrenProc;
+ if {$IFDEF USE_FLAGS} G4_NotUseAlign in fFlagsG4
+ {$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;
+begin
+ Set_Align( AAlign );
+ Result := @Self;
+end;
+
+{$IFDEF LOG_ANTIFLICK}
+procedure LogFlick( const s: AnsiString; const rects: array of TRect );
+var s1: AnsiString;
+ i: Integer;
+begin
+ s1 := s + ' ';
+ for i := 0 to High( rects ) do
+ begin
+ s1 := s1 + '[' + Int2Str( rects[i].Left ) + ',' + Int2Str( rects[i].top ) +
+ ',' + Int2Str( rects[i].Right ) + ',' + Int2Str( rects[i].Bottom ) +
+ '=' + Int2Str( rects[i].Right - rects[i].Left ) + 'x' +
+ Int2Str( rects[i].Bottom - rects[i].Top ) + ']';
+ end;
+ LogFileOutput( GetStartDir + 'log_antiflick', s1 );
+end;
+{$ENDIF}
+
+procedure TControl.Update;
+var I: Integer;
+ C: PControl;
+begin
+ if fUpdateCount > 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ UpdateWindow( fHandle );
+ for I := 0 to fChildren.fCount - 1 do
+ begin
+ C := fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ];
+ C.Update;
+ end;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function WndProcUpdate( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ if Sender.fUpdateCount <> 0 then
+ begin
+ case Msg.message of
+ WM_PAINT:
+ begin
+ ValidateRect( Sender.Handle, nil );
+ Rslt := 0;
+ end;
+ WM_ERASEBKGND: Rslt := 1;
+ else begin
+ Result := FALSE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ Result := TRUE;
+ end
+ else Result := FALSE;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.BeginUpdate;
+begin
+ Inc( fUpdateCount );
+ AttachProc( @WndProcUpdate );
+end;
+
+procedure TControl.EndUpdate;
+begin
+ Dec( fUpdateCount );
+ if fUpdateCount <= 0 then
+ begin
+ Invalidate;
+ //Update;
+ end;
+end;
+
+function TControl.GetSelection: KOLString;
+var L: Integer;
+begin
+ if fCommandActions.aGetSelection <> 0 then
+ begin
+ L := SelLength;
+ SetString( Result, nil, L + 1 );
+ Perform( fCommandActions.aGetSelection, 0, Integer( @Result[ 1 ] ) );
+ end
+ else
+ Result := Copy( Text, SelStart + 1, SelLength );
+end;
+
+procedure TControl.SetSelection(const Value: KOLString);
+begin
+ ReplaceSelection( Value, True );
+end;
+
+procedure TControl.ReplaceSelection(const Value: KOLString; aCanUndo: Boolean);
+begin
+ if fCommandActions.aReplaceSel <> 0 then
+ begin
+ Perform( fCommandActions.aReplaceSel, Integer( aCanUndo ), Integer( PKOLchar( Value ) ) );
+ end;
+end;
+
+procedure TControl.DeleteLines(FromLine, ToLine: Integer);
+var I1, I2: DWORD;
+ SStart, SLength: DWORD;
+begin
+ if FromLine > ToLine then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ {$IFDEF KOL_ASSERTIONS}
+ Assert( FromLine >= 0, 'Incorrect line index' );
+ {$ENDIF KOL_ASSERTIONS}
+ I1 := Item2Pos( FromLine );
+ I2 := Item2Pos( ToLine+1 ) - I1;
+ SStart := SelStart;
+ SLength := SelLength;
+ SelStart := I1;
+ {if ToLine >= Count-1 then
+ I2 := MaxInt;}
+ SelLength := I2;
+ ReplaceSelection( '', TRUE );
+ if SStart >= I2 then
+ begin
+ SStart := SStart - (I2 - I1);
+ end
+ else
+ if SStart >= I1 then
+ begin
+ SLength := SLength - (I2 - SStart);
+ SStart := I1;
+ end
+ else
+ if SStart + SLength >= I2 then
+ begin
+ SLength := SLength - (I2 - I1);
+ end
+ else
+ if SStart + SLength >= I1 then
+ begin
+ SLength := I1 - SLength;
+ end;
+ SelStart := SStart;
+ SelLength := Max( 0, SLength );
+end;
+
+procedure TControl.SetTabOrder(const Value: SmallInt);
+var CL: PList;
+ I : Integer;
+ C: PControl;
+begin
+ if Value = fTabOrder then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ CL := CollectTabControls( ParentForm );
+ for I := 0 to CL.fCount - 1 do
+ begin
+ C := CL.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ];
+ if C.fTabOrder >= Value then
+ Inc( C.fTabOrder );
+ end;
+ fTabOrder := Value;
+ CL.Free;
+end;
+
+function TControl.GetFocused: Boolean;
+begin
+ if {$IFDEF USE_FLAGS} G3_IsControl in fFlagsG3
+ {$ELSE} fIsControl {$ENDIF} then
+ Result := ParentForm.DF.fCurrentControl = @Self
+ else
+ Result := GetForegroundWindow = fHandle;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+procedure TControl.SetFocused(const Value: Boolean);
+var PF: PControl;
+begin
+ if not Value or
+ {$IFDEF USE_FLAGS} not( F2_Tabstop in fStyle.f2_Style )
+ {$ELSE} not fTabStop {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>}
+ if {$IFDEF USE_FLAGS} G3_IsControl in fFlagsG3
+ {$ELSE} fIsControl {$ENDIF} then
+ begin
+ PF := ParentForm;
+ if ( PF.DF.fCurrentControl <> nil ) and (PF.DF.fCurrentControl <> @ Self) then
+ if Assigned( PF.DF.fCurrentControl.EV.fLeave ) then
+ PF.DF.fCurrentControl.EV.fLeave( PF.DF.fCurrentControl )
+ else
+ Windows.SetFocus( 0 );
+ PF.DF.fCurrentControl := @Self;
+ {$IFDEF USE_GRAPHCTLS}
+ if Assigned( fSetFocus ) then
+ fSetFocus(@Self)
+ else
+ {$ENDIF}
+ SetFocus( GetWindowHandle );
+ end
+ else
+ SetForegroundWindow( GetWindowHandle );
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFNDEF NOT_USE_RICHEDIT}
+
+//////////////////////////////////////////////////////////////////////
+// R I C H E D I T
+//////////////////////////////////////////////////////////////////////
+
+{ -- rich edit -- }
+
+function TControl.REGetFont: PGraphicTool;
+var
+ CF: PCharFormat;
+ //CFA: PCharFormat2A;
+ //CFW: PCharFormat2W;
+ FS: TFontStyle;
+begin
+ {$IFDEF STATIC_RICHEDIT_DATA}
+ CF := @ DF.fRECharFormatRec;
+ {$ELSE}
+ CF := DF.fRECharFormatRec;
+ {$ENDIF}
+ ZeroMemory( CF, Sizeof( CF^ ) );
+ {$IFDEF UNICODE_CTRLS}
+ CF.cbSize := Sizeof( CF^ );
+ {$ELSE}
+ CF.cbSize := sizeof( RichEdit.TCharFormat ) + DF.fCharFmtDeltaSz;
+ {$ENDIF}
+ if DF.fTmpFont = nil then
+ begin
+ DF.fTmpFont := NewFont;
+ {$IFDEF USE_AUTOFREE4CONTROLS}
+ Add2AutoFree( DF.fTmpFont );
+ {$ENDIF}
+ end;
+ Result := DF.fTmpFont;
+ Result.OnChange := nil;
+ Perform( EM_GETCHARFORMAT, 1, Integer( CF ) );
+ Result.FontHeight := CF.yHeight;
+ FS := [ ];
+ if LongBool(CF.dwEffects and CFE_BOLD) then
+ FS := [ fsBold ];
+ if LongBool(CF.dwEffects and CFE_ITALIC) then
+ include( FS, fsItalic );
+ if LongBool(CF.dwEffects and CFE_STRIKEOUT) then
+ include( FS, fsStrikeOut );
+ if LongBool(CF.dwEffects and CFE_UNDERLINE) then
+ include( FS, fsUnderline );
+ Result.FontStyle := FS;
+ if not LongBool(CF.dwEffects and CFE_AUTOCOLOR) then
+ Result.Color := CF.crTextColor;
+ Result.FontPitch := TFontPitch( CF.bPitchAndFamily and 3 );
+ Result.FontCharset := CF.bCharSet;
+ {$IFDEF UNICODE_CTRLS}
+ {$ELSE}
+ if (PWord( @CF.szFaceName[0] )^ shr 8) <> 0 then
+ Result.FontName := PAnsiChar(@CF.szFaceName[0]) // real T,0 works fine.
+ else
+ {$ENDIF}
+ Result.FontName := KOLString(PWideChar(@CF.szFaceName[0]));
+ Result.OnChange := RESetFont;
+end;
+
+const RichAreas: array[ TRichFmtArea ] of Integer = ( SCF_SELECTION,
+ 3 {SCF_WORD}, 4 {SCF_ALL} );
+
+procedure TControl.RESetFontEx(const Index: Integer);
+var CF: PCharFormat;
+ FS: TFontStyle;
+begin
+ {$IFDEF STATIC_RICHEDIT_DATA}
+ CF := @ DF.fRECharFormatRec;
+ {$ELSE}
+ CF := DF.fRECharFormatRec;
+ {$ENDIF}
+ ZeroMemory( CF, {82} sizeof( CF^ ) );
+ {$IFDEF UNICODE_CTRLS}
+ CF.cbSize := Sizeof( CF^ );
+ {$ELSE}
+ CF.cbSize := 60 { sizeof( TCharFormat ) } + DF.fCharFmtDeltaSz;
+ {$ENDIF}
+ CF.dwMask := CFM_BOLD or CFM_COLOR or CFM_FACE or CFM_ITALIC
+ or CFM_SIZE or CFM_STRIKEOUT or CFM_UNDERLINE;
+ CF.yHeight := DF.fTmpFont.FontHeight;
+ FS := DF.fTmpFont.FontStyle;
+ if fsBold in FS then CF.dwEffects := CFE_BOLD;
+ if fsItalic in FS then CF.dwEffects := CF.dwEffects or CFE_ITALIC;
+ if fsStrikeOut in FS then CF.dwEffects := CF.dwEffects or CFE_STRIKEOUT;
+ if fsUnderline in FS then CF.dwEffects := CF.dwEffects or CFE_UNDERLINE;
+ CF.crTextColor := Color2RGB(DF.fTmpFont.Color);
+ CF.bCharSet := DF.fTmpFont.FontCharset;
+ CF.bPitchAndFamily := Ord( DF.fTmpFont.FontPitch );
+ {$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF}
+ ( CF.szFaceName, PKOLChar( DF.fTmpFont.FontName ), 31 );
+ Perform( EM_SETCHARFORMAT, RichAreas[ DF.fRECharArea ], Integer( CF ) );
+end;
+
+procedure TControl.RESetFont(Value: PGraphicTool);
+var H: Integer;
+begin
+ if Value <> DF.fTmpFont then
+ REGetFont;
+ H := DF.fTmpFont.fData.Font.Height;
+ DF.fTmpFont := DF.fTmpFont.Assign( Value );
+ if DF.fTmpFont.fData.Font.Height = 0 then
+ DF.fTmpFont.fData.Font.Height := H;
+ RESetFontEx( Integer( CFM_BOLD or CFM_COLOR or CFM_FACE or CFM_ITALIC
+ or CFM_SIZE or CFM_STRIKEOUT or CFM_UNDERLINE ) );
+end;
+
+function TControl.REGetFontMask( const Index: Integer ): Boolean;
+begin
+ REGetFont;
+ Result := LongBool( DF.fRECharFormatRec.dwMask and Index );
+end;
+
+function TControl.REGetFontEffects(const Index: Integer): Boolean;
+begin
+ REGetFont;
+ Result := LongBool( DF.fRECharFormatRec.dwEffects and Index );
+end;
+
+procedure TControl.RESetFontEffect(const Index: Integer;
+ const Value: Boolean);
+var
+ CF: PCharFormat;
+begin
+ ReGetFont;
+ {$IFDEF STATIC_RICHEDIT_DATA}
+ CF := @ DF.fRECharFormatRec;
+ {$ELSE}
+ CF := DF.fRECharFormatRec;
+ {$ENDIF}
+ {
+ CF.dwEffects := $FFFFFFFF and Index;
+ if not Value then CF.dwEffects := 0;
+ }
+ CF.dwEffects := CF.dwEffects or DWORD( Index );
+ if not Value then CF.dwEffects := CF.dwEffects and not Index;
+ CF.dwMask := Index;
+ Perform( EM_SETCHARFORMAT, RichAreas[ DF.fRECharArea ], Integer( CF ) );
+end;
+
+function TControl.REGetFontAttr(const Index: Integer): Integer;
+var CF: PDWORD;
+ Mask: DWORD;
+begin
+ REGetFont;
+ CF := Pointer( Integer( @DF.fRECharFormatRec ) + (HiWord(Index) and $7E) );
+ Mask := $FFFFFFFF;
+ if LongBool( HiWord(Index) and $1 ) then
+ Mask := $FF;
+ Result := CF^ and Mask;
+end;
+
+procedure TControl.RESetFontAttr(const Index, Value: Integer);
+var CF: PDWORD;
+ Mask: DWORD;
+begin
+ REGetFont;
+ {$IFDEF STATIC_RICHEDIT_DATA}
+ CF := Pointer( Integer( @ DF.fRECharFormatRec ) + (HiWord(Index) and $7E) );
+ {$ELSE}
+ CF := Pointer( Integer( DF.fRECharFormatRec ) + (HiWord(Index) and $7E) );
+ {$ENDIF}
+ Mask := 0;
+ if LongBool( HiWord(Index) and $1 ) then
+ Mask := $FFFFFF00;
+ CF^ := CF^ and Mask or DWORD(Value);
+ DF.fRECharFormatRec.dwMask := Index and $FF81FFFF;
+ if LongBool( DF.fRECharFormatRec.dwMask and (CFM_COLOR or CFM_BACKCOLOR) ) then
+ DF.fRECharFormatRec.dwEffects := DF.fRECharFormatRec.dwEffects and
+ not (CFE_AUTOCOLOR or CFE_AUTOBACKCOLOR);
+ Perform( EM_SETCHARFORMAT, RichAreas[ DF.fRECharArea ],
+ Integer( {$IFDEF STATIC_RICHEDIT_DATA} @ {$ENDIF} DF.fRECharFormatRec ) );
+end;
+
+procedure TControl.RESetFontAttr1(const Index, Value: Integer);
+begin
+ RESetFontAttr( Index, Color2RGB( Value ) );
+end;
+
+function TControl.REGetFontSizeValid: Boolean;
+begin
+ Result := REGetFontMask( Integer( CFM_SIZE ) );
+end;
+
+function TControl.REGetFontName: KOLString;
+begin
+ ReGetFont;
+ Result := DF.fRECharFormatRec.szFaceName;
+end;
+
+procedure TControl.RESetFontName(const Value: KOLString);
+begin
+ ReGetFont;
+ {$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF}
+ ( DF.fRECharFormatRec.szFaceName, PKOLChar( Value ), Sizeof( DF.fRECharFormatRec.szFaceName ) - 1 );
+ DF.fRECharFormatRec.dwMask := CFM_FACE;
+ Perform( EM_SETCHARFORMAT, RichAreas[ DF.fRECharArea ], Integer( @DF.fRECharFormatRec ) );
+end;
+
+function TControl.REGetCharformat: TCharFormat;
+begin
+ REGetFont;
+ Result := {$IFDEF STATIC_RICHEDIT_DATA} DF.fRECharFormatRec
+ {$ELSE} DF.fRECharFormatRec^ {$ENDIF};
+end;
+
+procedure TControl.RESetCharFormat(const Value: TCharFormat);
+begin
+ Perform( EM_SETCHARFORMAT, RichAreas[ DF.fRECharArea ], Integer( @Value ) );
+end;
+
+function REOut2Stream( Sender: PControl; Buf: PByte; Sz: DWORD; pSz: PInteger )
+ :DWORD; stdcall;
+begin
+ if Sz + Sender.DF.fREStream.Position > Sender.DF.fREStream.Size then
+ Sender.DF.fREStream.Size := Sender.DF.fREStream.Size + DWORD( {Min(} Sz {, 8192 )} );
+ pSz^ := Sender.DF.fREStream.Write( Buf^, Sz );
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnProgress ) then
+ {$ENDIF}
+ Sender.EV.fOnProgress( Sender );
+ Result := 0;
+end;
+
+const TextTypes: array[ TRETextFormat ] of WORD = ( SF_RTF, SF_TEXT,
+ SF_RTF or SFF_PLAINRTF, SF_RTFNOOBJS, SF_RTFNOOBJS or SFF_PLAINRTF,
+ SF_TEXTIZED, {SF_UNICODE} $0010, $0010 or SF_TEXT );
+
+function TControl.RE_SaveToStream(Stream: PStream; Format: TRETextFormat;
+ SelectionOnly: Boolean): Boolean;
+var ES: TEditStream;
+ SelFlag: Integer;
+begin
+ DF.fREStream := Stream;
+ ES.dwCookie := Integer( @Self );
+ ES.dwError := 0;
+ ES.pfnCallback := @REOut2Stream;
+ SelFlag := 0;
+ if SelectionOnly then
+ SelFlag := SFF_SELECTION;
+ Perform( EM_STREAMOUT, TextTypes[ Format ] or SelFlag, Integer( @ES ) );
+ DF.fREStream := nil;
+ DF.fREError := ES.dwError;
+ Result := DF.fREError = 0;
+end;
+
+procedure RE_AddText( Self_: PControl; const S: KOLString );
+begin
+ Self_.SelStart := Self_.TextSize;
+ Self_.RE_Text[ reText, True ] := S;
+end;
+
+function TControl.REReadText(Format: TRETextFormat;
+ SelectionOnly: Boolean): KOLString;
+var B0: Integer;
+ MS: PStream;
+begin
+ fCommandActions.aAddText := RE_AddText;
+ MS := NewMemoryStream;
+ RE_SaveToStream( MS, Format, SelectionOnly );
+ B0 := 0;
+ MS.Write( B0, Sizeof( KOLChar ) );
+ {$IFDEF UNICODE_CTRLS}
+ {$ELSE}
+ if not (Format in [reUnicode,reTextUnicode]) then
+ Result := AnsiString(PAnsiChar( MS.fMemory )) // must be PAnsiChar, not PKOLChar!
+ else
+ {$ENDIF}
+ Result := PKOLChar( MS.fMemory );
+ MS.Free;
+end;
+
+function REInFromStream( Sender: PControl; Buf: PByte; Sz: DWORD; pSz: PInteger )
+ :DWORD; stdcall;
+begin
+ {$IFDEF _D3} if Sender.DF.fREStrLoadLen >= 0 then {$ENDIF}
+ if Sz > Sender.DF.fREStrLoadLen then
+ Sz := Sender.DF.fREStrLoadLen;
+ pSz^ := Sender.DF.fREStream.Read( Buf^, Sz );
+ Dec( Sender.DF.fREStrLoadLen, pSz^ );
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnProgress ) then
+ {$ENDIF}
+ Sender.EV.fOnProgress( Sender );
+ Result := 0;
+end;
+
+function TControl.RE_LoadFromStream(Stream: PStream; Length: Integer;
+ Format: TRETextFormat; SelectionOnly: Boolean): Boolean;
+var ES: TEditStream;
+ SelFlag: Integer;
+begin
+ DF.fREStream := Stream;
+ DF.fREStrLoadLen := DWORD( Length );
+ ES.dwCookie := Integer( @Self );
+ ES.dwError := 0;
+ ES.pfnCallback := @REInFromStream;
+ SelFlag := 0;
+ if SelectionOnly then
+ SelFlag := SFF_SELECTION;
+ Perform( EM_STREAMIN, TextTypes[ Format ] or SelFlag, Integer( @ES ) );
+ DF.fREStream := nil;
+ DF.fREError := ES.dwError;
+ Result := DF.fREError = 0;
+end;
+
+procedure TControl.REWriteText(Format: TRETextFormat;
+ SelectionOnly: Boolean; const Value: KOLString);
+var MS: PStream;
+ {$IFDEF UNICODE_CTRLS}
+ {$ELSE}
+ s: AnsiString; // not KOLString!
+ {$ENDIF}
+begin
+ fCommandActions.aAddText := RE_AddText;
+ {$IFDEF UNICODE_CTRLS}
+ {$ELSE}
+ if not (Format in [reUnicode,reTextUnicode]) then
+ begin
+ s := Value;
+ MS := NewExMemoryStream( @ s[ 1 ], Length( s ) );
+ end
+ else
+ {$ENDIF}
+ MS := NewExMemoryStream( @ Value[ 1 ], Length( Value ) * Sizeof( KOLChar ) );
+ RE_LoadFromStream( MS, MS.fData.fSize, Format, SelectionOnly );
+ MS.Free;
+end;
+
+function TControl.RE_LoadFromFile(const Filename: KOLString;
+ Format: TRETextFormat; SelectionOnly: Boolean): Boolean;
+var Strm: PStream;
+begin
+ Strm := NewReadFileStream( Filename );
+ Result := RE_LoadFromStream( Strm, -1, Format, SelectionOnly );
+ Strm.Free;
+end;
+
+function TControl.RE_SaveToFile(const Filename: KOLString;
+ Format: TRETextFormat; SelectionOnly: Boolean): Boolean;
+var Strm: PStream;
+begin
+ Strm := NewWriteFileStream( Filename );
+ Result := RE_SaveToStream( Strm, Format, SelectionOnly );
+ Strm.Free;
+end;
+
+function TControl.REGetParaFmt: TParaFormat;
+begin
+ ZeroMemory( @Result, sizeof( TParaFormat2 ) );
+ Result.cbSize := sizeof( RichEdit.TParaFormat ) + DF.fParaFmtDeltaSz;
+ Perform( EM_GETPARAFORMAT, 0, Integer( @Result ) );
+end;
+
+procedure TControl.RESetParaFmt(const Value: TParaFormat);
+begin
+ Perform( EM_SETPARAFORMAT, 0, Integer( @Value ) );
+end;
+
+function TControl.REGetNumbering: Boolean;
+begin
+ Result := LongBool( ReGetParaAttr( 9 shl 16 ) );
+end;
+
+function TControl.REGetParaAttr( const Index: Integer ): Integer;
+var pDw : PDWORD;
+begin
+ {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec
+ {$ELSE} DF.fREParaFmtRec^ {$ENDIF}
+ := REGetParaFmt;
+ pDw := Pointer( Integer( @DF.fREParaFmtRec ) + ( HiWord( Index ) and $7E ) );
+ Result := pDw^;
+ if LongBool( HiWord( Index ) and 1 ) then
+ Result := Result and $FFFF;
+end;
+
+function TControl.REGetParaAttrValid( const Index: Integer ): Boolean;
+begin
+ Result := LongBool( ReGetParaAttr( 4 shl 16 ) and Index );
+end;
+
+function TControl.REGetTabCount: Integer;
+begin
+ Result := ReGetParaAttr( 27 shl 16 );
+end;
+
+function TControl.REGetTabs(Idx: Integer): Integer;
+begin
+ Result := ReGetParaAttr( (28 + 4 * Idx) shl 16 );
+end;
+
+function TControl.REGetTextAlign: TRichTextAlign;
+begin
+ Result := TRichTextAlign( ReGetParaAttr( 25 shl 16 ) - 1 );
+end;
+
+procedure TControl.RESetNumbering(const Value: Boolean);
+begin
+ RESetParaAttr( (9 shl 16) or PFM_NUMBERING, Integer( Value ) );
+end;
+
+procedure TControl.RESetParaAttr(const Index, Value: Integer);
+var pDw: PDWORD;
+ Mask: Integer;
+begin
+ REGetParaAttr( 0 );
+ pDw := Pointer( Integer( @DF.fREParaFmtRec ) + ( HiWord( Index ) and $7E ) );
+ Mask := 0;
+ if LongBool( HiWord( Index ) and 1 ) then
+ Mask := Integer( $FFFF0000 );
+ pDw^ := pDw^ and Mask or DWORD(Value);
+ DF.fREParaFmtRec.dwMask := Index and $8000FFFF;
+ RESetParaFmt( {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec
+ {$ELSE} DF.fREParaFmtRec^ {$ENDIF} );
+end;
+
+procedure TControl.RESetTabCount(const Value: Integer);
+begin
+ REGetParaAttr( 0 );
+ RESetParaAttr( (27 shl 16) or PFM_TABSTOPS, Value );
+end;
+
+procedure TControl.RESetTabs(Idx: Integer; const Value: Integer);
+begin
+ REGetParaAttr( 0 );
+ RESetParaAttr( (28 + 4 * Idx) or PFM_TABSTOPS, Value );
+end;
+
+procedure TControl.RESetTextAlign(const Value: TRichTextAlign);
+begin
+ RESetParaAttr( (25 shl 16) or PFM_ALIGNMENT, Ord( Value ) + 1 );
+end;
+
+function TControl.REGetStartIndentValid: Boolean;
+begin
+ Result := REGetParaAttrValid( Integer( PFM_STARTINDENT ) );
+end;
+
+procedure TControl.RE_HideSelection(aHide: Boolean);
+begin
+ Perform( EM_HIDESELECTION, Integer( aHide ), 1 );
+end;
+
+function TControl.RE_SearchText(const Value: KOLString; MatchCase,
+ WholeWord, ScanForward: Boolean; SearchFrom, SearchTo: Integer): Integer;
+var Flags: Integer;
+ FT: {$IFDEF UNICODE_CTRLS} TFindTextW {$ELSE}
+ {$IFDEF _D2} TFindText {$ELSE} TFindTextA {$ENDIF} {$ENDIF};
+begin
+ Flags := Integer( ScanForward );
+{$IFDEF _D2009orHigher}
+{$WARN SYMBOL_DEPRECATED OFF} // check deprecate state
+{$ENDIF}
+ if WholeWord then Flags := Flags or FT_WHOLEWORD;
+ if MatchCase then Flags := Flags or FT_MATCHCASE;
+{$IFDEF _D2009orHigher}
+{$WARN SYMBOL_DEPRECATED ON}
+{$ENDIF}
+ FT.chrg.cpMin := SearchFrom;
+ FT.chrg.cpMax := SearchTo;
+ FT.lpstrText := PKOLChar( Value );
+ Result := Perform( EM_FINDTEXT, Flags, Integer( @FT ) );
+end;
+
+ {$IFNDEF _FPC}
+ {$IFNDEF _D2} //------- KOLWideString not supported in D2
+function TControl.RE_WSearchText(const Value: KOLWideString; MatchCase,
+ WholeWord, ScanForward: Boolean; SearchFrom, SearchTo: Integer): Integer;
+var Flags: Integer;
+ FT: TFindTextW;
+begin
+ Flags := Integer( ScanForward );
+{$IFDEF _D2009orHigher}
+{$WARN SYMBOL_DEPRECATED OFF} // check deprecate state
+{$ENDIF}
+ if WholeWord then Flags := Flags or FT_WHOLEWORD;
+ if MatchCase then Flags := Flags or FT_MATCHCASE;
+{$IFDEF _D2009orHigher}
+{$WARN SYMBOL_DEPRECATED ON} // switch on!
+{$ENDIF}
+ FT.chrg.cpMin := SearchFrom;
+ FT.chrg.cpMax := SearchTo;
+ FT.lpstrText := PWideChar( Value );
+ Result := Perform( WM_USER+123 {EM_FINDTEXTW}, Flags, Integer( @FT ) );
+end;
+ {$ENDIF}{$ENDIF}
+
+{$ENDIF NOT_USE_RICHEDIT}
+
+function TControl.CanUndo: Boolean;
+begin
+ Result := LongBool( Perform( EM_CANUNDO, 0, 0 ) );
+end;
+
+procedure TControl.EmptyUndoBuffer;
+begin
+ Perform( EM_EMPTYUNDOBUFFER, 0, 0 );
+end;
+
+function TControl.Undo: Boolean;
+begin
+ Result := LongBool( Perform( EM_UNDO, 0, 0 ) );
+end;
+
+{$IFNDEF NOT_USE_RICHEDIT}
+function TControl.RE_Redo: Boolean;
+begin
+ Result := LongBool( Perform( EM_REDO, 0, 0 ) );
+end;
+
+function TControl.REGetAutoURLDetect: Boolean;
+begin
+ Result := LongBool( Perform( EM_GETAUTOURLDETECT, 0, 0 ) );
+end;
+
+procedure TControl.RESetAutoURLDetect(const Value: Boolean);
+begin
+ AttachProc( WndProc_RE_LinkNotify );
+ Perform( EM_AUTOURLDETECT, Integer( Value ), 0 );
+end;
+
+procedure TControl.RESetZoom( const Value: TSmallPoint );
+begin
+ Perform( EM_SETZOOM, Value.x, Value.y );
+end;
+
+function TControl.REGetZoom: TSmallPoint;
+var P: TPoint;
+begin
+ Perform( EM_GETZOOM, Integer( @ P.X ), Integer( @ P.Y ) );
+ Result := Point2SmallPoint( P );
+end;
+
+function TControl.GetMaxTextSize: DWORD;
+begin
+ Result := Perform( EM_GETLIMITTEXT, 0, 0 );
+end;
+
+procedure TControl.SetMaxTextSize(const Value: DWORD);
+var V1, V2: Integer;
+begin
+ if fCommandActions.aSetLimit <> 0 then
+ begin
+ V1 := 0; V2 := Value;
+ if fCommandActions.aSetLimit = EM_SETLIMITTEXT then
+ begin
+ V1 := Value; V2 := 0;
+ end;
+ Perform( fCommandActions.aSetLimit, V1, V2 );
+ end;
+end;
+
+function WndProc_REFmt( _Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var Mask: Integer;
+ Shft, Alt, Ctrl, Flg: Boolean;
+ Delta: Integer;
+ TA: TRichTextAlign;
+ ChgTA: Boolean;
+ US: TRichUnderline;
+ NS: TRichNumbering;
+ NB: TRichNumBrackets;
+ Side: TBorderEdge;
+ Param: DWORD;
+begin
+ Result := False;
+ if Msg.message = WM_CHAR then
+ if _Self_.DF.FSupressTab then
+ begin
+ _Self_.DF.FSupressTab := FALSE;
+ if Msg.wParam = 9 then
+ begin
+ Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ if (Msg.message = WM_KEYDOWN) or (Msg.message = WM_SYSKEYDOWN) then
+ begin
+ Ctrl := GetKeyState( VK_CONTROL ) < 0;
+ Alt := GetKeyState( VK_MENU ) < 0;
+ Param := Msg.wParam;
+ if Ctrl or
+ Alt and IntIn(Param, [ VK_ADD, VK_SUBTRACT, Integer( '-' ), Integer( '=' ),
+ Integer( '+' ), 189 , 187 ]) then
+ begin
+ Shft := GetKeyState( VK_SHIFT ) < 0;
+ Rslt := 0;
+ Result := True;
+ Mask := 0;
+ ChgTA := False; TA := raLeft;
+ case Param of
+ Integer('Z'):
+ begin
+ if Shft then
+ begin
+ _Self_.RE_Redo; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := False;
+ end;
+
+ Integer('L'): begin ChgTA := True; TA := raLeft; end;
+ Integer('R'): begin ChgTA := True; TA := raRight; end;
+ Integer('E'): begin ChgTA := True; TA := raCenter; end;
+ Integer('J'): begin ChgTA := True; TA := raJustify; end;
+ Integer('N'): begin
+ if Shft then
+ begin
+ NS := _Self_.RE_NumStyle;
+ NB := _Self_.RE_NumBrackets;
+ if NS = rnBullets then
+ begin
+ _Self_.RE_NumStyle := rnNone; Exit; {>>>>>>>>>>>>>>>>>>}
+ end;
+ if NS = rnNone then
+ begin
+ _Self_.RE_NumStyle := rnBullets; Exit; {>>>>>>>>>>>>>>>}
+ end
+ else
+ if Ord( NB ) = 0 then
+ NB := High(NB) else
+ NB := Pred(NB);
+ _Self_.RE_NumBrackets := NB;
+ end
+ else
+ begin
+ NS := _Self_.RE_NumStyle;
+ if Ord( NS ) = 0 then
+ begin
+ NS := rnURoman; //rnULetter; //High( NS );
+ { because rnLRoman, rnURoman, rnNoNumber are not shown
+ in RichEdit. }
+ _Self_.RE_NumBrackets := rnbPeriod;
+ end else
+ NS := Pred(NS);
+ _Self_.RE_NumStyle := NS;
+ if NS in [ rnLRoman, rnURoman, rnArabic ] then
+ _Self_.RE_NumStart := 1;
+ end;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Integer('W'): begin
+ Delta := _Self_.RE_BorderWidth[ beLeft ] + 4;
+ if Shft then Delta := -1;
+ for Side := Low(Side) to High(Side) do
+ begin
+ if Delta < 0 then
+ _Self_.RE_BorderStyle[ Side ] := _Self_.RE_BorderStyle[ Side ] + 1
+ else
+ begin
+ _Self_.RE_BorderWidth[ Side ] := Delta;
+ _Self_.RE_BorderSpace[ Side ] := Delta;
+ end;
+ end;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ (* TABLES STUFF -- to try, uncomment it and press CTRL+T in RichEdit.
+ (and uncomment declaration for Tmp above).
+
+ Not finished, and seems no way to figure it out - even RichEdit20.dll
+ (i.e. Rich Edit v3.0) can not display tables properly formatted. :(((
+
+ Integer('T'): begin
+ if _Self_.RE_Table then
+ begin
+ //MsgOK( 'table' );
+ end;
+ Tmp := _Self_.REReadText( reRTF, True );
+ if StrIsStartingFrom( PAnsiChar(Tmp), '{\rtf' )
+ and (CopyTail( Tmp, 3 ) = '}'#$D#$A) then
+ begin
+ //Tmp := Copy( Tmp, 1, Length(Tmp) - 3 );
+ _Self_.RE_Text[ reRTF, True ] := '{\rtf1' + //Copy( Tmp, 1, 6 ) +
+ '\trowd' +
+ //'\lytcalctblwd' +
+ //'\oldlinewrap' +
+ //'\alntblind' +
+ //'\trgaph108' +
+ '\trleft-108' +
+ {'\trbrdrt\brdrs\brdrw10' +
+ '\trbrdrl\brdrs\brdrw10' +
+ '\trbrdrb\brdrs\brdrw10' +
+ '\trbrdrr\brdrs\brdrw10' +
+ '\trbrdrh\brdrs\brdrw10' +
+ '\trbrdrv\brdrs\brdrw10' +}
+ //'\clvertalt' +
+ {'\clbrdrt\brdrs\brdrw10' +
+ '\clbrdrl\brdrs\brdrw10' +
+ '\clbrdrb\brdrs\brdrw10' +
+ '\clbrdrr\brdrs\brdrw10' +}
+ //'\cltxlrtb' +
+ '\cellx1414' +
+ //'\pard' +
+ //'\plain' +
+ //'\widctlpar' +
+ '\trautofit1' +
+ '\intbl' +
+ //'\adjustright' +
+ //'\fs20\lang1049' +
+ //'\cgrid' +
+ '\trrh0' +
+ '{\clFitText{{\box\brdrs\brdrw20\brsp20}'+
+ '\par}\cell\row}' +
+ //'\pard\widctlpar' +
+ //'\intbl'+
+ //'\adjustright'+
+ //'{\row}' +
+ '\pard\widctlpar' +
+ '}'#$D#$A;
+ _Self_.Perform( WM_KEYDOWN, VK_UP, 0 );
+ _Self_.Perform( WM_KEYUP, VK_UP, 0 );
+ end; Exit;
+ end;
+ *)
+ Integer('B'): Mask := CFM_BOLD;
+ Integer('I'):
+ begin
+ Mask := CFM_ITALIC;
+ _Self_.DF.FSupressTab := TRUE;
+ end;
+ Integer('U'):
+ begin
+ if Shft then
+ begin
+ US := _Self_.RE_FmtUnderlineStyle;
+ if Ord(US) = 0 then US := High(TRichUnderLine)
+ else US := Pred( US );
+ _Self_.RE_FmtUnderlineStyle := US;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Mask := CFM_UNDERLINE;
+ end;
+ Integer('O'): Mask := CFM_STRIKEOUT;
+ VK_SUBTRACT, VK_ADD, Integer( '+' ), 187, Integer( '-' ), 189:
+ ;
+ else
+ begin
+ Result := False;
+ Msg.wParam := Param;
+ end;
+ end;
+ if not Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if ChgTA then
+ begin
+ if Shft then Result := False
+ else _Self_.RE_TextAlign := TA;
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ _Self_.REGetFont;
+ if Mask > 0 then
+ begin
+ if Shft then Result := False
+ else begin
+ Flg := _Self_.REGetFontEffects( Mask );
+ if not Flg then
+ _Self_.DF.fRECharFormatRec.dwEffects := _Self_.DF.fRECharFormatRec.dwEffects and not Mask;
+ _Self_.DF.fRECharFormatRec.dwEffects := _Self_.DF.fRECharFormatRec.dwEffects xor DWORD(Mask);
+ end;
+ end
+ else
+ if IntIn( Param, [ VK_ADD, VK_SUBTRACT, Integer( '+' ),
+ Integer( '-' ), 189, 187 ] ) then
+ begin
+ if (Param = VK_SUBTRACT) or (Param = DWORD( '-' )) or (Param = 189) then
+ Delta := -1
+ else
+ Delta := 1;
+ if Alt and Ctrl then
+ begin
+ Mask := Integer( CFM_SIZE ) or Integer( CFM_OFFSET );
+ Delta := 0;
+ _Self_.DF.fRECharFormatRec.yOffset := 0;
+ _Self_.DF.fRECharFormatRec.yHeight := 200;
+ end
+ else
+ if Alt then Mask := Integer( CFM_SIZE )
+ else Mask := Integer( CFM_OFFSET );
+ Inc( _Self_.DF.fRECharFormatRec.yOffset, Delta * _Self_.DF.fRECharFormatRec.yHeight div 3 );
+ Inc( _Self_.DF.fRECharFormatRec.yHeight, Delta * _Self_.DF.fRECharFormatRec.yHeight div 8 );
+ Flg := LongBool( _Self_.DF.fRECharFormatRec.dwMask and Mask );
+ if not Flg then
+ _Self_.DF.fRECharFormatRec.yOffset := 0;
+ end;
+ _Self_.DF.fRECharFormatRec.dwMask := Mask;
+ if _Self_.SelLength = 0 then
+ _Self_.SelLength := 1;
+ _Self_.Perform( EM_SETCHARFORMAT, SCF_SELECTION { RichAreas[ _Self_.fRECharArea ] },
+ Integer( {$IFDEF STATIC_RICHEDIT_DATA} @_Self_.DF.fRECharFormatRec
+ {$ELSE} _Self_.DF.fRECharFormatRec {$ENDIF} ) );
+ end;
+ end;
+end;
+
+function TControl.RE_FmtStandard: PControl;
+begin
+ AttachProc( WndProc_REFmt );
+ Result := @Self;
+end;
+
+procedure TControl.RE_CancelFmtStandard;
+begin
+ DetachProc( WndProc_REFmt );
+end;
+{$ENDIF NOT_USE_RICHEDIT}
+
+{$IFDEF ASM_TLIST}
+function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+asm //cmd //opd
+ CMP [EAX].TControl.fRefCount, 0
+ JL @@fin_false
+ PUSHAD
+ MOV EBX, EAX
+ MOV EBP, ECX
+ MOV ECX, [EBX].TControl.fDynHandlers
+ JECXZ @@ret_false
+ MOV ESI, ECX
+ MOV ECX, [ESI].TList.fCount
+ JECXZ @@ret_false
+ MOV EDI, ECX
+ SHR EDI, 1
+ CALL TControl.RefInc
+@@loo: DEC EDI
+ JS @@e_loo
+ PUSH EDX
+ PUSH EBX
+{$IFNDEF SMALLEST_CODE}
+{$IFNDEF ENUM_DYN_HANDLERS_AFTER_RUN}
+ XOR EAX, EAX
+ CMP [AppletTerminated], AL
+ JZ @@do_call
+ MOV ECX, [ESI].TList.fItems
+ MOV ECX, [ECX+EDI*8+4]
+ JECXZ @@skip_call
+{$ENDIF}
+{$ENDIF}
+@@do_call:
+ MOV EAX, [ESI].TList.fItems
+ MOV EAX, [EAX+EDI*8]
+ XCHG EAX, EBX
+ MOV ECX, EBP
+ CALL EBX
+@@skip_call:
+ POP EBX
+ POP EDX
+ TEST AL, AL
+ JZ @@loo
+@@ret_true:
+ MOV EAX, EBX
+ CALL TControl.RefDec
+ POPAD
+ MOV AL, 1
+ RET
+@@e_loo:
+ XOR EAX, EAX
+ INC EAX
+ CMP [EBX].TControl.fRefCount, EAX
+ JE @@ret_true
+ MOV EAX, EBX
+ CALL TControl.RefDec
+@@ret_false:
+ POPAD
+@@fin_false:
+ XOR EAX, EAX
+end;
+{$ELSE PAS_VERSION} //Pascal
+function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var I: Integer;
+ Proc: TWindowFunc;
+begin
+ Result := False;
+ if Self_.fRefCount < 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if (Self_.fDynHandlers = nil) or (Self_.fDynHandlers.fCount = 0) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Self_.RefInc; // Prevent destroying Self_
+ for I := Self_.fDynHandlers.fCount div 2 - 1 downto 0 do
+ begin
+ Proc := Self_.fDynHandlers.{$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;
+ break;
+ end;
+ end;
+ {$IFDEF DEBUG_ENDSESSION}
+ if EndSession_Initiated then
+ begin
+ LogFileOutput( GetStartDir + 'es_debug.txt',
+ 'ENUM_DYN_HANDLERS: Self_:' + Int2Hex( DWORD( Self_ ), 8 ) );
+ LogFileOutput( GetStartDir + 'es_debug.txt',
+ 'ENUM_DYN_HANDLERS: Self_.fRefCount:' + Int2Str( Self_.fRefCount ) );
+ end;
+ {$ENDIF}
+ if LongBool(Self_.fRefCount and 1) then
+ Result := True; // If Self_ will be destroyed now, stop further processing
+ Self_.RefDec; // Destroy Self_, if Free was called for it while processing attached procedures
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TransparentAttachProcExtension ( DynHandlers: PList );
+var i: integer;
+begin
+ I := DynHandlers.IndexOf( @WndProcTransparent );
+ if I >=0 then begin
+ DynHandlers.Delete( I );
+ DynHandlers.Delete( I );
+ DynHandlers.Add( @WndProcTransparent );
+ DynHandlers.Add( nil );
+ end;
+end;
+
+procedure DummyAttachProcExtension ( DynHandlers: PList );
+begin
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+procedure TControl.AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean );
+begin
+ //if fDynHandlers = nil then
+ // fDynHandlers := NewList;
+ if not IsProcAttached( Proc ) then
+ begin
+ fDynHandlers.Add( @Proc );
+ fDynHandlers.Add( Pointer( Integer( ExecuteAfterAppletTerminated ) ) );
+ end;
+ {$IFNDEF SMALLEST_CODE}
+ Global_AttachProcExtension(fDynHandlers);
+ {$ENDIF}
+ PP.fOnDynHandlers := EnumDynHandlers;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure TControl.AttachProc(Proc: TWindowFunc);
+begin
+ AttachProcEx( Proc, FALSE );
+end;
+
+procedure TControl.DetachProc(Proc: TWindowFunc);
+var I: Integer;
+begin
+ if fDynHandlers = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ I := fDynHandlers.IndexOf( @Proc );
+ if I >=0 then
+ begin
+ fDynHandlers.Delete( I );
+ fDynHandlers.Delete( I );
+ end;
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
+function TControl.IsProcAttached(Proc: TWindowFunc): Boolean;
+var I: Integer;
+begin
+ I := fDynHandlers.IndexOf( @Proc );
+ Result := I >=0;
+end;
+{$ENDIF PAS_VERSION}
+
+{$IFDEF nASM_VERSION}{$ELSE PAS_VERSION}
+function WndProcAutoPopupMenu( Control: PControl; var Msg: TMsg; var MsgRslt: Integer ): Boolean;
+var {$IFNDEF SMALLEST_CODE}
+ R: TRect;
+ M: Word;
+ I: Integer;
+ {$ENDIF SMALLEST_CODE}
+ P: TPoint;
+begin
+ if (Msg.message = WM_CONTEXTMENU) and
+ (Control.fAutoPopupMenu <> nil) then
+ begin
+ {$IFDEF USE_MENU_CURCTL}
+ PMenu( Control.fAutoPopupMenu ).fCurCtl := Control;
+ {$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;
+ if (I >= 0) and (M <> 0) then
+ begin
+ CASE M OF
+ EM_POSFROMCHAR:
+ begin
+ I := Control.SelStart + Control.SelLength;
+ // Edit or Rich Edit 2:
+ I := Control.Perform( M, I, 1 );
+ P.X := SmallInt( LoWord( I ) );
+ P.Y := SmallInt( HiWord( I ) );
+ end;
+ LB_GETITEMRECT, LVM_GETITEMRECT, TCM_GETITEMRECT:
+ begin
+ R.Left := LVIR_BOUNDS;
+ Control.Perform( M, I, Integer( @ R ) );
+ P.X := R.Left;
+ P.Y := R.Bottom;
+ end;
+ TVM_GETITEMRECT:
+ begin
+ I := Control.TVSelected;
+ R.Left := I;
+ Control.Perform( M, 1, Integer( @ R ) );
+ P.X := R.Left;
+ P.Y := R.Bottom;
+ end;
+ END;
+ R := Control.ClientRect;
+ if P.X < R.Left then P.X := R.Left;
+ if P.X > R.Right then P.X := R.Right;
+ if P.Y < R.Top then P.Y := R.Top;
+ if P.Y > R.Bottom then P.Y := R.Bottom;
+ 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,
+ if it is the same already as desired. }
+var pm: PMenu;
+begin
+ if PopupMenu <> nil then
+ {$IFDEF USE_MENU_CURCTL}
+ begin
+ pm := PMenu( PopupMenu );
+ if ( pm.FParentMenu <> nil ) then
+ begin
+ while pm.FControl = nil do
+ pm := pm.FParentMenu;
+ PMenu( PopupMenu ).FControl := pm.FControl;
+ end
+ else
+ begin
+ PMenu( PopupMenu ).FControl := @Self;
+ end;
+ AttachProc(WndProcAutoPopupMenu);
+ AttachProc(WndProcMenu)
+ end
+ else begin
+ DetachProc(WndProcAutoPopupMenu);
+ DetachProc(WndProcMenu);
+ end;
+ {$ELSE}
+ begin
+ pm := PMenu( PopupMenu );
+ while pm.FControl = nil do pm := pm.Parent;
+ PMenu( PopupMenu ).FControl := pm.FControl;
+ end;
+ {$ENDIF}
+ fAutoPopupMenu := PopupMenu;
+ {$IFNDEF USE_MENU_CURCTL}
+ AttachProc( WndProcAutoPopupMenu );
+ {$ENDIF}
+end;
+
+function SearchAnsiMnemonics( const S: KOLString ): KOLString;
+var I: Integer;
+ Sh: ShortInt;
+begin
+ Result := S;
+ for I := 1 to Length( Result ) do
+ begin
+ Sh := VkKeyScanEx( Result[ I ], MnemonicsLocale );
+ if Sh <> -1 then
+ Result[ I ] := KOLChar( Sh );
+ end;
+end;
+
+procedure SupportAnsiMnemonics( LocaleID: Integer );
+begin
+ MnemonicsLocale := LocaleID;
+ SearchMnemonics := SearchAnsiMnemonics;
+end;
+
+function WndProcMnemonics( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var Form: PControl;
+
+ function HandleMnemonic( Prnt: PControl ): Boolean;
+ var C: PControl;
+ XY: Integer;
+ procedure DoPressMnemonic;
+ begin
+ if Msg.message = WM_SYSKEYDOWN then
+ begin
+ //Form.DF.fPressedMnemonic := Msg.wParam;
+ C.Perform( WM_LBUTTONDOWN, MK_LBUTTON, XY );
+ end
+ else
+ begin
+ //Form.DF.fPressedMnemonic := 0;
+ C.Perform( WM_LBUTTONUP, MK_LBUTTON, XY );
+ end;
+ end;
+ var I, J: Integer;
+ R: TRect;
+ begin
+ for I := 0 to Prnt.ChildCount-1 do
+ begin
+ C := Prnt.Children[ I ];
+ if {$IFDEF USE_FLAGS} G5_IsButton in C.fFlagsG5
+ {$ELSE} C.IsButton {$ENDIF} then
+ if C.Enabled then
+ begin
+ if C.fCommandActions.aGetCount = TB_BUTTONCOUNT then
+ for J := 0 to C.Count-1 do
+ begin
+ if C.TBButtonEnabled[ J ] then
+ if pos( KOLString('&') + AnsiChar( Msg.wParam ), SearchMnemonics( C.TBButtonText[ J ] ) ) > 0 then
+ begin
+ C.fCurIndex := J;
+ C.DF.fTBCurItem := C.TBIndex2Item( J );
+ R := C.TBButtonRect[ J ];
+ XY := R.Left or (R.Top shl 16);
+ DoPressMnemonic;
+ Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ if pos( KOLString('&') + AnsiChar( Msg.wParam ), SearchMnemonics( C.Caption ) ) > 0 then
+ begin
+ XY := 0;
+ DoPressMnemonic;
+ Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ if HandleMnemonic( C ) then
+ begin
+ Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ Result := FALSE;
+ end;
+
+{$IFDEF NEW_MENU_ACCELL}
+ function FindByCtlRef(C: PControl; Accell: TMenuAccelerator): Boolean;
+
+ function FindInMenu(M: PMenu): PMenu;
+ var
+ I: Integer;
+ SM: PMenu;
+ begin
+ for I := 0 to M.FMenuItems.Count - 1 do begin
+ Result := M.FMenuItems.Items[I];
+ if (Cardinal(Result.Accelerator) = Cardinal(Accell)) and Result.Enabled then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := nil;
+ for I := 0 to M.FMenuItems.Count - 1 do begin
+ SM := PMenu(M.FMenuItems.Items[I]);
+ if (SM.FMenuItems.Count > 0) then
+ Result := FindInMenu(SM);
+ if (Result <> nil) then
+ Break;
+ end;
+ end;
+
+ function FindInMenu2(M: PMenu): Boolean;
+ var
+ MI: PMenu;
+ begin
+ if (M <> nil) then begin
+ MI := FindInMenu(M);
+ if (MI <> nil) then begin
+ //M.FControl.Perform(WM_COMMAND, MI.FId, 0);
+ C.Perform(WM_COMMAND, MI.FId, 0); // fixed
+ Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ Result := False;
+ end;
+
+ var
+ Parent: PControl;
+ begin
+ Result := False;
+ if not FindInMenu2(PMenu(C.fAutoPopupMenu)) then
+ if not FindInMenu2(PMenu(C.fMenuObj)) then begin
+ Parent := C.Parent;
+ if (Parent <> nil) then
+ Result := FindByCtlRef(Parent, Accell);
+ end;
+ end;
+
+var
+ Ac: TMenuAccelerator;
+{$ENDIF}
+begin
+ Result := FALSE;
+ if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
+ begin
+{$IFDEF NEW_MENU_ACCELL}
+ Ac := MakeAccelerator(FVIRTKEY or GetShiftState, Msg.wParam);
+ Result := FindByCtlRef(Sender, Ac);
+{$ELSE}
+ if (Sender.fAccelTable <> 0)
+ {$IFDEF KEY_PREVIEW}
+ and (Sender.DF.fKeyPreviewCount = 0)
+ {$ENDIF}
+ then
+ Result := LongBool( TranslateAccelerator( Sender.fHandle, Sender.fAccelTable, Msg ) );
+ if not Result then
+ begin
+ if Sender.DF.fCurrentControl <> nil then
+ if Sender.DF.fCurrentControl.fAccelTable <> 0 then
+ Result := LongBool( TranslateAccelerator( Sender.DF.fCurrentControl.fHandle,
+ Sender.DF.fCurrentControl.fAccelTable, Msg ) );
+ end;
+ if not Result then
+ begin
+ Form := Sender.ParentForm;
+ if (Form <> nil) and (Form <> Sender)
+ {$IFDEF KEY_PREVIEW}
+ and (Form.DF.fKeyPreviewCount = 0)
+ {$ENDIF KEY_PREVIEW}
+ then
+ if Form.fAccelTable <> 0 then
+ Result := LongBool( TranslateAccelerator( Form.fHandle,
+ Form.fAccelTable, Msg ) );
+ end;
+{$ENDIF}
+ end;
+ if Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if (Msg.message = WM_SYSKEYUP) or
+ (Msg.message = WM_SYSKEYDOWN) and (GetKeyState( VK_MENU ) < 0) then
+ begin
+ Rslt := 0;
+ Form := Sender.ParentForm;
+ if Form <> nil then
+ begin
+ if AnsiChar( Msg.wParam ) in [ 'A'..'Z', '0'..'9' ] then
+ begin
+ if HandleMnemonic( Form ) then
+ begin
+ Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end;
+ end else
+ if Msg.message = WM_KEYUP then
+ begin
+ Rslt := 0;
+ Form := Sender.ParentForm;
+ if Form <> nil then
+ begin
+ if Msg.wParam = VK_MENU then
+ // if Form.DF.fPressedMnemonic <> 0 then
+ // Form.DF.fPressedMnemonic := Form.DF.fPressedMnemonic or $80000000;
+ else if AnsiChar( Msg.wParam ) in [ 'A'..'Z', '0'..'9' ] then
+ begin
+ if HandleMnemonic( Form ) then
+ begin
+ Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ end;
+ end;
+ Result := FALSE;
+end;
+
+function TControl.SupportMnemonics: PControl;
+begin
+ fGlobalProcKeybd := WndProcMnemonics;
+ Result := @Self;
+end;
+
+procedure TControl.SelectAll;
+begin
+ SelStart := 0;
+ SelLength := -1; // this can be not working for some controls... //*//*
+end;
+
+{$IFnDEF NOT_USE_RICHEDIT}
+function RevokeDragDrop(wnd: HWnd): HResult; stdcall;
+ external 'ole32.dll' name 'RevokeDragDrop';
+
+function TControl.RE_NoOLEDragDrop: PControl;
+begin
+ RevokeDragDrop( Handle );
+ Result := @Self;
+end;
+{$ENDIF NOT_USE_RICHEDIT}
+
+function WndProcOnResize( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ if Msg.message = WM_SIZE then
+ begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnResize ) then
+ {$ENDIF}
+ Self_.EV.fOnResize( Self_ );
+ end;
+ Result := False;
+end;
+
+procedure TControl.SetOnResize(const Value: TOnEvent);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .FOnResize := Value;
+ AttachProc( WndProcOnResize );
+end;
+
+function WndProcMove( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ if Msg.message = WM_MOVE then
+ begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.FOnMove ) then
+ {$ENDIF}
+ Self_.EV.FOnMove( Self_ );
+ end;
+ Result := False;
+end;
+
+procedure TControl.SetOnMove(const Value: TOnEvent);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .FOnMove := Value;
+ AttachProc( WndProcMove );
+end;
+
+function WndProcMoving( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := False;
+ if Msg.message = WM_MOVING then
+ begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.FOnMoving ) then
+ {$ENDIF}
+ Self_.EV.FOnMoving( Self_, Pointer( Msg.lParam ) );
+ Rslt := 1;
+ Result := TRUE;
+ end;
+end;
+
+procedure TControl.SetOnMoving(const Value: TOnEventMoving);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .FOnMoving := Value;
+ AttachProc( WndProcMoving );
+end;
+
+{$IFNDEF NOT_USE_RICHEDIT}
+function WndProc_REBottomless( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ if Msg.message = WM_SIZE then
+ Self_.Perform( EM_REQUESTRESIZE, 0, 0 );
+ Result := False;
+end;
+
+function TControl.RE_Bottomless: PControl;
+begin
+ AttachProc( WndProc_REBottomless );
+ Result := @Self;
+end;
+
+procedure TControl.RE_Append(const S: KOLString; ACanUndo: Boolean);
+begin
+ SelStart := TextSize;
+ if S <> '' then
+ begin
+ ReplaceSelection( S, ACanUndo );
+ SelStart := TextSize;
+ end;
+end;
+
+procedure TControl.RE_InsertRTF(const S: KOLString);
+var MS: PStream;
+begin
+ MS := NewMemoryStream;
+ MS.Size := (Length( S ) + 1) * Sizeof(KOLChar);
+ Move( S[ 1 ], MS.Memory^, ( Length( S ) + 1 ) * Sizeof( KOLChar ) );
+ RE_LoadFromStream( MS, Length( S ), reRTF, TRUE );
+ MS.Free;
+end;
+{$ENDIF NOT_USE_RICHEDIT}
+
+procedure TControl.DoSelChange;
+begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( EV.fOnSelChange ) then
+ {$ELSE}
+ if TMethod( EV.fOnSelChange ).Code <> @DummyObjProc then
+ {$ENDIF}
+ EV.fOnSelChange( @Self )
+ else
+ {$IFDEF NIL_EVENTS}
+ if Assigned( EV.fOnChangeCtl ) then
+ {$ENDIF}
+ EV.fOnChangeCtl( @Self );
+end;
+
+{$IFNDEF NOT_USE_RICHEDIT}
+function TControl.REGetUnderlineEx: TRichUnderline;
+begin
+ Result := TRichUnderline( REGetFontAttr( ((81
+ {$IFDEF UNICODE_CTRLS} + 32 {$ENDIF})
+ shl 16) or CFM_UNDERLINETYPE ) - 1 );
+end;
+
+procedure TControl.RESetUnderlineEx(const Value: TRichUnderline);
+begin
+ RESetFontAttr( ((81
+ {$IFDEF UNICODE_CTRLS} + 32 {$ENDIF})
+ shl 16) or CFM_UNDERLINETYPE, Ord( Value ) + 1 );
+ RESetFontEffect( CFM_UNDERLINE, True );
+end;
+
+function TControl.GetTextSize: Integer;
+begin
+ Result := 0;
+ if fHandle <> 0 then
+ Result := GetWindowTextLength( fHandle );
+end;
+
+function TControl.REGetTextSize(Units: TRichTextSize): Integer;
+const TextLengthFlags: array[ TRichTextSizes ] of Integer =
+ ( not GTL_UseCRLF, not GTL_Precise, GTL_Close, GTL_NUMBytes );
+var GTL: TGetTextLengthEx;
+begin
+ GTL.flags := MakeFlags( @Units, TextLengthFlags );
+ if not(rtsBytes in Units) then
+ GTL.flags := GTL.flags or GTL_NUMCHARS;
+ GTL.codepage := CP_ACP;
+ Result := Perform( EM_GETTEXTLENGTHEX, Integer( @GTL ), 0 );
+end;
+
+function TControl.RE_TextSizePrecise: Integer;
+var gtlex : TGetTextLengthEx;
+begin
+ gtlex.flags := GTL_PRECISE;
+ gtlex.codepage := CP_ACP;
+ Result := Perform(EM_GETTEXTLENGTHEX,WPARAM(@gtlex), 0 );
+end;
+
+function TControl.REGetNumStyle: TRichNumbering;
+begin
+ Result := TRichNumbering( ReGetParaAttr( 9 shl 16 ) );
+end;
+
+procedure TControl.RESetNumStyle(const Value: TRichNumbering);
+begin
+ RESetParaAttr( (9 shl 16) or PFM_NUMBERING, Ord( Value ) );
+end;
+
+function TControl.REGetNumBrackets: TRichNumBrackets;
+begin
+ REGetParaAttr( 0 );
+ Result := TRichNumBrackets( (DF.fREParaFmtRec.wNumberingStyle shr 8) );
+end;
+
+procedure TControl.RESetNumBrackets(const Value: TRichNumBrackets);
+begin
+ REGetParaAttr( 0 );
+ DF.fREParaFmtRec.wNumberingStyle := DF.fREParaFmtRec.wNumberingStyle and $F8FF
+ or Word( Ord( Value ) shl 8 );
+ DF.fREParaFmtRec.dwMask := PFM_NUMBERINGSTYLE;
+ RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec
+ {$ELSE} DF.fREParaFmtRec^ {$ENDIF};
+end;
+
+function TControl.REGetNumTab: Integer;
+begin
+ REGetParaAttr( 0 );
+ Result := DF.fREParaFmtRec.wNumberingTab;
+end;
+
+procedure TControl.RESetNumTab(const Value: Integer);
+begin
+ REGetParaAttr( 0 );
+ DF.fREParaFmtRec.wNumberingTab := Value;
+ DF.fREParaFmtRec.dwMask := PFM_NUMBERINGTAB;
+ RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec
+ {$ELSE} DF.fREParaFmtRec^ {$ENDIF};
+end;
+
+function TControl.REGetNumStart: Integer;
+begin
+ REGetParaAttr( 0 );
+ Result := DF.fREParaFmtRec.wNumberingStart;
+end;
+
+procedure TControl.RESetNumStart(const Value: Integer);
+begin
+ REGetParaAttr( 0 );
+ DF.fREParaFmtRec.wNumberingStart := Value;
+ DF.fREParaFmtRec.dwMask := PFM_NUMBERINGSTART;
+ RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec
+ {$ELSE} DF.fREParaFmtRec^ {$ENDIF};
+end;
+
+function TControl.REGetSpacing( const Index: Integer ): Integer;
+begin
+ REGetParaAttr( 0 );
+ Result := PInteger( Integer(@DF.fREParaFmtRec.dySpaceBefore) + (Index and $F) )^;
+end;
+
+procedure TControl.RESetSpacing(const Index, Value: Integer);
+begin
+ REGetParaAttr( 0 );
+ PInteger( Integer(@DF.fREParaFmtRec.dySpaceBefore) + (Index and $F) )^ := Value;
+ DF.fREParaFmtRec.dwMask := Index and not $F;
+ RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec
+ {$ELSE} DF.fREParaFmtRec^ {$ENDIF};
+end;
+
+function TControl.REGetSpacingRule: Integer;
+begin
+ REGetParaAttr( 0 );
+ Result := DF.fREParaFmtRec.bLineSpacingRule;
+end;
+
+procedure TControl.RESetSpacingRule(const Value: Integer);
+begin
+ REGetParaAttr( 0 );
+ DF.fREParaFmtRec.bLineSpacingRule := Value;
+ DF.fREParaFmtRec.dwMask := PFM_LINESPACING;
+ RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec
+ {$ELSE} DF.fREParaFmtRec^ {$ENDIF};
+end;
+
+function TControl.REGetLevel: Integer;
+begin
+ REGetParaAttr( 0 );
+ Result := DF.fREParaFmtRec.bCRC;
+end;
+
+function TControl.REGetBorder(Side: TBorderEdge; const Index: Integer): Integer;
+begin
+ REGetParaAttr( 0 );
+ Result := PWORD( Integer(@DF.fREParaFmtRec.wBorderSpace) + Index )^ shr (Ord(Side) * 4);
+end;
+
+procedure TControl.RESetBorder(Side: TBorderEdge; const Index: Integer;
+ const Value: Integer);
+var Mask: Word;
+ pW : PWord;
+begin
+ REGetParaAttr( 0 );
+ pw := PWORD( Integer(@DF.fREParaFmtRec.wBorderSpace) + Index );
+ Mask := $F shl (Ord(Side) * 4);
+ pw^ := pw^ and not Mask or (Value shl (4 * Ord(Side)) );
+ DF.fREParaFmtRec.dwMask := PFM_BORDER;
+ RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec
+ {$ELSE} DF.fREParaFmtRec^ {$ENDIF};
+end;
+
+function TControl.REGetParaEffect(const Index: Integer): Boolean;
+begin
+ Result := LongBool( HiWord( REGetParaAttr( 8 shl 16 ) ) and Index );
+end;
+
+procedure TControl.RESetParaEffect(const Index: Integer;
+ const Value: Boolean);
+var Idx: Integer;
+begin
+ REGetParaAttr( 0 );
+ DF.fREParaFmtRec.wReserved := Index;
+ Idx := Index;
+ DF.fREParaFmtRec.dwMask := Idx shl 16;
+ RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec
+ {$ELSE} DF.fREParaFmtRec^ {$ENDIF};
+end;
+
+function WndProc_REMonitorIns( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := False;
+ if (Msg.message = WM_KEYDOWN) and (Msg.wParam = VK_INSERT) and
+ ((GetKeyState(VK_CONTROL) or GetKeyState(VK_SHIFT) or GetKeyState(VK_MENU)) >= 0) then
+ begin
+ if not Self_.DF.fReOvrDisable then
+ Self_.DF.fREOvr := not Self_.DF.fREOvr
+ else
+ Result := True;
+ {$IFDEF NIL_EVENTS}
+ if assigned( Self_.EV.fOnREInsModeChg ) then
+ {$ENDIF}
+ Self_.EV.fOnREInsModeChg( Self_ );
+ end;
+end;
+
+function TControl.REGetOverwite: Boolean;
+begin
+ AttachProc( WndProc_REMonitorIns );
+ Result := DF.fREOvr;
+end;
+
+procedure TControl.RESetOverwrite(const Value: Boolean);
+begin
+ if REGetOverwite = Value then // do not replace with fREOvr here!
+ Exit; // this installs monitor WndProc_REMonitorIns. {>>>>>>>>>>>>>>>>>>>>>}
+ Perform( WM_KEYDOWN, VK_INSERT, 0 );
+ Perform( WM_KEYUP, VK_INSERT, 0 );
+end;
+
+procedure TControl.RESetOvrDisable(const Value: Boolean);
+begin
+ REGetOverwite;
+ DF.fReOvrDisable := Value;
+end;
+
+function WndProc_RichEdTransp_ParentPaint( Self_:PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var I: Integer;
+ C: PControl;
+begin
+ if (Msg.message = WM_PAINT) and (Msg.wParam = 0) then
+ begin
+ for I := 0 to Self_.fChildren.fCount - 1 do
+ begin
+ C := Self_.fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ];
+ if {$IFDEF USE_FLAGS} G5_IsCommonCtl in C.fFlagsG5
+ {$ELSE} C.fIsCommonControl {$ENDIF} then
+ begin
+ Inc( C.DF.fREUpdCount );
+ PostMessage( C.fHandle, CM_NCUPDATE, C.DF.fREUpdCount, WM_PAINT );
+ InvalidateRect( C.fHandle, nil, False );
+ end;
+ end;
+ end;
+ Result := False;
+end;
+
+function WndProc_RichEdTransp_Update( Self_:PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var Rgn, Rgn1: HRgn;
+ R, CR: TRect;
+ Pt: TPoint;
+ VW, HH, VH, HW: Integer;
+begin
+ if Self_.DF.fRETransparent then
+ case Msg.message of
+ WM_CHAR, WM_KILLFOCUS, WM_SETFOCUS, WM_KEYDOWN, WM_LBUTTONDOWN:
+ begin
+ PostMessage( Self_.fHandle, CM_INVALIDATE, 0, 0 );
+ end;
+ WM_PAINT:
+ if Msg.wParam = 0 then
+ begin
+ Inc( Self_.DF.fREUpdCount );
+ PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.DF.fREUpdCount, Msg.message );
+ end;
+ WM_SIZE:
+ begin
+ Inc( Self_.DF.fREUpdCount );
+ PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.DF.fREUpdCount, Msg.message );
+ PostMessage( Self_.fHandle, CM_INVALIDATE, 0, 0 );
+ end;
+ WM_ERASEBKGND:
+ if Msg.wParam = 0 then
+ begin
+ Inc( Self_.DF.fREUpdCount );
+ PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.DF.fREUpdCount, Msg.message );
+ end;
+ WM_HSCROLL, WM_VSCROLL:
+ begin
+ Self_.DF.fREScrolling := LoWord( Msg.wParam ) <> SB_ENDSCROLL;
+ Inc( Self_.DF.fREUpdCount );
+ PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.DF.fREUpdCount, Msg.message );
+ if Self_.DF.fREScrolling then
+ Self_.Invalidate;
+ end;
+ CM_INVALIDATE:
+ begin
+ Self_.Parent.Invalidate;
+ Self_.Invalidate;
+ end;
+ CM_NCUPDATE:
+ if DWORD(Msg.wParam) = DWORD(Self_.DF.fREUpdCount) then
+ begin
+ GetWindowRect( Self_.fHandle, R );
+ Windows.GetClientRect( Self_.fHandle, CR );
+ Pt.x := 0; Pt.y := 0;
+ Pt := Self_.Client2Screen( Pt );
+ OffsetRect( CR, Pt.x, Pt.y );
+ Rgn := CreateRectRgn( R.Left, R.Top, R.Right, R.Bottom );
+ if Self_.DF.fREScrolling then
+ begin
+ VW := GetSystemMetrics( SM_CXVSCROLL );
+ HH := GetSystemMetrics( SM_CYHSCROLL );
+ VH := GetSystemMetrics( SM_CYVSCROLL );
+ HW := GetSystemMetrics( SM_CXHSCROLL );
+ if CR.Right + VW <= R.Right then
+ begin
+ Rgn1 := CreateRectRgn( CR.Right, CR.Top + VH, CR.Right + VW, CR.Bottom - VH );
+ CombineRgn( Rgn, Rgn, Rgn1, RGN_DIFF );
+ DeleteObject( Rgn1 );
+ end;
+ if CR.Bottom + HH <= R.Bottom then
+ begin
+ Rgn1 := CreateRectRgn( CR.Left + HW, CR.Bottom, CR.Right - HW, CR.Bottom + HH );
+ CombineRgn( Rgn, Rgn, Rgn1, RGN_DIFF );
+ DeleteObject( Rgn1 );
+ end;
+ end;
+ Self_.Perform( WM_NCPAINT, Rgn, 0 );
+ DeleteObject( Rgn ); // Unremarked By M.Gerasimov
+ end;
+ end;
+ Result := False;
+end;
+
+function TControl.REGetTransparent: Boolean;
+begin
+ Result := Longbool(ExStyle and WS_EX_TRANSPARENT);
+end;
+
+procedure TControl.RESetTransparent(const Value: Boolean);
+begin
+ if Value then
+ ExStyle := ExStyle or WS_EX_TRANSPARENT
+ else
+ ExStyle := ExStyle and not WS_EX_TRANSPARENT;
+ DF.fRETransparent := Value;
+ fParent.AttachProc( WndProc_RichEdTransp_ParentPaint );
+ AttachProc( WndProc_RichEdTransp_Update );
+ {$IFDEF USE_FLAGS}
+ if Value then
+ include( fFlagsG2, G2_Transparent )
+ else exclude( fFlagsG2, G2_Transparent );
+ {$ELSE} fTransparent := Value; {$ENDIF}
+end;
+
+procedure TControl.RESetOnURL(const Index: Integer; const Value: TOnEvent);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents; {$ENDIF}
+ if Index = 0 then
+ EV.fOnREOverURL := Value
+ else
+ EV.fOnREURLClick := Value;
+ RE_AutoURLDetect :=
+ assigned(EV.fOnREOverURL) or assigned(EV.fOnREURLClick);
+end;
+
+procedure TControl.SetOnRE_URLClick(const Value: TOnEvent);
+begin
+ RESetOnURL( 1, Value );
+end;
+
+procedure TControl.SetOnRE_OverURL(const Value: TOnEvent);
+begin
+ RESetOnURL( 0, Value );
+end;
+
+function TControl.REGetOnURL(const Index: Integer): TOnEvent;
+begin
+ CASE Index OF
+ 0: Result := EV.fOnREOverURL;
+ else Result := EV.fOnREURLClick;
+ END;
+end;
+
+function TControl.REGetLangOptions(const Index: Integer): Boolean;
+begin
+ Result := LongBool( Perform( EM_GETLANGOPTIONS, 0, 0 ) and Index);
+end;
+
+procedure TControl.RESetLangOptions(const Index: Integer;
+ const Value: Boolean);
+var Mask: Integer;
+begin
+ Mask := -1;
+ if not Value then Inc( Mask );
+ Perform( EM_SETLANGOPTIONS, 0, Perform( EM_GETLANGOPTIONS, 0, 0 ) and
+ not Index or (Mask and Index) );
+end;
+{$ENDIF NOT_USE_RICHEDIT}
+
+function DoTrackMouseEvent(lpEventTrack: PTrackMouseEvent): BOOL;
+var FunTrack: function(lpEventTrack: PTrackMouseEvent): BOOL; stdcall;
+ ComCtlModule: THandle;
+begin
+ Result := FALSE;
+ ComCtlModule := GetModuleHandle( cctrl );
+ if ComCtlModule = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FunTrack := GetProcAddress( ComCtlModule, '_TrackMouseEvent' );
+ if not Assigned( FunTrack ) then Exit; // is necessary for Win95! {>>>>>>>>>>}
+ Result := FunTrack( lpEventTrack );
+end;
+
+function WndProcMouseEnterLeave( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+ forward;
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+function WndProcMouseEnterLeave( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var P: TPoint;
+ MouseWasInControl: Boolean;
+ Yes: Boolean;
+ Track: TTrackMouseEvent;
+begin
+ case Msg.message of
+ WM_MOUSEFIRST..WM_MOUSELAST:
+ begin
+ MouseWasInControl := {$IFDEF USE_FLAGS} G3_MouseInCtl in Self_.fFlagsG3;
+ {$ELSE} Self_.fMouseInControl; {$ENDIF}
+ if Assigned( Self_.EV.fOnTestMouseOver ) then
+ Yes := Self_.EV.fOnTestMouseOver( Self_ )
+ else
+ begin
+ GetCursorPos( P );
+ P := Self_.Screen2Client( P );
+ Yes := PointInRect( P, Self_.ClientRect );
+ end;
+ if MouseWasInControl <> Yes then
+ begin
+ Self_.Invalidate;
+ if Yes then
+ begin
+ {$IFDEF USE_FLAGS} include( Self_.fFlagsG3, G3_MouseInCtl );
+ {$ELSE} Self_.fMouseInControl := TRUE; {$ENDIF}
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseEnter ) then
+ {$ENDIF}
+ Self_.EV.fOnMouseEnter( Self_ );
+ Track.cbSize := Sizeof( Track );
+ Track.dwFlags := TME_LEAVE;
+ Track.hwndTrack := Self_.Handle;
+ DoTrackMouseEvent( @ Track );
+ Self_.Invalidate;
+ end
+ else
+ begin
+ {$IFDEF USE_FLAGS} exclude( Self_.fFlagsG3, G3_MouseInCtl );
+ {$ELSE} Self_.fMouseInControl := FALSE; {$ENDIF}
+ Track.cbSize := Sizeof( Track );
+ Track.dwFlags := TME_LEAVE or TME_CANCEL;
+ Track.hwndTrack := Self_.Handle;
+ DoTrackMouseEvent( @ Track );
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseLeave ) then
+ {$ENDIF}
+ Self_.EV.fOnMouseLeave( Self_ );
+ Self_.Invalidate;
+ end;
+ end;
+ end;
+ WM_MOUSELEAVE:
+ begin
+ if {$IFDEF USE_FLAGS} G3_MouseInCtl in Self_.fFlagsG3
+ {$ELSE} Self_.fMouseInControl {$ENDIF} then
+ begin
+ {$IFDEF USE_FLAGS} exclude( Self_.fFlagsG3, G3_MouseInCtl);
+ {$ELSE} Self_.fMouseInControl := FALSE; {$ENDIF}
+ {$IFDEF GRAPHCTL_HOTTRACK}
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fMouseLeaveProc ) then
+ {$ENDIF}
+ Self_.EV.fMouseLeaveProc( Self_ );
+ {$ENDIF}
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Self_.EV.fOnMouseLeave ) then
+ {$ENDIF}
+ Self_.EV.fOnMouseLeave( Self_ );
+ Self_.Invalidate;
+ end;
+ end;
+ end;
+ Result := False;
+end;
+{$ENDIF PAS_VERSION}
+
+procedure ProvideMouseEnterLeave( Self_: PControl );
+begin
+ InitCommonControls;
+ Self_.AttachProc( WndProcMouseEnterLeave );
+end;
+
+procedure TControl.SetFlat(const Value: Boolean);
+begin
+ {$IFDEF USE_FLAGS}
+ if Value then
+ include( fFlagsG3, G3_Flat )
+ else exclude( fFlagsG3, G3_Flat );
+ exclude( fFlagsG3, G3_MouseInCtl );
+ {$ELSE}
+ fFlat := Value;
+ fMouseInControl := FALSE;
+ {$ENDIF}
+ ProvideMouseEnterLeave( @Self );
+ Invalidate;
+end;
+
+procedure TControl.SetOnMouseEnter(const Value: TOnEvent);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnMouseEnter := Value;
+ ProvideMouseEnterLeave( @Self );
+end;
+
+procedure TControl.SetOnMouseLeave(const Value: TOnEvent);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnMouseLeave := Value;
+ ProvideMouseEnterLeave( @Self );
+end;
+
+procedure TControl.SetOnTestMouseOver(const Value: TOnTestMouseOver);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnTestMouseOver := Value;
+ ProvideMouseEnterLeave( @Self );
+end;
+
+function WndProcEdTransparent( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ if (Msg.message = WM_KEYDOWN) or
+ (Msg.message = WM_MOUSEMOVE) and (GetKeyState( VK_LBUTTON ) < 0) or
+ (Msg.message = WM_LBUTTONUP) or (Msg.message = WM_LBUTTONDOWN) then
+ Self_.Invalidate;
+ Result := False; // continue handling of a message anyway
+end;
+
+procedure TControl.EdSetTransparent(const Value: Boolean);
+begin
+ Transparent := Value;
+ AttachProc( WndProcEdTransparent );
+end;
+
+var LastHWnd: HWnd; // + Don
+function WndProcSpeedButton( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := False;
+ if Msg.message = WM_SETFOCUS then
+ begin
+ Result := TRUE;
+ Rslt := 0;
+ LastHWnd := Msg.wParam; // + don
+ end else // + Don
+ if (Msg.message = WM_CAPTURECHANGED) and
+ (Msg.lParam = 0) and
+ (LastHwnd <> 0) then
+ begin
+ SetFocus(LastHwnd);
+ LastHwnd := 0;
+ end;
+end;
+
+function TControl.LikeSpeedButton: PControl;
+var Form: PControl;
+begin
+ AttachProc( WndProcSpeedButton );
+ {$IFDEF USE_FLAGS}
+ {$ELSE} fTabstop := False; {$ENDIF}
+ Style := Style and not WS_TABSTOP;
+ Form := ParentForm;
+ if Form <> nil then
+ if Form.DF.fCurrentControl = @Self then
+ begin
+ Form.GotoControl( VK_TAB );
+ if Form.DF.fCurrentControl = @Self then
+ Form.DF.fCurrentControl := nil;
+ end;
+ Result := @Self;
+end;
+
+{ -- Unicode -- }
+function TControl.SetUnicode(Unicode: Boolean): PControl;
+begin
+ Perform( CCM_SETUNICODEFORMAT, Integer( Unicode ), 0 );
+ Result := @ Self;
+end;
+
+{ -- TabControl -- }
+
+function TControl.GetPages(Idx: Integer): PControl;
+var Item: TTCItem;
+begin
+ Item.mask := TCIF_PARAM;
+ if Perform( TCM_GETITEM, Idx, Integer( @Item ) ) = 0 then
+ Result := nil
+ else
+ Result := Pointer( Item.lParam );
+end;
+
+function TControl.TCGetItemText(Idx: Integer): KOLString;
+var TI: TTCItem;
+ Buffer: array[ 0..1023 ] of KOLChar;
+begin
+ TI.mask := TCIF_TEXT;
+ TI.pszText := @Buffer[ 0 ];
+ TI.cchTextMax := sizeof( Buffer );
+ Buffer[ 0 ] := #0;
+ Perform( TCM_GETITEM, Idx, Integer( @TI ) );
+ Result := PKOLChar( @ Buffer[ 0 ] );
+end;
+
+procedure TControl.TCSetItemText(Idx: Integer; const Value: KOLString);
+var TI: TTCItem;
+begin
+ TI.mask := TCIF_TEXT;
+ TI.pszText := PKOLChar( Value );
+ Perform( TCM_SETITEM, Idx, Integer( @TI ) );
+end;
+
+function TControl.TCGetItemImgIDx(Idx: Integer): Integer;
+var TI: TTCItem;
+begin
+ TI.mask := TCIF_IMAGE;
+ if Perform( TCM_GETITEM, Idx, Integer( @TI ) ) = 0 then
+ Result := -1
+ else Result := TI.iImage;
+end;
+
+procedure TControl.TCSetItemImgIdx(Idx: Integer; const Value: Integer);
+var TI: TTCItem;
+begin
+ TI.mask := TCIF_IMAGE;
+ TI.iImage := Value;
+ Perform( TCM_SETITEM, Idx, Integer( @TI ) );
+end;
+
+function TControl.TCGetItemRect(Idx: Integer): TRect;
+begin
+ if Perform( TCM_GETITEMRECT, Idx, Integer( @Result ) ) = 0 then
+ begin
+ Result.Left := 0;
+ Result.Right := 0;
+ Result.Top := 0;
+ Result.Bottom := 0;
+ end;
+end;
+
+procedure TControl.TC_SetPadding(cx, cy: Integer);
+begin
+ Perform( TCM_SETPADDING, 0, cx or (cy shl 16) );
+end;
+
+function TControl.TC_TabAtPos(x, y: Integer): Integer;
+type TTCHittestInfo = packed record
+ Pt: TPoint;
+ Fl: DWORD;
+ end;
+var HTI: TTCHitTestInfo;
+begin
+ HTI.Pt.x := x;
+ HTI.Pt.y := y;
+ Result := Perform( TCM_HITTEST, 0, Integer( @HTI ) );
+end;
+
+function TControl.TC_DisplayRect: TRect;
+begin
+ Windows.GetClientRect( fHandle, Result );
+ Perform( TCM_ADJUSTRECT, 0, Integer( @Result ) );
+end;
+
+function TControl.TC_IndexOf(const S: KOLString): Integer;
+begin
+ Result := TC_SearchFor( S, -1, FALSE );
+end;
+
+function TControl.TC_SearchFor(const S: KOLString; StartAfter: Integer;
+ Partial: Boolean): Integer;
+var I: Integer;
+begin
+ Result := -1;
+ for I := StartAfter+1 to Count-1 do
+ begin
+ if Partial and ( Copy( TC_Items[ I ], 1, Length( S ) ) = S ) or
+ ( TC_Items[ I ] = S ) then
+ begin
+ Result := I;
+ break;
+ end;
+ end;
+end;
+
+function TControl.TC_Insert(Idx: Integer; const TabText: KOLString;
+ TabImgIdx: Integer): PControl;
+var TI: TTCItem;
+begin
+ Result := NewPanel( @Self, esNone );
+ {$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 := Integer( Result );
+ Perform( TCM_INSERTITEM, Idx, Integer( @TI ) );
+ {$IFDEF OLD_ALIGN}
+ Result.BoundsRect := TC_DisplayRect;//+ Galkov
+ {$ENDIF}
+ Perform(WM_SIZE,0,0); //May be changes of margins for TabControl
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ Attach_WM_THEMECHANGED(Result, XP_Themes_For_TabPanel);
+ {$ENDIF}
+end;
+
+procedure TControl.TC_Delete(Idx: Integer);
+var Page: PControl;
+begin
+ Page := TC_Pages[ Idx ];
+ if Page = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Perform( TCM_DELETEITEM, Idx, 0 );
+ Page.Free;
+ Perform(WM_SIZE,0,0); //May be changes of margins for TabControl
+end;
+
+{$IFNDEF OLD_ALIGN}
+procedure TControl.TC_InsertControl( Idx: Integer; const TabText: KOLString;
+ TabImgIdx: Integer; Page: PControl);
+var TI: TTCItem;
+begin
+ Page.Visible := CurIndex<0;
+ TI.mask := TCIF_TEXT or TCIF_IMAGE or TCIF_PARAM;
+ TI.iImage := TabImgIdx;
+ TI.pszText := PKOLChar( TabText );
+ TI.lParam := Integer( Page );
+ Perform( TCM_INSERTITEM, Idx, Integer( @TI ) );
+ Perform(WM_SIZE,0,0); //May be changes of margins for TabControl
+end;
+
+function TControl.TC_Remove( Idx: Integer ):PControl;
+begin
+ Result := TC_Pages[ Idx ];
+ if Result = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Perform( TCM_DELETEITEM, Idx, 0 );
+ Perform(WM_SIZE,0,0); //May be changes of margins for TabControl
+end;
+{$ENDIF}
+
+{ -- TreeView -- }
+
+function TControl.TVGetItemIdx(const Index: Integer): THandle;
+begin
+ Result := Perform( TVM_GETNEXTITEM, Index, 0 );
+end;
+
+procedure TControl.TVSetItemIdx(const Index: Integer;
+ const Value: THandle);
+begin
+ Perform( TVM_SELECTITEM, Index, Value );
+end;
+
+function TControl.TVGetItemNext(Item: THandle; const Index: Integer): THandle;
+begin
+ Result := Perform( TVM_GETNEXTITEM, Index, Item );
+end;
+
+function TControl.TVGetItemRect(Item: THandle; TextOnly: Boolean): TRect;
+begin
+ Result.Left := Item;
+ if Perform( TVM_GETITEMRECT, Integer( TextOnly ), Integer( @Result ) ) = 0 then
+ begin
+ Result.Left := 0;
+ Result.Right := 0;
+ Result.Top := 0;
+ Result.Bottom := 0;
+ end;
+end;
+
+function TControl.TVGetItemVisible(Item: THandle): Boolean;
+var R: TRect;
+begin
+ R := TVItemRect[ Item, False ];
+ Result := R.Bottom > R.Top;
+end;
+
+procedure TControl.TVSetItemVisible(Item: THandle; const Value: Boolean);
+begin
+ if Value then
+ Perform( TVM_ENSUREVISIBLE, 0, Item );
+end;
+
+function TControl.TVGetItemStateFlg(Item: THandle; const Index: Integer): Boolean;
+var TVI: TTVItem;
+begin
+ TVI.mask := TVIF_HANDLE or TVIF_STATE;
+ TVI.hItem := Item;
+ TVI.stateMask := Index;
+ Result := False;
+ if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then
+ Result := (TVI.state and Index) <> 0;
+end;
+
+procedure TControl.TVSetItemStateFlg(Item: THandle; const Index: Integer;
+ const Value: Boolean);
+var TVI: TTVItem;
+begin
+ TVI.mask := TVIF_HANDLE or TVIF_STATE;
+ TVI.hItem := Item;
+ TVI.stateMask := Index;
+ TVI.state := $FFFFFFFF and Index;
+ if not Value then
+ TVI.state := 0;
+ Perform( TVM_SETITEM, 0, Integer( @TVI ) );
+end;
+
+function TControl.TVGetItemImage(Item: THandle; const Index: Integer): Integer;
+var TVI: TTVItem;
+begin
+ TVI.mask := TVIF_HANDLE or Loword( Index );
+ TVI.hItem := Item;
+ if Hiword( Index ) <> 0 then
+ begin
+ TVI.mask := TVIF_STATE or TVIF_HANDLE;
+ TVI.stateMask := Loword( Index );
+ end;
+ Result := -1;
+ if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then
+ begin
+ if Hiword( Index ) <> 0 then
+ Result := (TVI.state shr Hiword( Index )) and $F
+ else if Loword( Index ) = TVIF_IMAGE then
+ Result := TVI.iImage
+ else Result := TVI.iSelectedImage;
+ end;
+end;
+
+procedure TControl.TVSetItemImage(Item: THandle; const Index: Integer;
+ const Value: Integer);
+var TVI: TTVItem;
+begin
+ TVI.mask := TVIF_HANDLE or Loword( Index );
+ TVI.hItem := Item;
+ TVI.iImage := Value;
+ TVI.iSelectedImage := Value;
+ if Hiword( Index ) <> 0 then
+ begin
+ TVI.mask := TVIF_STATE or TVIF_HANDLE;
+ TVI.stateMask := Loword( Index );
+ TVI.state := Value shl Hiword( Index );
+ end;
+ Perform( TVM_SETITEM, 0, Integer( @TVI ) );
+end;
+
+function TControl.TVGetItemText(Item: THandle): KOLString;
+var TVI: TTVItem;
+ Buffer: array[ 0..4095 ] of KOLChar;
+begin
+ TVI.mask := TVIF_HANDLE or TVIF_TEXT;
+ TVI.hItem := Item;
+ TVI.pszText := @Buffer[ 0 ];
+ Buffer[ 0 ] := #0;
+ TVI.cchTextMax := Sizeof( Buffer ) {$IFDEF UNICODE_CTRLS} div Sizeof( KOLChar ) {$ENDIF};
+ Perform( TVM_GETITEM, 0, Integer( @TVI ) );
+ Result := PKOLChar( @ Buffer[ 0 ] );
+end;
+
+procedure TControl.TVSetItemText(Item: THandle; const Value: KOLString);
+var TVI: TTVItem;
+begin
+ TVI.mask := TVIF_HANDLE or TVIF_TEXT;
+ TVI.hItem := Item;
+ TVI.pszText := PKOLChar( Value );
+ Perform( TVM_SETITEM, 0, Integer( @TVI ) );
+end;
+
+function TControl.TVItemPath(Item: THandle; Delimiter: KOLChar): KOLString;
+begin
+ if Item = 0 then
+ Item := TVSelected;
+ Result := '';
+ while Item <> 0 do
+ begin
+ if Result <> '' then
+ Result := KOLString(Delimiter) + Result;
+ Result := TVItemText[ Item ] + Result;
+ Item := TVItemParent[ Item ];
+ end;
+end;
+
+function TControl.TV_GetItemHasChildren(Item: THandle): Boolean;
+var TVI: TTVItem;
+begin
+ TVI.mask := TVIF_HANDLE or TVIF_CHILDREN;
+ TVI.hItem := Item;
+ Perform( TVM_GETITEM, 0, Integer( @TVI ) );
+ Result := TVI.cChildren = 1;
+end;
+
+function TControl.TV_GetItemChildCount(Item: THandle): Integer;
+var Node: THandle;
+begin
+ Result := 0;
+ Node := TVItemChild[ Item ];
+ while Node <> 0 do
+ begin
+ Inc( Result );
+ Node := TVItemNext[ Node ];
+ end;
+end;
+
+procedure TControl.TV_SetItemHasChildren(Item: THandle;
+ const Value: Boolean);
+var TVI: TTVItem;
+begin
+ TVI.mask := TVIF_HANDLE or TVIF_CHILDREN;
+ TVI.hItem := Item;
+ TVI.cChildren := 1 and Integer( Value );
+ Perform( TVM_SETITEM, 0, Integer( @TVI ) );
+end;
+
+function TControl.TVItemAtPos(x, y: Integer; var Where: DWORD): THandle;
+var HTI: TTVHitTestInfo;
+begin
+ HTI.pt.x := x;
+ HTI.pt.y := y;
+ Result := Perform( TVM_HITTEST, 0, Integer( @HTI ) );
+ Where := HTI.fl;
+end;
+
+type
+ TTVInsertStruct = packed Record
+ hParent: THandle;
+ hAfter : THandle;
+ item: TTVItem;
+ end;
+ TTVInsertStructEx = packed Record
+ hParent: THandle;
+ hAfter : THandle;
+ item: TTVItemEx;
+ end;
+
+function TControl.TVInsert(nParent, nAfter: THandle;
+ const Txt: KOLString): THandle;
+var TVIns: TTVInsertStruct;
+begin
+ TVIns.hParent := nParent;
+ TVIns.hAfter := nAfter;
+ TVIns.item.mask := TVIF_TEXT;
+ TVIns.item.pszText := PKOLChar( Txt );
+ Result := Perform( TVM_INSERTITEM, 0, Integer( @TVIns ) );
+ if fUpdateCount <= 0 then
+ Invalidate;
+end;
+
+procedure TControl.TVExpand(Item: THandle; Flags: DWORD);
+begin
+ Perform( TVM_EXPAND, Flags, Item );
+end;
+
+procedure TControl.TVSort( N: THandle );
+var a: Cardinal;
+ b: Boolean;
+begin
+ b := N = 0;
+ if b then
+ N := TVRoot;
+ while N <> 0 do
+ begin
+ a := TVItemChild[N];
+ if a > 0 then TVSort(a);
+ Perform(TVM_SORTCHILDREN, 0, N);
+ N := TVItemNext[N];
+ end;
+ if b then //moved by Tr"]f
+ Perform(TVM_SORTCHILDREN, 0, 0); //+ by YS
+end;
+
+procedure TControl.TVDelete(Item: THandle);
+begin
+ Perform( TVM_DELETEITEM, 0, Item );
+ Invalidate;
+end;
+
+function TControl.TVGetItemData(Item: THandle): Pointer;
+var TVI: TTVItem;
+begin
+ TVI.mask := TVIF_HANDLE or TVIF_PARAM;
+ TVI.hItem := Item;
+ Result := nil;
+ if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then
+ Result := Pointer( TVI.lParam );
+end;
+
+procedure TControl.TVSetItemData(Item: THandle; const Value: Pointer);
+var TVI: TTVItem;
+begin
+ TVI.mask := TVIF_HANDLE or TVIF_PARAM;
+ TVI.hItem := Item;
+ TVI.lParam := Integer( Value );
+ Perform( TVM_SETITEM, 0, Integer( @TVI ) );
+end;
+
+procedure TControl.TVEditItem(Item: THandle);
+begin
+ Perform( TVM_EDITLABEL, 0, Item );
+end;
+
+procedure TControl.TVStopEdit(Cancel: Boolean);
+begin
+ Perform( TVM_ENDEDITLABELNOW, Integer( Cancel ), 0 );
+end;
+
+function WndProcTVRightClickSelect( Sender: PControl; var Msg: TMsg; var R: Integer ): Boolean;
+var I: Integer;
+ Where: DWORD;
+begin
+ if Msg.message = WM_RBUTTONDOWN then
+ begin
+ I := Sender.TVItemAtPos( SmallInt( Msg.lParam and $FFFF ),
+ SmallInt( Msg.lParam shr 16 ), Where );
+ if I <> 0 then
+ Sender.TVSelected := I;
+ end;
+ Result := FALSE;
+end;
+
+procedure TControl.SetTVRightClickSelect(const Value: Boolean);
+begin
+ DF.fTVRightClickSelect := Value;
+ if Value then
+ AttachProc( @WndProcTVRightClickSelect );
+end;
+
+procedure TControl.SetOnTVDelete( const Value: TOnTVDelete );
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnTVDelete := Value;
+ if fParent <> nil then
+ begin
+ fParent.Add2AutoFreeEx( Clear );
+ fParent.DetachProc( WndProcNotify );
+ fParent.AttachProcEx( WndProcNotify, TRUE );
+ end;
+ AttachProcEx( ProcTVDeleteItem, TRUE );
+end;
+
+function ClipboardHasText: Boolean;
+begin
+ Result := false;
+ if OpenClipboard( 0 ) then
+ begin
+ if IsClipboardFormatAvailable( CF_TEXT ) then
+ Result := TRUE;
+ CloseClipboard;
+ end;
+end;
+
+function Clipboard2Text: AnsiString;
+var gbl: THandle;
+ str: PAnsiChar;
+begin
+ Result := '';
+ if OpenClipboard( 0 ) then
+ begin
+ if IsClipboardFormatAvailable( CF_TEXT ) then
+ begin
+ gbl := GetClipboardData( CF_TEXT );
+ if gbl <> 0 then
+ begin
+ str := GlobalLock( gbl );
+ if str <> nil then
+ begin
+ Result := str;
+ GlobalUnlock( gbl );
+ end;
+ end;
+ end;
+ CloseClipboard;
+ end;
+end;
+
+{$IFNDEF _D2}
+function Clipboard2WText: KOLWideString;
+var gbl: THandle;
+ str: PWideChar;
+begin
+ Result := '';
+ if OpenClipboard( 0 ) then
+ begin
+ if IsClipboardFormatAvailable( CF_UNICODETEXT ) then
+ begin
+ gbl := GetClipboardData( CF_UNICODETEXT );
+ if gbl <> 0 then
+ begin
+ str := GlobalLock( gbl );
+ if str <> nil then
+ begin
+ Result := str;
+ GlobalUnlock( gbl );
+ end;
+ end;
+ end;
+ CloseClipboard;
+ end;
+end;
+{$ENDIF}
+
+function Text2Clipboard( const S: AnsiString ): Boolean;
+var gbl: THandle;
+ str: PAnsiChar;
+begin
+ Result := False;
+ if not OpenClipboard( 0 ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ EmptyClipboard;
+ if S <> '' then
+ begin
+ gbl := GlobalAlloc( GMEM_DDESHARE, Length( S ) + 1 );
+ if gbl <> 0 then
+ begin
+ str := GlobalLock( gbl );
+ Move( S[ 1 ], str^, Length( S ) + 1 );
+ GlobalUnlock( gbl );
+ Result := SetClipboardData( CF_TEXT, gbl ) <> 0;
+ end;
+ end
+ else
+ Result := True;
+ CloseClipboard;
+end;
+
+{$IFNDEF _D2}
+function WText2Clipboard( const WS: KOLWideString ): Boolean;
+var gbl: THandle;
+ str: PAnsiChar;
+begin
+ Result := False;
+ if not OpenClipboard( 0 ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ EmptyClipboard;
+ if WS <> '' then
+ begin
+ gbl := GlobalAlloc( GMEM_DDESHARE, (Length( WS ) + 1) * 2 );
+ if gbl <> 0 then
+ begin
+ str := GlobalLock( gbl );
+ Move( WS[ 1 ], str^, (Length( WS ) + 1) * 2 );
+ GlobalUnlock( gbl );
+ Result := SetClipboardData( CF_UNICODETEXT, gbl ) <> 0;
+ end;
+ end
+ else
+ Result := True;
+ CloseClipboard;
+end;
+{$ENDIF}
+
+function TControl.Size(W, H: Integer): PControl;
+var C, P: PControl;
+ dW, dH: Integer;
+begin
+ C := @Self;
+ while True do
+ begin
+ dW := 0; dH := 0;
+ P := C.FParent;
+ if C.ToBeVisible then
+ begin
+ if C.fAlign in [caLeft, caRight, caClient] then
+ begin
+ if H > 0 then
+ begin
+ dH := H - C.Height; H := 0;
+ end;
+ end;
+ if C.fAlign in [caTop, caBottom, caClient] then
+ begin
+ if W > 0 then
+ begin
+ dW := W - C.Width; W := 0;
+ end;
+ end;
+ end;
+ if (W > 0) or (H > 0) then
+ begin
+ C.SetSize( W, H );
+ if (P <> nil) // {Ralf Junker}
+ and not P.IsApplet then
+ C.ResizeParent;
+ end;
+ if (dW = 0) and (dH = 0) then break;
+ C := P; //C.FParent;
+ if C = nil then break;
+ //if not C.fIsControl then break;
+ if C.IsApplet then break;
+ W := C.Width + dW;
+ H := C.Height + dH;
+ end;
+ Result := @Self;
+end;
+{$ENDIF WIN_GDI}
+
+{$IFDEF GDI}
+procedure AutoSzProc( Self_: PObj );
+var DeltaX, DeltaY: Integer;
+ SZ: TSize; PT: TPoint;
+ Txt: KOLString;
+ Chg: Boolean;
+ R: TRect;
+ Flags: DWORD;
+{+ecm}
+ OldFont: HFONT;
+ CtlHavingFont: PControl;
+{/+ecm}
+begin
+ Txt := PControl( Self_ ).fCaption;
+ SZ.cx := 0;
+ SZ.cy := 0;
+ if Txt <> '' then
+ begin
+ if ( PControl( Self_ ).fFont <> nil ) then
+ if PControl( Self_ ).fFont.fData.Font.Italic then
+ Txt := Txt + ' ';
+ PControl( Self_ ).GetWindowHandle; // this line must be here.
+ //-- otherwise, when handle is not yet allocated,
+ // it is requested in TCanvas.GetHandle, and in result
+ // of unpredictable recursion some memory can be currupted.
+ PControl( Self_ ).Canvas.TextArea( Txt, SZ, PT );
+ if {$IFDEF USE_FLAGS} (G1_WordWrap in PControl(Self_).fFlagsG1)
+ {$ELSE} PControl( Self_ ).fWordWrap {$ENDIF}
+ and (PControl( Self_ ).fAlign <> caClient) then
+ begin
+ R := PControl( Self_ ).ClientRect;
+ Flags := DT_CALCRECT or DT_EXPANDTABS or DT_WORDBREAK;
+ CASE PControl( Self_ ).fTextAlign OF
+ taCenter: Flags := Flags or DT_CENTER;
+ taRight : Flags := Flags or DT_RIGHT;
+ END;
+ {-ecm}
+// CASE Self_.fVerticalAlign OF
+// vaCenter: Flags := Flags or DT_VCENTER;
+// vaBottom: Flags := Flags or DT_BOTTOM;
+// END;
+ {/-ecm}
+ {+ecm}
+ CtlHavingFont := PControl( Self_ );
+ while (CtlHavingFont <> nil)
+ and ( CtlHavingFont.FFont = nil ) do
+ CtlHavingFont := CtlHavingFont.Parent;
+ OldFont := 0;
+ if ( CtlHavingFont ) <> nil then
+ OldFont := SelectObject( PControl( Self_ ).Canvas.Handle, CtlHavingFont.Font.Handle );
+ {/+ecm}
+ // DrawText return the height of the text !
+ SZ.cy := DrawText( PControl( Self_ ).fCanvas.Handle, PKOLChar( Txt ), Length( Txt ), R, Flags );
+ {+ecm}
+ if ( CtlHavingFont <> nil ) then
+ SelectObject(PControl( Self_ ).Canvas.fHandle,OldFont);
+ {/+ecm}
+ SZ.cx := R.Right - R.Left;
+ //SZ.cy := R.Bottom - R.Top;
+ end;
+ end;
+ Chg := FALSE;
+ if PControl( Self_ ).FAlign in [ caNone, caLeft, caRight ] then
+ begin
+ DeltaX := PControl( Self_ ).aAutoSzX;
+ if PControl( Self_ ).Width <> SZ.cx + DeltaX then
+ begin
+ PControl( Self_ ).Width := SZ.cx + DeltaX;
+ Chg := TRUE;
+ end;
+ if PControl( Self_ ).fMinWidth > PControl( Self_ ).Width then
+ begin
+ PControl( Self_ ).Width := PControl( Self_ ).fMinWidth;
+ Chg := TRUE;
+ end;
+ end;
+ if PControl( Self_ ).FAlign in [ caNone, caTop, caBottom ] then
+ begin
+ DeltaY := PControl( Self_ ).aAutoSzY;
+ if PControl( Self_ ).Height <> SZ.cy + DeltaY then
+ begin
+ PControl( Self_ ).Height := SZ.cy + DeltaY;
+ Chg := TRUE;
+ end;
+ if PControl( Self_ ).FMinHeight > PControl( Self_ ).Height then
+ begin
+ PControl( Self_ ).Height := PControl( Self_ ).FMinHeight;
+ Chg := TRUE;
+ end;
+ end;
+ if Chg then
+ begin
+ {$IFDEF OLD_ALIGN}
+ if PControl( Self_ ).fParent <> nil then
+ Global_Align( PControl( Self_ ).fParent );
+ {$ENDIF}
+ Global_Align( Self_ );
+ end;
+end;
+{$ENDIF GDI}
+{$IFDEF _X_}
+{$IFDEF GTK}
+PROCEDURE AutoSzProc( Self_: PObj );
+VAR SZ: TSize;
+ //Txt: KOLString;
+ Chg: Boolean;
+ req_captn, req_evbox: TGtkRequisition;
+BEGIN
+ //Txt := PControl( Self_ ).fCaption;
+ SZ.cx := 0;
+ SZ.cy := 0;
+ //if Txt <> '' then
+ BEGIN
+ gtk_widget_size_request( PControl( Self_ ).fCaptionHandle, @ req_captn );
+ IF (PControl( Self_ ).fDeltaX = 0) AND
+ (PControl( Self_ ).fDeltaY = 0) THEN
+ BEGIN
+ gtk_widget_size_request( PControl( Self_ ).fEventboxHandle, @ req_evbox );
+ PControl( Self_ ).fDeltaX := Max( 0, req_evbox.width - req_captn.width );
+ PControl( Self_ ).fDeltaY := Max( 0, req_evbox.height - req_captn.height );
+ END;
+ Sz.cx := req_captn.width + PControl( Self_ ).fDeltaX;
+ Sz.cy := req_captn.height + PControl( Self_ ).fDeltaY;
+ //gtk_widget_get_size_request( PControl( Self_ ).fHandle, @ Sz.cx, @ Sz.cy );
+ END;
+ Chg := FALSE;
+ IF PControl( Self_ ).FAlign in [ caNone, caLeft, caRight ] THEN
+ BEGIN
+ //DeltaX := PControl( Self_ ).fCommandActions.aAutoSzX;
+ if PControl( Self_ ).Width <> SZ.cx {+ DeltaX} then
+ BEGIN
+ PControl( Self_ ).Width := SZ.cx {+ DeltaX};
+ Chg := TRUE;
+ END;
+ IF PControl( Self_ ).fMinWidth > PControl( Self_ ).Width THEN
+ BEGIN
+ PControl( Self_ ).Width := PControl( Self_ ).fMinWidth;
+ Chg := TRUE;
+ END;
+ END;
+ IF PControl( Self_ ).FAlign in [ caNone, caTop, caBottom ] THEN
+ begin
+ //DeltaY := PControl( Self_ ).fCommandActions.aAutoSzY;
+ IF PControl( Self_ ).Height <> SZ.cy {+ DeltaY} THEN
+ BEGIN
+ PControl( Self_ ).Height := SZ.cy {+ DeltaY};
+ Chg := TRUE;
+ END;
+ IF PControl( Self_ ).FMinHeight > PControl( Self_ ).Height THEN
+ BEGIN
+ PControl( Self_ ).Height := PControl( Self_ ).FMinHeight;
+ Chg := TRUE;
+ END;
+ END;
+ IF Chg THEN
+ BEGIN
+ {$IFDEF OLD_ALIGN}
+ if PControl( Self_ ).fParent <> nil then
+ Global_Align( PControl( Self_ ).fParent );
+ {$ENDIF}
+ Global_Align( Self_ );
+ END;
+END;
+{$ENDIF GTK}
+{$ENDIF _X_}
+
+function TControl.AutoSize(AutoSzOn: Boolean): PControl;
+begin
+ if AutoSzOn then
+ begin
+ PP.fAutoSize := AutoSzProc;
+ DoAutoSize;
+ end
+ else
+ PP.fAutoSize := DummyObjProc;
+ Result := @Self;
+end;
+
+{$IFDEF WIN_GDI}
+function TControl.IsAutoSize: Boolean;
+begin
+ Result := Assigned( PP.fAutoSize );
+end;
+
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+function TControl.GetToBeVisible: Boolean;
+begin
+ Result := {$IFDEF USE_FLAGS} (F3_Visible in fStyle.f3_Style)
+ {$ELSE} fVisible {$ENDIF}
+ or {$IFDEF USE_FLAGS} ([G4_CreateHidden, G4_VisibleWOParent]
+ * fFlagsG4 <> [])
+ or (G3_IsForm in fFlagsG3)
+ {$ELSE} fCreateHidden or fVisibleWoParent or IsForm {$ENDIF};
+ 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;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+///////////////////////////////////////////////////////////////////////
+// W I N D O W S
+///////////////////////////////////////////////////////////////////////
+
+{ -- Set of window-related utility functions. -- }
+type
+ PGUIThreadInfo = ^TGUIThreadInfo;
+ tagGUITHREADINFO = packed record
+ cbSize: DWORD;
+ flags: DWORD;
+ hwndActive: HWND;
+ hwndFocus: HWND;
+ hwndCapture: HWND;
+ hwndMenuOwner: HWND;
+ hwndMoveSize: HWND;
+ hwndCaret: HWND;
+ rcCaret: TRect;
+ end;
+ TGUIThreadInfo = tagGUITHREADINFO;
+
+const
+ GUI_CARETBLINKING = $00000001;
+ GUI_INMOVESIZE = $00000002;
+ GUI_INMENUMODE = $00000004;
+ GUI_SYSTEMMENUMODE = $00000008;
+ GUI_POPUPMENUMODE = $00000010;
+
+{function GetGUIThreadInfo (idThread: DWORD; var pgui: TGUIThreadinfo): BOOL; stdcall;
+ external user32 name 'GetGUIThreadInfo';}
+
+type TGUIThreadInfo_Proc = function( ThreadID: THandle; var GTI: TGUIThreadInfo )
+ : Boolean; stdcall;
+
+var Proc_GetGUIThreadInfo: TGuiThreadInfo_Proc;
+
+function GetWindowChild( Wnd: HWnd; Kind: TWindowChildKind ): HWnd;
+var GTI: TGuiThreadInfo;
+ ThreadID: THandle;
+ Module: THandle;
+begin
+ if not Assigned( Proc_GetGUIThreadInfo ) then
+ begin
+ Module := GetModuleHandle( 'User32' );
+ Proc_GetGUIThreadInfo := GetProcAddress( Module, 'GetGUIThreadInfoA' );
+ if not Assigned( Proc_GetGUIThreadInfo ) then
+ Proc_GetGUIThreadInfo := Pointer( -1 );
+ end;
+ Result := Wnd;
+ if Integer( @Proc_GetGUIThreadInfo ) = -1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>}
+ Result := 0;
+ if Wnd = 0 then
+ ThreadID := GetCurrentThreadID
+ else
+ ThreadID := GetWindowThreadProcessID( Wnd, nil );
+ if ThreadID = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ GTI.cbSize := Sizeof( GTI );
+ if Proc_GetGUIThreadInfo( ThreadId, GTI ) then
+ begin
+ case Kind of
+ wcActive: Result := GTI.hwndActive;
+ wcFocus: Result := GTI.hwndFocus;
+ wcCapture: Result := GTI.hwndCapture;
+ wcMenuOwner: Result := GTI.hwndMenuOwner;
+ wcMoveSize: Result := GTI.hwndMoveSize;
+ wcCaret: Result := GTI.hwndCaret;
+ end;
+ end;
+end;
+
+function GetFocusedChild( Wnd: HWnd ): HWnd;
+var Tr1, Tr2: THandle;
+begin
+ Result := 0;
+ Tr1 := GetCurrentThreadId;
+ Tr2 := GetWindowThreadProcessId( Wnd, nil );
+ if Tr1 = Tr2 then
+ Result := GetFocus
+ else
+ if AttachThreadInput( Tr2, Tr1, True ) then
+ begin
+ Result := GetFocus;
+ AttachThreadInput( Tr2, Tr1, False );
+ end;
+end;
+
+function WaitFocusedWndChild( Wnd: HWnd ): HWnd;
+var T1, T2: Integer;
+ W: HWnd;
+begin
+ Sleep( 50 );
+ T1 := GetTickCount;
+ while True do
+ begin
+ W := GetTopWindow( Wnd );
+ if W = 0 then W := Wnd;
+ W := GetFocusedChild( W );
+ if W <> 0 then
+ begin
+ Wnd := W;
+ break;
+ end;
+ T2 := GetTickCount;
+ if Abs( T1 - T2 ) > 100 then break;
+ end;
+ Result := Wnd;
+end;
+
+function Stroke2Window( Wnd: HWnd; const S: AnsiString ): Boolean;
+var P: PAnsiChar;
+begin
+ Result := False;
+ Wnd := WaitFocusedWndChild( Wnd );
+ if Wnd = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ P := PAnsiChar( S );
+ while P^ <> #0 do
+ begin
+ PostMessage( Wnd, WM_CHAR, Integer( P^ ), 1 );
+ Inc( P );
+ end;
+ Result := True;
+end;
+
+function Stroke2WindowEx( Wnd: HWnd; const S: AnsiString; Wait: Boolean ): Boolean;
+var P: PAnsiChar;
+ EndChar: AnsiChar;
+ MsgDn, MsgUp, SCA: Integer;
+
+ function Compare( Pattern: PAnsiChar ): Boolean;
+ var Pos: PAnsiChar;
+ C1, C2: AnsiChar;
+ begin
+ Pos := P;
+ while Pattern^ <> #0 do
+ begin
+ C1 := Pattern^;
+ C2 := Pos^;
+ if (C1 >= 'a') and (C1 <= 'z') then
+ C1 := AnsiChar( Ord( C1 ) - $20 );
+ if (C2 >= 'a') and (C2 <= 'z') then
+ C2 := AnsiChar( Ord( C2 ) - $20 );
+ if C1 <> C2 then
+ begin
+ Result := False; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Inc( Pos );
+ Inc( Pattern );
+ end;
+ while Pos^ = ' ' do Inc( Pos );
+ P := Pos;
+ Result := True;
+ end;
+
+ procedure Send( Msg, KeyCode: Integer );
+ var lParam: Integer;
+ begin
+ Wnd := WaitFocusedWndChild( Wnd );
+ if Wnd = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ lParam := 1;
+ if longBool( SCA and 4 ) then
+ lParam := $20000001;
+ if Msg = MsgUp then
+ lParam := lParam or Integer($D0000000);
+ PostMessage( Wnd, Msg, KeyCode, lParam );
+ Applet.ProcessMessages;
+ if Wait then
+ Sleep( 50 );
+ end;
+
+ function CompareSend( Pattern: PAnsiChar; Value2Send: Integer ): Boolean;
+ begin
+ if Compare( Pattern ) then
+ begin
+ Send( MsgDn, Value2Send );
+ Send( MsgUp, Value2Send );
+ Result := True;
+ end
+ else
+ Result := False;
+ end;
+
+ function ParseKeys( EndChar: AnsiChar ): PAnsiChar;
+ var FN: Integer;
+ begin
+ SCA := 0;
+ while not (P^ in [ #0, EndChar ]) do
+ begin
+ if Compare( 'Shift' ) then SCA := SCA or 1
+ else
+ if Compare( 'Ctrl' ) then SCA := SCA or 2
+ else
+ if Compare( 'Alt' ) then SCA := SCA or 4
+ else
+ break;
+ end;
+ MsgDn := WM_KEYDOWN;
+ MsgUp := WM_KEYUP;
+ if LongBool( SCA and 4 ) then
+ begin
+ MsgDn := WM_SYSKEYDOWN;
+ MsgUp := WM_SYSKEYUP;
+ keybd_event( VK_MENU, 0, 0, 0 );
+ Send( WM_SYSKEYDOWN, VK_MENU );
+ end;
+ if LongBool( SCA and 2 ) then
+ begin
+ keybd_event( VK_CONTROL, 0, 0, 0 );
+ Send( WM_KEYDOWN, VK_CONTROL );
+ end;
+ if Longbool( SCA and 1 ) then
+ begin
+ keybd_event( VK_SHIFT, 0, 0, 0 );
+ Send( WM_KEYDOWN, VK_SHIFT );
+ end;
+ while not (P^ in [ #0, EndChar ]) do
+ begin
+ if (P^ = 'F') and (P[ 1 ] in [ '1'..'9' ]) then
+ begin
+ Inc( P );
+ FN := Ord( P^ ) - Ord( '0' );
+ if (FN = 1) and (P[ 1 ] in [ '0'..'2' ]) then
+ begin
+ Inc( P );
+ FN := 10 + Ord( P^ ) - Ord( '0' );
+ end;
+ repeat Inc( P ) until P^ <> ' ';
+ FN := FN + $6F;
+ Send( MsgDn, FN );
+ Send( MsgUp, FN );
+ end
+ else
+ if Compare( 'Numpad' ) then
+ begin
+ if P^ in [ '0'..'9' ] then
+ begin
+ FN := Ord( P^ ) - Ord( '0' ) + $60;
+ repeat Inc( P^ ) until P^ <> ' ';
+ Send( MsgDn, FN );
+ Send( MsgUp, FN );
+ end;
+ end
+ else
+ if not (CompareSend( 'Add', $6B ) or
+ CompareSend( 'Gray+', $6B ) or
+ CompareSend( 'Apps', $5D ) or
+ CompareSend( 'BackSpace', $08 ) or
+ CompareSend( 'BkSp', $08 ) or
+ CompareSend( 'BS', $08 ) or
+ CompareSend( 'Break', $13 ) or
+ CompareSend( 'CapsLock', $14 ) or
+ CompareSend( 'Clear', $0C ) or
+ CompareSend( 'Decimal', $6E ) or
+ CompareSend( 'Del', $2E ) or
+ CompareSend( 'Delete', $2E ) or
+ CompareSend( 'Divide', $6F ) or
+ CompareSend( 'Gray/', $6F ) or
+ CompareSend( 'Down', $28 ) or
+ CompareSend( 'End', $23 ) or
+ CompareSend( 'Enter', $0D ) or
+ CompareSend( 'Return', $0D ) or
+ CompareSend( 'CR', $0D ) or
+ CompareSend( 'Esc', $1B ) or
+ CompareSend( 'Escape', $1B ) or
+ CompareSend( 'Help', $2F ) or
+ CompareSend( 'Home', $24 ) or
+ CompareSend( 'Ins', $2D ) or
+ CompareSend( 'Insert', $2D ) or
+ CompareSend( 'Left', $25 ) or
+ CompareSend( 'LWin', $5B ) or
+ CompareSend( 'Multiply', $6A ) or
+ CompareSend( 'Gray*', $6A ) or
+ CompareSend( 'NumLock', $90 ) or
+ CompareSend( 'PgDn', $22 ) or
+ CompareSend( 'PgUp', $21 ) or
+ CompareSend( 'PrintScrn', $2C ) or
+ CompareSend( 'Right', $27 ) or
+ CompareSend( 'RWin', $5C ) or
+ CompareSend( 'Separator', $6C ) or
+ CompareSend( 'ScrollLock', $91 ) or
+ CompareSend( 'Subtract', $6D ) or
+ CompareSend( 'Tab', $09 ) or
+ CompareSend( 'Gray-', $6D ) or
+ CompareSend( 'Up', $26 )) then break;
+ end;
+ while not (P^ in [ #0, EndChar ]) do
+ begin
+ if P^ in [ 'A'..'Z', '0'..'9' ] then
+ begin
+ Send( MsgDn, Integer( P^ ) );
+ Send( MsgUp, Integer( P^ ) );
+ end
+ else
+ if P^ in [ #1..#255 ] then
+ Stroke2Window( Wnd, AnsiString('') + P^ );
+ repeat Inc( P ) until (P^ <> AnsiString(' '));
+ end;
+ if P^ = EndChar then
+ Inc( P );
+ if Longbool( SCA and 1 ) then
+ begin
+ Send( WM_KEYUP, VK_SHIFT );
+ keybd_event( VK_SHIFT, 0, KEYEVENTF_KEYUP, 0 );
+ end;
+ if LongBool( SCA and 2 ) then
+ begin
+ Send( WM_KEYUP, VK_CONTROL );
+ keybd_event( VK_CONTROL, 0, KEYEVENTF_KEYUP, 0 );
+ end;
+ if LongBool( SCA and 4 ) then
+ begin
+ Send( WM_SYSKEYUP, VK_MENU );
+ keybd_event( VK_MENU, 0, KEYEVENTF_KEYUP, 0 );
+ end;
+ Result := P;
+ end;
+
+begin
+ Result := False;
+ Wnd := GetTopWindow( Wnd );
+ Wnd := GetFocusedChild( Wnd );
+ if Wnd = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ P := PAnsiChar( S );
+ while P^ <> #0 do
+ begin
+ if not (P^ in [ '[', '{' ]) then
+ begin
+ Stroke2Window( Wnd, AnsiString('') + P^ ); // TODO: adjust compile options?
+ Inc( P );
+ end
+ else
+ begin
+ if P^ = '[' then
+ EndChar := ']'
+ else
+ EndChar := '}';
+ Inc( P );
+ P := ParseKeys( EndChar );
+ end;
+ end;
+ Result := True;
+end;
+
+type
+ PHWnd = ^HWnd;
+
+ TFindWndRec = packed Record
+ ThreadID : DWord;
+ WndFound : HWnd;
+ end;
+ PFindWndRec = ^TFindWndRec;
+
+function EnumWindowsProc( Wnd : HWnd; Find : PFindWndRec ) : Boolean;
+stdcall;
+var Id : DWord;
+begin
+ Result := True;
+ Id := GetWindowThreadProcessId( Wnd, @Id );
+ if Id = Find.ThreadID then
+ begin
+ Find.WndFound := Wnd;
+ Result := False;
+ end;
+end;
+
+function FindWindowByThreadID( ThreadID : DWORD ) : HWnd;
+var Find : TFindWndRec;
+begin
+ Find.ThreadID := ThreadID;
+ Find.WndFound := 0;
+ EnumWindows( @EnumWindowsProc, Integer( @Find ) );
+ Result := Find.WndFound;
+end;
+
+function DesktopPixelFormat: TPixelFormat;
+var DC: HDC;
+ Nbits_per_pixel, Nplanes: Integer;
+begin
+ DC := GetDC( 0 );
+ Nbits_per_pixel := GetDeviceCaps( DC, BITSPIXEL );
+ Nplanes := GetDeviceCaps( DC, PLANES );
+ ReleaseDC( 0, DC );
+ CASE Nplanes * Nbits_per_pixel OF
+ 1: Result := pf1bit;
+ 4: Result := pf4bit;
+ 8: Result := pf8bit;
+ 16: Result := pf16bit;
+ 24, 32: Result := pf32bit;
+ else Result := pfDevice;
+ END;
+end;
+
+function GetDesktopRect : TRect;
+var W1, W2 : HWnd;
+begin
+ if WinVer >= wvVista then
+ begin
+ Result := GetWorkArea; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := MakeRect( 0, 0, GetSystemMetrics( SM_CXSCREEN ), GetSystemMetrics( SM_CYSCREEN ) );
+ W2 := findwindow('Progman',nil);
+ W1 := findwindowex(W2,0,'SHELLDLL_DefView',nil);
+ if W1 = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ GetWindowRect( W1, Result );
+end;
+
+function GetWorkArea: TRect;
+begin
+ SystemParametersInfo( SPI_GETWORKAREA, 0, @ Result, 0 );
+end;
+
+function ExecuteWait( const AppPath, CmdLine, DfltDirectory: KOLString;
+ Show: DWORD; TimeOut: DWORD; ProcID: PDWORD ): Boolean;
+var Flags: DWORD;
+ Startup: TStartupInfo;
+ ProcInf: TProcessInformation;
+ DfltDir: PKOLChar;
+ App: KOLString;
+begin
+ Result := FALSE;
+ Flags := CREATE_NEW_CONSOLE;
+ if Show = SW_HIDE then
+ Flags := Flags or {$IFDEF F_P}$08000000{$ELSE}CREATE_NO_WINDOW{$ENDIF};
+ ZeroMemory( @Startup, SizeOf( Startup ) );
+ Startup.cb := Sizeof( Startup );
+ Startup.wShowWindow := Show;
+ Startup.dwFlags := STARTF_USESHOWWINDOW;
+ if ProcID <> nil then
+ ProcID^ := 0;
+ DfltDir := nil;
+ if DfltDirectory <> '' then
+ DfltDir := PKOLChar( DfltDirectory );
+ App := AppPath;
+ //if (pos( KOLString(' '), App ) > 0) and (pos( KOLString('"'), App ) <= 0) then
+ if (App <> '') and (App[1] <> '"') and (pos( KOLString(' '), App ) > 0) then
+ App := '"' + App + '"';
+ if (App <> '') and (CmdLine <> '') then
+ App := App + ' ';
+ if CreateProcess( nil, PKOLChar( App + CmdLine ), nil,
+ nil, FALSE, Flags, nil, DfltDir, Startup,
+ ProcInf ) then
+ begin
+ if WaitForSingleObject( ProcInf.hProcess, TimeOut ) = WAIT_OBJECT_0 then
+ begin
+ CloseHandle( ProcInf.hProcess );
+ Result := TRUE;
+ end
+ else
+ begin
+ if ProcID <> nil then
+ ProcID^ := ProcInf.hProcess;
+ end;
+ CloseHandle( ProcInf.hThread );
+ end;
+end;
+
+function ExecuteIORedirect( const AppPath, CmdLine, DfltDirectory: KOLString;
+ Show: DWORD; ProcID: PDWORD; InPipe, OutPipeWr, OutPipeRd: PHandle ): Boolean;
+var Flags: DWORD;
+ Startup: TStartupInfo;
+ ProcInf: TProcessInformation;
+ DfltDir: PKOLChar;
+ SecurityAttributes: TSecurityAttributes;
+ SaveStdOut, SaveStdIn: THandle;
+ ChildStdOutRd, ChildStdOutWr: THandle;
+ ChildStdInRd, ChildStdInWr: THandle;
+ ChildStdOutRdDup: THandle;
+ ChildStdInWrDup: THandle;
+
+ procedure Do_CloseHandle( var Handle: THandle );
+ begin
+ if Handle <> 0 then
+ begin
+ CloseHandle( Handle );
+ Handle := 0;
+ end;
+ end;
+
+ procedure Close_Handles;
+ begin
+ Do_CloseHandle( ChildStdOutRd );
+ Do_CloseHandle( ChildStdOutWr );
+ Do_CloseHandle( ChildStdInRd );
+ Do_CloseHandle( ChildStdInWr );
+ end;
+
+ function RedirectInputOutput: Boolean;
+ begin
+ Result := FALSE;
+ if (OutPipeRd <> nil) or (OutPipeWr <> nil) then
+ begin
+ // redirect output
+ SaveStdOut := GetStdHandle(STD_OUTPUT_HANDLE);
+ if not CreatePipe( ChildStdOutRd, ChildStdOutWr, @ SecurityAttributes, 0 ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if not SetStdHandle( STD_OUTPUT_HANDLE, ChildStdOutWr ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if not DuplicateHandle( GetCurrentProcess, ChildStdOutRd,
+ GetCurrentProcess, @ ChildStdOutRdDup, 0, FALSE,
+ 2 {DUPLICATE_SAME_ACCESS} ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Do_CloseHandle( ChildStdOutRd );
+ if OutPipeRd <> nil then
+ OutPipeRd^ := ChildStdOutRdDup;
+ if OutPipeWr <> nil then
+ OutPipeWr^ := ChildStdOutWr;
+ end;
+ if InPipe <> nil then
+ begin
+ // redirect input
+ SaveStdIn := GetStdHandle(STD_INPUT_HANDLE);
+ if not CreatePipe( ChildStdInRd, ChildStdInWr, @ SecurityAttributes, 0 ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if not SetStdHandle( STD_INPUT_HANDLE, ChildStdInRd ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if not DuplicateHandle( GetCurrentProcess, ChildStdInWr,
+ GetCurrentProcess, @ ChildStdInWrDup, 0, FALSE,
+ 2 {DUPLICATE_SAME_ACCESS} ) then
+ Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Do_CloseHandle( ChildStdInWr );
+ if InPipe <> nil then
+ InPipe^ := ChildStdInWrDup;
+ Do_CloseHandle( ChildStdInRd );
+ end;
+ Result := TRUE;
+ end;
+
+ procedure Restore_Saved_StdInOut;
+ begin
+ SetStdHandle( STD_OUTPUT_HANDLE, SaveStdOut );
+ SetStdHandle( STD_INPUT_HANDLE, SaveStdIn );
+ end;
+
+var Cmd: KOLString;
+begin
+ Result := FALSE;
+ Flags := 0;
+ if Show = SW_HIDE then
+ Flags := Flags or {$IFDEF F_P}$08000000{$ELSE}CREATE_NO_WINDOW{$ENDIF};
+ ZeroMemory( @Startup, SizeOf( Startup ) );
+ Startup.cb := Sizeof( Startup );
+ if ProcID <> nil then
+ ProcID^ := 0;
+ DfltDir := nil;
+ SecurityAttributes.nLength := Sizeof( SecurityAttributes );
+ SecurityAttributes.lpSecurityDescriptor := nil;
+ SecurityAttributes.bInheritHandle := TRUE;
+ SaveStdOut := 0;
+ SaveStdIn := 0;
+ ChildStdOutRd := 0;
+ ChildStdOutWr := 0;
+ ChildStdInRd := 0;
+ ChildStdInWr := 0;
+ if not RedirectInputOutput then
+ begin
+ Close_Handles; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if DfltDirectory <> '' then
+ DfltDir := PKOLChar( DfltDirectory );
+ Cmd := '"' + AppPath + '" ' + CmdLine;
+ if CreateProcess( nil, PKOLChar( Cmd ), nil, nil, TRUE, Flags, nil,
+ DfltDir, Startup, ProcInf ) then
+ begin
+ if ProcID <> nil then
+ ProcID^ := ProcInf.hProcess
+ else
+ CloseHandle( ProcInf.hProcess );
+ CloseHandle( ProcInf.hThread );
+ Restore_Saved_StdInOut;
+ Result := TRUE;
+ end else
+ begin
+ Restore_Saved_StdInOut;
+ Close_Handles;
+ end;
+end;
+
+function ExecuteConsoleAppIORedirect( const AppPath, CmdLine, DfltDirectory: KOLString;
+ Show: DWORD; const InStr: KOLString; var OutStr: KOLString; WaitTimeout: DWORD ): Boolean;
+var PipeIn, PipeOutRd, PipeOutWr: THandle;
+ ProcID: DWORD;
+ BytesCount: DWORD;
+ Buffer: Array[ 0..4096 ] of KOLChar; // KOL_ANSI
+ BufStr: KOLString;
+ PPipeIn: PHandle;
+begin
+ Result := FALSE;
+ PPipeIn := @ PipeIn;
+ if InStr = '' then
+ PPipeIn := nil;
+ PipeOutRd := 0;
+ PipeOutWr := 0;
+ if not ExecuteIORedirect( AppPath, CmdLine, DfltDirectory, Show, @ ProcID,
+ PPipeIn, @ PipeOutWr, @ PipeOutRd ) then Exit; {>>>>>>>>>>}
+ if PPipeIn <> nil then
+ begin
+ if InStr <> '' then
+ WriteFile( PipeIn, InStr[ 1 ], Length( InStr ), BytesCount, nil );
+ CloseHandle( PipeIn );
+ end;
+ OutStr := '';
+ if WaitForSingleObject( ProcID, WaitTimeOut ) = WAIT_OBJECT_0 then
+ begin
+ CloseHandle( ProcID );
+ CloseHandle( PipeOutWr );
+ while ReadFile( PipeOutRd, Buffer, Sizeof( Buffer ), BytesCount, nil ) do
+ begin
+ SetLength( BufStr, BytesCount );
+ Move( Buffer[ 0 ], BufStr[ 1 ], BytesCount );
+ OutStr := OutStr + BufStr;
+ end;
+ end
+ else
+ CloseHandle( PipeOutWr );
+ CloseHandle( PipeOutRd );
+ Result := TRUE;
+end;
+
+{$IFDEF _D2}
+function OpenProcessToken(ProcessHandle: THandle; DesiredAccess: DWORD;
+ var TokenHandle: THandle): BOOL; stdcall;
+ external advapi32 name 'OpenProcessToken';
+{$ENDIF}
+
+function WindowsShutdown( const Machine : KOLString; Force, Reboot : Boolean ) : Boolean;
+var
+ hToken: THandle;
+ tkp, tkp_prev: TTokenPrivileges;
+ dwRetLen :DWORD;
+ Flags: Integer;
+begin
+ Result := False;
+ if Integer( GetVersion ) < 0 then // Windows95/98/Me
+ begin
+ if Machine <> '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Flags := EWX_SHUTDOWN;
+ if Reboot then
+ Flags := Flags or EWX_REBOOT;
+ if Force then
+ Flags := Flags or EWX_FORCE;
+ Result := ExitWindowsEx( Flags, 0 ); Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ OpenProcessToken(GetCurrentProcess(),
+ TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
+ hToken);
+ if not LookupPrivilegeValue(PKOLChar(Machine), 'SeShutdownPrivilege',
+ tkp.Privileges[0].Luid) then Exit; {>>>>>>>>>>>>>}
+ tkp_prev:=tkp;
+ tkp.PrivilegeCount:=1;
+ tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
+ AdjustTokenPrivileges(hToken, FALSE, tkp, sizeof(tkp), tkp_prev,
+dwRetLen);
+ if not LookupPrivilegeValue(PKOLChar(Machine),
+ 'SeRemoteShutdownPrivilege',
+ tkp.Privileges[0].Luid) then Exit; {>>>>>>>>>>>>}
+ tkp.PrivilegeCount:=1;
+ tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
+ AdjustTokenPrivileges(hToken, FALSE, tkp, sizeof(tkp), tkp_prev, dwRetLen);
+ Result := InitiateSystemShutdown(PKOLChar(Machine),nil, 0, Force, Reboot);
+end;
+
+function WindowsLogoff( Force : Boolean ) : Boolean;
+var Flags: Integer;
+begin
+ Flags := 0;
+ if Force then
+ Flags := EWX_FORCE;
+ Result := ExitWindowsEx( Flags, 0 );
+end;
+
+var SaveWinVer: Byte = $FF;
+
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // asm version by MTsv DN (v 2.90)
+function WinVer : TWindowsVersion;
+var MajorVersion, MinorVersion: Byte;
+ dwVersion: Integer;
+begin
+ if SaveWinVer <> $FF then Result := TWindowsVersion( SaveWinVer )
+ else
+ begin
+ dwVersion := GetVersion;
+ MajorVersion := LoByte( dwVersion );
+ MinorVersion := HiByte( LoWord( dwVersion ) );
+ if dwVersion >= 0 then
+ begin
+ Result := wvNT;
+ if (MajorVersion >= 6) then begin
+ if (MinorVersion >= 1) then
+ Result := wvSeven
+ else
+ Result := wvVista;
+ end else begin
+ if MajorVersion >= 5 then
+ if MinorVersion >= 1 then
+ begin
+ Result := wvXP;
+ if MinorVersion >= 2 then
+ Result := wvServer2003;
+ end
+ else Result := wvY2K;
+ end;
+ end
+ else
+ begin
+ Result := wv95;
+ if (MajorVersion > 4) or
+ (MajorVersion = 4) and (MinorVersion >= 10) then
+ begin
+ Result := wv98;
+ if (MajorVersion = 4) and (MinorVersion >= $5A) then
+ Result := wvME;
+ end
+ else
+ if MajorVersion <= 3 then
+ Result := wv31;
+ end;
+ SaveWinVer := Ord( Result );
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function IsWinVer( Ver : TWindowsVersions ) : Boolean;
+{* Returns True if Windows version is in given range of values. }
+begin
+ Result := WinVer in Ver;
+end;
+
+procedure TControl.SetAlphaBlend(const Value: Byte);
+const
+ LWA_COLORKEY=$00000001;
+ LWA_ALPHA=$00000002;
+ ULW_COLORKEY=$00000001;
+ ULW_ALPHA=$00000002;
+ ULW_OPAQUE=$00000004;
+ WS_EX_LAYERED=$00080000;
+type
+ TSetLayeredWindowAttributes=
+ function( hwnd: Integer; crKey: TColor; bAlpha: Byte; dwFlags: DWORD )
+ : Boolean; stdcall;
+var
+ SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
+ User32: THandle;
+ dw: DWORD;
+begin
+ if Value = fAlphaBlend then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ fAlphaBlend := Value;
+ User32 := GetModuleHandle( 'User32' );
+ SetLayeredWindowAttributes := GetProcAddress( User32,
+ 'SetLayeredWindowAttributes' );
+ if Assigned( SetLayeredWindowAttributes ) then
+ begin
+ dw := GetWindowLong( GetWindowHandle, GWL_EXSTYLE );
+ if Value < 255 then
+ begin
+ SetWindowLong( fHandle, GWL_EXSTYLE, dw or WS_EX_LAYERED );
+ SetLayeredWindowAttributes( fHandle, 0, Value {and $FF}, LWA_ALPHA);
+ end else
+ SetWindowLong( fHandle, GWL_EXSTYLE, dw and not WS_EX_LAYERED );
+ end;
+end;
+
+{$ENDIF WIN_GDI}
+function TControl.SetPosition( X, Y: Integer ): PControl;
+begin
+ Left := X;
+ Top := Y;
+ Result := @Self;
+end;
+{$IFDEF WIN_GDI}
+
+function NewColorDialog( FullOpen: TColorCustomOption ): PColorDialog;
+var I: Integer;
+begin
+ New( Result, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ Result.fObjKind := 'TColorDialog';
+ {$ENDIF}
+ Result.ColorCustomOption := FullOpen;
+ for I := 1 to 16 do
+ Result.CustomColors[ I ] := clWhite;
+end;
+
+{ TColorDialog }
+
+function TColorDialog.Execute: Boolean;
+var CD: TChooseColor;
+begin
+ CD.lStructSize := Sizeof( CD );
+ CD.hWndOwner := OwnerWindow;
+ //CD.hInstance := 0;
+ CD.rgbResult := Color2RGB( Color );
+ CD.lpCustColors := @CustomColors[ 1 ];
+ CD.Flags := CC_RGBINIT;
+ case ColorCustomOption of
+ ccoFullOpen: CD.Flags := CD.Flags or CC_FULLOPEN;
+ ccoPreventFullOpen: CD.Flags := CD.Flags or CC_PREVENTFULLOPEN;
+ end;
+ Result := ChooseColor( CD );
+ if Result then
+ Color := CD.rgbResult;
+end;
+
+procedure TControl.SetMaxProgress(const Index, Value: Integer);
+begin
+ // ignore index, and set Value via PBM_SETRANGE32: ()
+ Perform( PBM_SETRANGE32, 0, Value );
+end;
+
+procedure TControl.SetDroppedWidth(const Value: Integer);
+begin
+ DF.fDroppedWidth := Value;
+ Perform( CB_SETDROPPEDWIDTH, Value, 0 );
+end;
+
+function TControl.LVGetItemState(Idx: Integer): TListViewItemState;
+type
+ PListViewItemState = ^TListViewItemState;
+var I: Byte;
+begin
+ I := Perform( LVM_GETITEMSTATE, Idx,
+ LVIS_CUT or LVIS_DROPHILITED or LVIS_FOCUSED or LVIS_SELECTED );
+ Result := PListViewItemState( @ I )^;
+end;
+
+procedure TControl.LVSetItemState(Idx: Integer; const Value: TListViewItemState);
+var Data: TLVItem;
+begin
+ Data.stateMask := LVIS_FOCUSED or LVIS_SELECTED or LVIS_CUT or LVIS_DROPHILITED;
+ Data.state := PByte( @ Value )^;
+ Perform( LVM_SETITEMSTATE, Idx, Integer( @Data ) );
+end;
+
+procedure TControl.LVSelectAll;
+begin
+ LVSetItemState( -1, [ lvisSelect ] );
+end;
+
+function TControl.LVItemInsert(Idx: Integer; const aText: KOLString): Integer;
+var LVI: TLVItem;
+begin
+ LVI.mask := LVIF_TEXT or LVIF_DI_SETITEM;
+ LVI.iItem := Idx;
+ LVI.iSubItem := 0;
+ LVI.pszText := PKOL_Char( aText );
+ Result := Perform( LVM_INSERTITEM, 0, Integer( @LVI ) );
+end;
+
+function TControl.LVItemAdd(const aText: KOLString): Integer;
+begin
+ Result := LVItemInsert( Count, aText );
+end;
+
+function TControl.LVGetSttImgIdx(Idx: Integer): Integer;
+begin
+ Result := Perform( LVM_GETITEMSTATE, Idx, LVIS_STATEIMAGEMASK ) shr 12;
+end;
+
+procedure TControl.LVSetSttImgIdx(Idx: Integer; const Value: Integer);
+var LVI: TLVItem;
+begin
+ LVI.stateMask := LVIS_STATEIMAGEMASK;
+ LVI.state := Value shl 12;
+ Perform( LVM_SETITEMSTATE, Idx, Integer( @LVI ) );
+end;
+
+function TControl.LVGetOvlImgIdx(Idx: Integer): Integer;
+begin
+ Result := Perform( LVM_GETITEMSTATE, Idx, LVIS_OVERLAYMASK ) shr 8;
+end;
+
+procedure TControl.LVSetOvlImgIdx(Idx: Integer; const Value: Integer);
+var LVI: TLVItem;
+begin
+ LVI.stateMask := LVIS_OVERLAYMASK;
+ LVI.state := Value shl 8;
+ Perform( LVM_SETITEMSTATE, Idx, Integer( @LVI ) );
+end;
+
+function TControl.LVGetItemData(Idx: Integer): DWORD;
+var LVI: TLVItem;
+begin
+ LVI.mask := LVIF_PARAM;
+ LVI.iItem := Idx;
+ LVI.iSubItem := 0;
+ Perform( LVM_GETITEM, 0, Integer( @LVI ) );
+ Result := LVI.lParam;
+end;
+
+procedure TControl.LVSetItemData(Idx: Integer; const Value: DWORD);
+var LVI: TLVItem;
+begin
+ LVI.mask := LVIF_PARAM;
+ LVI.iItem := Idx;
+ LVI.iSubItem := 0;
+ LVI.lParam := Value;
+ Perform( LVM_SETITEM, 0, Integer( @LVI ) );
+end;
+
+function TControl.LVGetItemIndent(Idx: Integer): Integer;
+var LI: TLVItem;
+begin
+ LI.mask := LVIF_INDENT;
+ LI.iItem := Idx;
+ LI.iSubItem := 0;
+ Perform( LVM_GETITEM, 0, Integer( @LI ) );
+ Result := LI.iIndent;
+end;
+
+procedure TControl.LVSetItemIndent(Idx: Integer; const Value: Integer);
+var LI: TLVItem;
+begin
+ LI.mask := LVIF_INDENT or LVIF_DI_SETITEM;
+ LI.iItem := Idx;
+ LI.iSubItem := 0;
+ LI.iIndent := Value;
+ Perform( LVM_SETITEM, 0, Integer( @LI ) );
+end;
+
+type
+ TNMLISTVIEW = packed Record
+ hdr: TNMHDR;
+ iItem: Integer;
+ iSubItem: Integer;
+ uNewState: Integer;
+ uOldState: Integer;
+ uChanged: Integer;
+ ptAction: Integer;
+ lParam: DWORD;
+ end;
+ PNMLISTVIEW = ^TNMLISTVIEW;
+
+function WndProc_LVDeleteItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
+ : Boolean;
+var Hdr: PNMHDR;
+ LV: PNMListView;
+begin
+ Result := FALSE;
+ if Msg.message = WM_NOTIFY then
+ begin
+ Hdr := Pointer(Msg.lParam);
+ if Hdr.hwndFrom = Sender.Handle then
+ begin
+ LV := Pointer( Hdr );
+ if Hdr.code = LVN_DELETEITEM then
+ begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnDeleteLVItem ) then
+ {$ENDIF}
+ Sender.EV.fOnDeleteLVItem( Sender, LV.iItem );
+ Result := TRUE;
+ end
+ else
+ if Hdr.code = LVN_DELETEALLITEMS then
+ begin
+ if Assigned( Sender.DF.fOnDeleteAllLVItems ) then
+ begin
+ Sender.DF.fOnDeleteAllLVItems( Sender );
+ Rslt := 0;
+ if Assigned( Sender.EV.fOnDeleteLVItem ) then
+ Rslt := 1;
+ end;
+ Result := TRUE;
+ end;
+ end;
+ end;
+end;
+
+procedure TControl.SetOnDeleteAllLVItems(const Value: TOnEvent);
+begin
+ DF.fOnDeleteAllLVItems := Value;
+ AttachProc( @WndProc_LVDeleteItem );
+end;
+
+procedure TControl.SetOnDeleteLVItem(const Value: TOnDeleteLVItem);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnDeleteLVItem := Value;
+ AttachProc( @WndProc_LVDeleteItem );
+end;
+
+function WndProc_LVData( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
+ : Boolean;
+var Hdr: PNMHDR;
+ DI: PLVDispInfo;
+ Store: Boolean;
+ Txt: KOL_String;
+ LV: PControl;
+begin
+ Result := FALSE;
+ if Msg.message = WM_NOTIFY then
+ begin
+ Hdr := Pointer(Msg.lParam);
+ if Hdr.hwndFrom = Sender.Handle then
+ begin
+ if (Hdr.code = LVN_GETDISPINFO)
+ {$IFDEF UNICODE_CTRLS}
+ or (Hdr.code = LVN_GETDISPINFOW)
+ {$ENDIF UNICODE_CTRLS}
+ then
+ begin
+ DI := Pointer( Hdr );
+ LV := Sender;
+ if LV <> nil then
+ begin
+ Txt := '';
+ DI.item.iImage := -1;
+ DI.item.state := 0;
+ if {$IFDEF NIL_EVENTS} Assigned( LV.EV.fOnLVData ) and {$ENDIF}
+ (DI.item.iItem >= 0) then
+ begin
+ Store := FALSE;
+ LV.EV.fOnLVData( LV, DI.item.iItem, DI.item.iSubItem, Txt,
+ DI.item.iImage, DWORD( DI.item.state ), Store );
+ LV.fCaption := Txt;
+ DI.item.pszText := PKOL_Char( PKOLChar( LV.fCaption ) );
+ if Store then
+ DI.item.mask := DI.item.mask or LVIF_DI_SETITEM;
+ end;
+ Result := TRUE;
+ end;
+ end;
+ end;
+ end;
+end;
+
+procedure TControl.SetOnLVData(const Value: TOnLVData);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnLVData := Value;
+ AttachProc( @WndProc_LVData );
+ Perform( LVM_SETCALLBACKMASK, LVIS_OVERLAYMASK or LVIS_STATEIMAGEMASK, 0 );
+end;
+
+{$IFDEF ENABLE_DEPRECATED}
+{$DEFINE implementation} {$I KOL_deprecated.inc} {$UNDEF implementation}
+{$ENDIF DISABLE_DEPRECATED}
+
+function WndProc_LVCustomDraw( Sender: PControl; var Msg: TMsg;
+ var Rslt: Integer ): Boolean;
+var NMCustDraw: PNMLVCustomDraw;
+ NMHdr: PNMHdr;
+ ItemIdx, SubItemIdx: Integer;
+ S: TListViewItemState;
+ ItemState: TDrawState;
+begin
+ Result := FALSE;
+ if Msg.message = WM_NOTIFY then
+ begin
+ NMHdr := Pointer( Msg.lParam );
+ if (NMHdr.code = NM_CUSTOMDRAW)
+ {$IFDEF NIL_EVENTS} and Assigned( Sender.EV.fOnLVCustomDraw ) {$ENDIF}
+ then
+ begin
+ NMCustDraw := Pointer( Msg.lParam );
+ ItemIdx := -1;
+ SubItemIdx := -1;
+ if LongBool( NMCustDraw.nmcd.dwDrawStage and CDDS_ITEM ) then
+ ItemIdx := NMCustDraw.nmcd.dwItemSpec;
+ if LongBool( NMCustDraw.nmcd.dwDrawStage and CDDS_SUBITEM ) then
+ SubItemIdx := NMCustDraw.iSubItem;
+ ItemState := [ ];
+ if ItemIdx >= 0 then
+ begin
+ S := Sender.LVItemState[ ItemIdx ];
+ if lvisFocus in S then
+ include( ItemState, odsFocused );
+ if lvisSelect in S then
+ include( ItemState, odsSelected );
+ if lvisBlend in S then
+ include( ItemState, odsGrayed );
+ if lvisHighlight in S then
+ include( ItemState, odsMarked );
+ end;
+ Rslt := Sender.EV.FOnLVCustomDraw( Sender, {Sender.fPaintDC} NMCustDraw.nmcd.hdc,
+ NMCustDraw.nmcd.dwDrawStage, ItemIdx, SubItemIdx, NMCustDraw.nmcd.rc,
+ ItemState, TColor( NMCustDraw.clrText ), TColor( NMCustDraw.clrTextBk ) );
+
+ Result := TRUE;
+ end;
+ end;
+end;
+
+procedure TControl.SetOnLVCustomDraw(const Value: TOnLVCustomDraw);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnLVCustomDraw := Value;
+ AttachProc( @WndProc_LVCustomDraw );
+end;
+
+function CompareLVItems( Idx1, Idx2: Integer; ListView: PControl ): Integer; stdcall;
+begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( ListView.EV.fOnCompareLVItems ) then
+ {$ENDIF}
+ Result := ListView.EV.fOnCompareLVItems( ListView, Idx1, Idx2 )
+ {$IFDEF NIL_EVENTS}
+ else
+ Result := 0
+ {$ENDIF} ;
+end;
+
+procedure TControl.LVSort;
+begin
+ Perform( LVM_SORTITEMSEX, Integer(@Self), Integer(@CompareLVItems) );
+end;
+
+function CompareLVItemsData( D1, D2: DWORD; ListView: PControl ): Integer; stdcall;
+begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( ListView.EV.fOnCompareLVItems ) then
+ {$ENDIF}
+ Result := ListView.EV.fOnCompareLVItems( ListView, D1, D2 )
+ {$IFDEF NIL_EVENTS}
+ else
+ Result := 0
+ {$ENDIF} ;
+end;
+
+procedure TControl.LVSortData;
+begin
+ Perform( LVM_SORTITEMS, Integer( @Self ), Integer( @CompareLVItemsData ) );
+end;
+
+function WndProc_LVColumnClick( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
+ : Boolean;
+var Hdr: PNMHDR;
+ LV: PNMListView;
+begin
+ Result := FALSE;
+ if Msg.message = WM_NOTIFY then
+ begin
+ Hdr := Pointer(Msg.lParam);
+ if Hdr.hwndFrom = Sender.Handle then
+ begin
+ LV := Pointer( Hdr );
+ if Hdr.code = LVN_COLUMNCLICK then
+ begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnColumnClick ) then
+ {$ENDIF}
+ Sender.EV.fOnColumnClick( Sender, LV.iSubItem );
+ Result := TRUE;
+ end;
+ end;
+ end;
+end;
+
+procedure TControl.SetOnColumnClick(const Value: TOnLVColumnClick);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnColumnClick := Value;
+ AttachProc( @WndProc_LVColumnClick );
+end;
+
+function WndProc_LVStateChange( Sender: PControl; var Msg: TMsg; var R: Integer ): Boolean;
+var NMOD: PNMLVODStateChange;
+ NMLV: PNMLISTVIEW;
+begin
+ if Msg.message = WM_NOTIFY then
+ begin
+ NMOD := Pointer( Msg.lParam );
+ NMLV := Pointer( Msg.lParam );
+ if NMOD.hdr.code = LVN_ODSTATECHANGED then
+ begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnLVStateChange ) then
+ {$ENDIF}
+ Sender.EV.fOnLVStateChange( Sender, NMOD.iFrom, NMOD.iTo,
+ NMOD.uOldState, NMOD.uNewState );
+ end
+ else
+ if NMLV.hdr.code = LVN_ITEMCHANGED then
+ begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnLVStateChange ) then
+ {$ENDIF}
+ Sender.EV.fOnLVStateChange( Sender, NMLV.iItem, NMLV.iItem,
+ NMLV.uOldState, NMLV.uNewState );
+ end;
+ end;
+ Result := FALSE;
+end;
+
+procedure TControl.SetOnLVStateChange(const Value: TOnLVStateChange);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .FOnLVStateChange := Value;
+ AttachProc( WndProc_LVStateChange );
+end;
+
+function CompareLVColumns( Idx1, Idx2: Integer; Sender: PControl ): Integer; stdcall;
+var S1, S2: KOLString;
+begin
+ //--- changed by Mike Gerasimov:
+ S1 := Sender.LVItems[ Idx1, Sender.DF.fColumn ];
+ S2 := Sender.LVItems[ Idx2, Sender.DF.fColumn ];
+ If lvoSortAscending in Sender.DF.fLVOptions Then
+ Result := AnsiCompareStrNoCase( S1, S2 )
+ Else
+ If lvoSortDescending in Sender.DF.fLVOptions Then
+ Result := AnsiCompareStrNoCase( S2, S1 )
+ Else
+ Result:=0;
+end;
+
+procedure TControl.LVSortColumn(Idx: Integer);
+begin
+ DF.fColumn := Idx;
+ Perform( LVM_SORTITEMSEX, Integer(@Self), Integer(@CompareLVColumns) );
+end;
+
+function TControl.LVIndexOf(const S: KOLString): Integer;
+begin
+ Result := LVSearchFor( S, -1, FALSE );
+end;
+
+function TControl.LVSearchFor(const S: KOLString; StartAfter: Integer;
+ Partial: Boolean): Integer;
+var f: TLVFindInfo;
+begin
+ f.lParam := 0;
+ f.flags := LVFI_STRING;
+ if Partial then
+ f.flags := LVFI_STRING or LVFI_PARTIAL;
+ f.psz := @s[1];
+ result := Perform(LVM_FINDITEM,StartAfter,integer(@f));
+end;
+
+function WndProcLVMeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var
+ pMI: PMeasureItemStruct;
+ P: PControl;
+ H: Integer;
+ wId: DWORD;
+ i: Integer;
+begin
+ Result := FALSE;
+ if Msg.message = WM_MEASUREITEM then begin
+ pMI := Pointer(Msg.lParam);
+ with pMI^ do begin
+ for i:=0 to Sender.ChildCount-1 do begin
+ P := Sender.Children[i];
+ if P <> nil then begin
+ wId := GetWindowLong(P.Handle,GWL_ID);
+ if CtlID = wId then begin
+ H := P.Perform(WM_MEASUREITEM,0,0);
+ if H > 0 then begin
+ itemHeight := H;
+ Rslt:=1;
+ Result := TRUE;
+ end;
+ break;
+ end;
+ end;
+ end;
+ end;
+ end;
+end;
+
+function WndProcLVMeasureItem2( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := FALSE;
+ if (Msg.message = WM_MEASUREITEM) and (Msg.wParam = 0) then begin
+ Rslt := Sender.DF.fLVItemHeight;
+ Result := TRUE;
+ end;
+
+end;
+
+function TControl.SetLVItemHeight(Value: Integer): PControl;
+begin
+ Set_LVItemHeight( Value );
+ Result := @ Self;
+end;
+
+procedure TControl.Set_LVItemHeight(Value: Integer);
+begin
+ if DF.fLVItemHeight <> Value then
+ begin
+ if DF.fLVItemHeight = 0 then
+ begin
+ Parent.AttachProc(WndProcLVMeasureItem);
+ AttachProc(WndProcLVMeasureItem2);
+ end;
+ DF.fLVItemHeight := Value;
+ end;
+end;
+
+function TControl.IndexOf(const S: KOLString): Integer;
+begin
+ Result := SearchFor( S, -1, FALSE );
+end;
+
+function TControl.SearchFor(const S: KOLString; StartAfter: Integer;
+ Partial: Boolean): Integer;
+var Cmd: Integer;
+ I: Integer;
+begin
+ Cmd := fCommandActions.aFindItem;
+ if Partial then
+ Cmd := fCommandActions.aFindPartial;
+ if Cmd <> 0 then
+ Result := Perform( Cmd, StartAfter, Integer( PKOLChar( S ) ) )
+ else
+ begin
+ Result := -1;
+ for I := StartAfter+1 to Count-1 do
+ begin
+ if Partial and ( Copy( Items[ I ], 1, Length( S ) ) = S ) or
+ ( Items[ I ] = S ) then
+ begin
+ Result := I;
+ break;
+ end;
+ end;
+ end;
+end;
+
+{$UNDEF ASM_LOCAL}
+{$IFDEF ASM_VERSION}
+ {$IFDEF USE_FLAGS}
+ {$IFDEF EVENTS_DYNAMIC}
+ //{$IFNDEF NIL_EVENTS}
+ {$IFNDEF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY}
+ {$DEFINE ASM_LOCAL}
+ {$ENDIF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY}
+ //{$ENDIF NIL_EVENTS}
+ {$ENDIF EVENTS_DYNAMIC}
+ {$ENDIF USE_FLAGS}
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_LOCAL}
+function TControl.DefaultBtnProc(var Msg: TMsg; var Rslt: Integer): Boolean;
+asm
+ PUSH EBX
+ PUSH ESI
+ PUSH EDI
+ PUSH ECX // save @Rslt
+ PUSH EDX // save Msg
+ MOV EBX, EDX // EBX = @ Msg
+ XCHG ESI, EAX // ESI = @ Self
+ MOV EAX, [ESI].TControl.EV
+ MOV EDI, [EAX].TEvents.fOldOnMessage.TMethod.Code
+ MOV EAX, [EAX].TEvents.fOldOnMessage.TMethod.Data
+ {$IFDEF NIL_EVENTS}
+ TEST EDI, EDI
+ JZ @@cont
+ {$ELSE}
+ {$ENDIF}
+ CALL EDI
+ TEST AL, AL
+ JNZ @@exit1
+@@cont:
+ CMP [AppletTerminated], AL
+ JNZ @@exit
+ MOV AX, word ptr [EBX].TMsg.message
+ //SUB AX, WM_KEYDOWN
+ DEC AH
+ CMP AX, WM_CHAR - WM_KEYDOWN
+ JA @@exit
+ XCHG EAX, EBX
+ MOV EBX, [EAX].TMsg.message
+ SHL EBX, 16
+ MOV BL, byte ptr [EAX].TMsg.wParam
+ CMP BL, 13
+ JE @@ok1327
+ CMP BL, 27
+ JNE @@exit
+@@ok1327:
+ MOV EDI, [Applet]
+ TEST [EDI].TControl.fFlagsG3, 1 shl G3_IsForm
+ JNZ @@1
+ MOV EDI, [EDI].DF.fCurrentControl
+@@1:
+ TEST EDI, EDI
+ JZ @@exit
+
+ PUSH EBP
+ XOR EBP, EBP // Btn := nil;
+
+ MOV BH, 13
+ MOV EDX, offset[DFLT_BTN]
+@@findButton:
+ MOV EAX, EDI
+ CALL TControl.Get_Prop_Int
+ TEST EAX, EAX
+ JZ @@notFromProp
+ CMP BL, BH
+ JNZ @@notFromProp
+ MOV EBP, EAX
+ CALL TControl.GetToBeVisible
+ TEST AL, AL
+ JZ @@notFromProp
+ MOV EAX, EBP
+ CALL TControl.GetEnabled
+ TEST AL, AL
+ JZ @@notFromProp
+ CMP BL, 13
+ JNZ @@yesFound
+ MOV ECX, [EDI].TControl.DF.fCurrentControl
+ JECXZ @@yesFound
+ TEST word ptr [ECX].TControl.fFlagsG5, (1 shl G6_CancelBtn) shl 8 or(1 shl G5_IgnoreDefault)
+ JZ @@yesFound
+ CMP EBP, ECX
+ JZ @@yesFound
+@@notFromProp:
+ XOR EBP, EBP
+ CMP BL, 13
+ JNZ @@notFound
+ MOV AL, [EDI].TControl.DF.fAllBtnReturnClick
+ OR AL, [ESI].TControl.DF.fAllBtnReturnClick
+ JZ @@notFound
+ MOV ECX, [EDI].DF.fCurrentControl
+ JECXZ @@notFound
+ MOV AL, [ECX].TControl.fFlagsG5
+ AND AL, (1 shl G5_IsButton) or (1 shl G5_IsGroupbox)
+ CMP AL, (1 shl G5_IsButton)
+ JNZ @@notFound
+ MOV EBP, EAX
+ CALL TControl.GetToBeVisible
+ TEST AL, AL
+ JNZ @@yesFound
+@@notFound:
+ XOR EBP, EBP
+@@yesFound:
+ CMP BH, 13
+ MOV BH, 27
+ MOV EDX, offset[CNCL_BTN]
+ JNZ @@check_Found
+ TEST EBP, EBP
+ JZ @@findButton
+@@check_Found:
+ MOV ECX, EBP
+ POP EBP
+ JECXZ @@exit
+
+ MOV ESI, ECX
+ XCHG EAX, ECX
+
+ SHR EBX, 16
+ CMP BX, WM_KEYDOWN
+ JNZ @@doclick
+
+ MOV DL, 1
+ CALL TControl.SetFocused
+
+@@doclick:
+ POP EDI
+ POP EBX
+
+ PUSH [EDI].TMsg.lParam
+ PUSH 32
+ PUSH [EDI].TMsg.message
+ PUSH ESI
+ CALL TControl.Perform
+
+ XOR EAX, EAX
+ AND [EDI].TMsg.wParam, EAX
+ AND [EBX], EAX
+ INC EAX
+ PUSH EAX
+ PUSH EAX
+ JMP @@exit1
+
+@@exit: XOR EAX, EAX
+@@exit1:
+ POP EDX
+ POP ECX
+ POP EDI
+ POP ESI
+ POP EBX
+end;
+{$ELSE PAS_VERSION}
+function TControl.DefaultBtnProc(var Msg: TMsg;
+ var Rslt: Integer): Boolean;
+var Btn: PControl;
+ F: PControl;
+
+ procedure FindBtn( key: Word; s: PKOLChar; for_dflt: Boolean );
+ var Ctl: PControl;
+ begin
+ Ctl := Pointer( F.PropInt[ s ] );
+ if (Msg.wParam = key) and
+ (Ctl <> nil) and
+ Ctl.ToBeVisible and
+ Ctl.Enabled and
+ ( not for_dflt or
+ for_dflt and
+ ( (F.DF.fCurrentControl=nil) or
+ ({$IFDEF USE_FLAGS} not(G6_CancelBtn in F.DF.fCurrentControl.fFlagsG6)
+ {$ELSE} not F.DF.fCurrentControl.fCancelBtn {$ENDIF} and
+ {$IFDEF USE_FLAGS} not(G5_IgnoreDefault in F.DF.fCurrentControl.fFlagsG5)
+ {$ELSE} not F.DF.fCurrentControl.fIgnoreDefault {$ENDIF})
+ or (F.DF.fCurrentControl = Ctl)
+ ) ) then
+ Btn := Ctl
+ else
+ if for_dflt
+ AND (Msg.wParam = VK_RETURN) and
+ (F.DF.fAllBtnReturnClick or DF.fAllBtnReturnClick)
+ and (F.ActiveControl <> nil) and
+ (F.ActiveControl.ToBeVisible) and
+ {$IFDEF USE_FLAGS} (G5_IsButton in F.ActiveControl.fFlagsG5)
+ and not(G5_IsGroupbox in F.ActiveControl.fFlagsG5)
+ {$ELSE} (F.ActiveControl.IsButton and not F.ActiveControl.fIsGroupbox) {$ENDIF}
+ {and (F.ActiveControl.Count = 0)} then
+ Btn := F.ActiveControl;
+ end;
+begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( EV.fOldOnMessage ) then
+ {$ENDIF}
+ begin
+ Result := EV.fOldOnMessage( Msg, Rslt );
+ if Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := FALSE;
+ if AppletTerminated then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ F := Applet;
+ if {$IFDEF USE_FLAGS} not(G3_IsForm in F.fFlagsG3)
+ {$ELSE} not F.fIsForm {$ENDIF} then
+ F := F.DF.fCurrentControl;
+ if F = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Btn := nil;
+ if //((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or (Msg.message = WM_CHAR)) and
+ ((Msg.message >= WM_KEYDOWN) and (Msg.message <= WM_CHAR)) and
+ ((Msg.wParam = VK_RETURN) or (Msg.wParam = VK_ESCAPE)) then
+ begin
+ FindBtn( VK_RETURN, @DFLT_BTN, TRUE );
+ FindBtn( VK_ESCAPE, @CNCL_BTN, FALSE );
+ if Btn <> nil then
+ begin
+ if Msg.message = WM_KEYDOWN then
+ begin
+ {$IFDEF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY}
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Btn.EV.fOnClick ) then
+ {$ENDIF}
+ Btn.EV.fOnClick( Btn );
+ {$ELSE}
+ Btn.Focused := TRUE;
+ {$ENDIF}
+ end;
+ {$IFDEF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY}
+ {$ELSE}
+ Btn.Perform( Msg.message, DWORD( ' ' ), Msg.lParam );
+ {$ENDIF}
+ Msg.wParam := 0;
+ Result := TRUE;
+ Rslt := 0; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end
+ end;
+ Result := FALSE;
+end;
+{$ENDIF PAS_VERSION}
+
+{$UNDEF ASM_LOCAL}
+{$IFDEF ASM_VERSION}
+ {$IFDEF USE_FLAGS}
+ {$IFNDEF DEFAULT_CANCEL_BTN_EXCLUSIVE}
+ {$IFDEF EVENTS_DYNAMIC}
+ {$DEFINE ASM_LOCAL}
+ {$ENDIF EVENTS_DYNAMIC}
+ {$ENDIF DEFAULT_CANCEL_BTN_EXCLUSIVE}
+ {$ENDIF USE_FLAGS}
+{$ENDIF PAS_VERSION}
+
+{$IFDEF ASM_LOCAL}
+procedure TControl.SetDefaultBtn(const Index: Integer;
+ const Value: Boolean);
+asm
+ PUSH EBX
+ PUSH EDI
+ PUSH ESI
+ MOV BL, DL // index
+ MOV BH, CL // value
+ MOV ESI, EAX // @Self
+ ADD ECX, ECX // DL = 2
+ CMP BL, 13
+ JZ @@1
+ CMP BL, 27
+ JNZ @@2
+ ADD ECX, ECX // DL := Index = 13 ? 2 : 4
+@@1: CMP BH, 0
+ JNZ @@set_flag
+ NOT CL
+ AND [ESI].fFlagsG6, CL
+ MOV CL, 0
+@@set_flag:
+ OR [ESI].fFlagsG6, CL
+@@2:
+ CMP [Applet], 0
+ JZ @@exit
+ CALL TControl.ParentForm
+ TEST EAX, EAX
+ JZ @@exit
+
+ XCHG EDI, EAX // EDI = ParentForm
+ MOV AL, BH
+ SHR EAX, 1
+ SBB ECX, ECX
+ AND ECX, ESI // ECX = Value ? @ Self : 0
+ MOV EDX, offset[DFLT_BTN]
+ CMP BL, 13
+ JZ @@3
+ MOV EDX, offset[CNCL_BTN]
+@@3:
+ XCHG EAX, EDI
+ CALL TControl.Set_Prop_Int
+
+ {$IFnDEF NO_DEFAULT_BUTTON_BOLD}
+ XCHG EAX, ESI //---- больше @Self не нужен
+ MOV EDX, [EAX].TControl.fStyle
+ AND DL, not BS_DEFPUSHBUTTON //---- BS_DEFPUSHBUTTON = 1, BH = Value = 1 : 0
+ OR DL, BH
+ CALL TControl.SetStyle
+ {$ENDIF}
+
+ TEST BH, BH
+ MOV ESI, [Applet] // ESI = Applet
+ MOV EBX, [ESI].TControl.EV
+ JZ @@notValue
+
+ MOV EDX, [EBX].TEvents.fOnMessage.TMethod.Code
+ CMP EDX, offset[TControl.DefaultBtnProc]
+ JZ @@setDefaultBtnProc
+
+ MOV [EBX].TEvents.fOldOnMessage.TMethod.Code, EDX
+ MOV EDX, [EBX].TEvents.fOnMessage.TMethod.Data
+ MOV [EBX].TEvents.fOldOnMessage.TMethod.Data, EDX
+
+@@setDefaultBtnProc:
+ MOV [EBX].TEvents.fOnMessage.TMethod.Code, offset[TControl.DefaultBtnProc]
+ MOV [EBX].TEvents.fOnMessage.TMethod.Data, ESI
+ JMP @@exit
+
+@@notValue:
+ LEA ESI, [EBX].TEvents.fOldOnMessage
+ LEA EDI, [EBX].TEvents.fOnMessage
+ MOVSD
+ MOVSD
+ MOV [EBX].TEvents.fOldOnMessage.TMethod.Code, offset[DummyProc123_0]
+
+@@exit: POP ESI
+ POP EDI
+ POP EBX
+end;
+{$ELSE notASM_VERSION}
+procedure TControl.SetDefaultBtn(const Index: Integer;
+ const Value: Boolean);
+var F, C: PControl;
+begin
+ if Index = 13 then
+ begin
+ {$IFDEF USE_FLAGS} if Value
+ then include( fFlagsG6, G6_DefaultBtn )
+ else exclude( fFlagsG6, G6_DefaultBtn );
+ {$ELSE} fDefaultBtn := Value; {$ENDIF}
+ {$IFDEF DEFAULT_CANCEL_BTN_EXCLUSIVE}
+ {$IFDEF USE_FLAGS} Exclude( fFlagsG6, G6_CancelBtn );
+ {$ELSE} fCancelBtn := FALSE; {$ENDIF}
+ {$ENDIF}
+ end else
+ if Index = 27 then // this check is necessary still could be Index = 0 to reset both !
+ begin
+ {$IFDEF USE_FLAGS} if Value
+ then include( fFlagsG6, G6_CancelBtn )
+ else exclude( fFlagsG6, G6_CancelBtn );
+ {$ELSE} fCancelBtn := Value; {$ENDIF}
+
+ {$IFDEF DEFAULT_CANCEL_BTN_EXCLUSIVE}
+ {$IFDEF USE_FLAGS} Exclude( fFlagsG6, G6_DefaultBtn );
+ {$ELSE} fDefaultBtn := FALSE; {$ENDIF}
+ {$ENDIF}
+ end;
+ if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ F := ParentForm;
+ if F <> nil then
+ begin
+ C := nil;
+ if Value then C := @ Self;
+ if Index = 13 then
+ begin
+ F.PropInt[ @DFLT_BTN ] := Integer( C );
+ {$IFDEF NO_DEFAULT_BUTTON_BOLD}
+ {$ELSE}
+ if Value then
+ Style := fStyle.Value or BS_DEFPUSHBUTTON
+ else
+ Style := fStyle.Value and not BS_DEFPUSHBUTTON;
+ {$ENDIF}
+ end
+ else if Index = 27 then
+ F.PropInt[ @CNCL_BTN ] := Integer( C );
+
+ if Value then
+ begin
+ if @ Applet.EV.fOnMessage <> @ TControl.DefaultBtnProc then
+ Applet.EV.fOldOnMessage := Applet.EV.fOnMessage; // fixed by YS
+ Applet.EV.fOnMessage := Applet.DefaultBtnProc;
+ end else
+ begin
+ Applet.EV.fOnMessage := Applet.EV.fOldOnMessage;
+ Applet.EV.fOldOnMessage :=
+ {$IFDEF SAFEST_CODE} TOnMessage( MakeMethod( nil, @ DummyProc123_0 ) )
+ {$ELSE} nil {$ENDIF};
+ end;
+ end;
+end;
+{$ENDIF PAS_VERSION}
+
+function TControl.GetDefaultBtn(const Index: Integer): Boolean;
+begin
+ CASE Index OF
+ 13 : Result := {$IFDEF USE_FLAGS} G6_DefaultBtn in fFlagsG6
+ {$ELSE} fDefaultBtn {$ENDIF};
+ else Result := {$IFDEF USE_FLAGS} G6_CancelBtn in fFlagsG6
+ {$ELSE} fCancelBtn {$ENDIF};
+ END;
+end;
+
+function TControl.AllBtnReturnClick: PControl;
+{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
+begin
+ // nothing: already implemented in WndProcBtnReturnClick
+ Result := @ Self;
+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;
+ if F <> nil then
+ F.DF.fAllBtnReturnClick := TRUE;
+ end;
+ Result := @ Self;
+end;
+{$ENDIF}
+
+function WndProc_CNDrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
+ : Boolean;
+type PDrawAction = ^TDrawAction;
+ PDrawState = ^TDrawState;
+var DI: PDrawItemStruct;
+begin
+ Result := FALSE;
+ if Msg.message = CN_DRAWITEM then
+ begin
+ DI := Pointer( Msg.lParam );
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.fOnDrawItem ) then
+ {$ENDIF}
+ begin
+ if Sender.EV.fOnDrawItem( Sender, DI.hDC, DI.rcItem, DI.itemID,
+ PDrawAction( @ DI.itemAction )^,
+ PDrawState( @ DI.itemState )^ )
+ then Rslt := 1
+ else Rslt := 0;
+ Result := TRUE;
+ end
+ {$IFDEF NIL_EVENTS}
+ else Rslt := 0
+ {$ENDIF}
+ ;
+ end;
+end;
+
+procedure TControl.SetOnDrawItem(const Value: TOnDrawItem);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnDrawItem := Value;
+ if Parent <> nil then
+ Parent.AttachProc( @WndProc_DrawItem );
+ AttachProc( @WndProc_CNDrawItem );
+end;
+
+function WndProc_MeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
+ : Boolean;
+var MI: PMeasureItemStruct;
+ Control: PControl;
+ I: Integer;
+begin
+ Result := FALSE;
+ if Msg.message = WM_MEASUREITEM then
+ begin
+ MI := Pointer( Msg.lParam );
+ for I := 0 to Sender.ChildCount - 1 do
+ begin
+ Control := Sender.Children[ I ];
+ if Control.Menu = MI.CtlID then
+ begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Control.EV.fOnMeasureItem ) then
+ {$ENDIF}
+ begin
+ MI.itemHeight := Control.EV.fOnMeasureItem( Control, MI.itemID );
+ if MI.itemHeight > 0 then
+ begin
+ Rslt := 1;
+ Result := TRUE;
+ end;
+ end;
+ break;
+ end;
+ end;
+ end;
+end;
+
+procedure TControl.SetOnMeasureItem(const Value: TOnMeasureItem);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnMeasureItem := Value;
+ if Parent <> nil then
+ Parent.AttachProc( @WndProc_MeasureItem );
+end;
+
+function TControl.GetItemData(Idx: Integer): DWORD;
+begin
+ Result := 0;
+ if fCommandActions.aGetItemData <> 0 then
+ Result := Perform( fCommandActions.aGetItemData, Idx, 0 );
+end;
+
+procedure TControl.SetItemData(Idx: Integer; const Value: DWORD);
+begin
+ if fCommandActions.aSetItemData <> 0 then
+ Perform( fCommandActions.aSetItemData, Idx, Value );
+end;
+
+function TControl.GetLVCurItem: Integer;
+begin
+ Result := Perform( LVM_GETNEXTITEM, -1, LVNI_SELECTED );
+end;
+
+procedure TControl.SetLVCurItem(const Value: Integer);
+begin
+ if (lvoMultiselect in LVOptions) or (Value <> LVCurItem ) then
+ LVItemState[ -1 ] := [ ];
+ if Value >= 0 then
+ LVItemState[ Value ] := [ lvisSelect, lvisFocus ];
+end;
+
+function TControl.LVNextItem(IdxPrev: Integer; Attrs: DWORD): Integer;
+begin
+ Result := Perform( LVM_GETNEXTITEM, IdxPrev, Attrs );
+end;
+
+function TControl.LVNextSelected(IdxPrev: Integer): Integer;
+begin
+ Result := Perform( LVM_GETNEXTITEM, IdxPrev, LVNI_SELECTED );
+end;
+
+function TControl.GetLVFocusItem: Integer;
+begin
+ Result := Perform( LVM_GETNEXTITEM, -1, LVNI_FOCUSED );
+end;
+
+procedure TControl.Close;
+begin
+ PostMessage( Handle, WM_CLOSE, 0, 0 );
+end;
+
+function WndProcMinimize( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var Wnd: PControl;
+begin
+ Result := FALSE;
+ if (Msg.message = WM_SYSCOMMAND) and ((Msg.wParam and $FFF0) = SC_MINIMIZE)then
+ begin
+ if Applet <> nil then
+ begin
+ Wnd := Pointer( Applet.PropInt[ @MIN_WND ] ); // fMinimizeWnd;
+ if Wnd <> nil then
+ SetWindowPos( Applet.Handle, 0, Wnd.Left, Wnd.Top, Wnd.Width, 0,
+ SWP_NOZORDER or SWP_NOREDRAW);
+ end;
+ end;
+end;
+
+function WndProcRestore( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+begin
+ Result := FALSE;
+ CASE Msg.message OF
+ WM_SHOWWINDOW:
+ begin
+ case Msg.lParam of
+ SW_PARENTCLOSING:
+ begin
+ if IsIconic( Self_.fHandle ) then
+ Self_.DF.fShowAction := SW_SHOWMINNOACTIVE
+ else
+ if IsZoomed( Self_.fHandle ) then
+ Self_.DF.fShowAction := SW_SHOWMAXIMIZED
+ else
+ Self_.DF.fShowAction := SW_SHOWNOACTIVATE;
+ end;
+ SW_PARENTOPENING:
+ begin
+ if Self_.DF.fShowAction <> 0 then
+ begin
+ ShowWindow( Self_.fHandle, Self_.DF.fShowAction );
+ Self_.DF.fShowAction := 0;
+ end;
+ Rslt := 0;
+ end;
+ end;
+ end;
+ END;
+end;
+
+procedure TControl.MinimizeNormalAnimated;
+var App: PControl;
+begin
+ App := Applet;
+ if App = nil then
+ App := @Self;
+ App.PropInt[ @MIN_WND ] // fMinimizeWnd
+ := Integer( @Self );
+ App.AttachProc( @WndProcMinimize );
+ AttachProc( @WndProcRestore );
+end;
+
+procedure TControl.RestoreNormalMaximized;
+begin
+ AttachProc( @WndProcRestore );
+end;
+
+function WndProcDropFiles( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var hDrop: THandle;
+ Pt: TPoint;
+ FList: KOLString;
+ I, N: Integer;
+ Buf: array[ 0..MAX_PATH ] of KOLChar;
+begin
+ if Msg.message = WM_DROPFILES then
+ if TMethod(Sender.EV.fOnDropFiles).Code <> nil then
+ begin
+ hDrop := Msg.wParam;
+ DragQueryPoint( hDrop, Pt );
+ N := DragQueryFile( hDrop, $FFFFffff, nil, 0 );
+ FList := '';
+ for I := 0 to N-1 do
+ begin
+ if FList <> '' then
+ FList := FList + #13;
+ DragQueryFile( hDrop, I, Buf, Sizeof( Buf ) );
+ FList := FList + KOLString(Buf);
+ end;
+ DragFinish( hDrop );
+ Sender.EV.FOnDropFiles( Sender, FList, Pt );
+ Rslt := 0;
+ Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ Result := FALSE;
+end;
+
+procedure TControl.SetOnDropFiles(const Value: TOnDropFiles);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .FOnDropFiles := Value;
+ AttachProc( @WndProcDropFiles );
+ DragAcceptFiles( GetWindowHandle, Assigned( Value ) );
+end;
+
+function WndProcShowHide( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var IsVisible: Boolean;
+begin
+ if Msg.message = WM_SHOWWINDOW then
+ if Msg.hwnd = Sender.Handle then
+ begin
+ IsVisible := IsWindowVisible( Sender.Handle );
+ if LongBool( Msg.wParam ) then
+ begin
+ {$IFDEF USE_FLAGS} include( Sender.fStyle.f3_Style, F3_Visible );
+ {$ELSE} Sender.fVisible := TRUE; {$ENDIF}
+ if not IsVisible then
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.FOnShow ) then
+ {$ENDIF}
+ Sender.EV.FOnShow( Sender );
+ end else
+ begin
+ {$IFDEF USE_FLAGS} exclude( Sender.fStyle.f3_Style, F3_Visible );
+ {$ELSE} Sender.fVisible := FALSE; {$ENDIF}
+ if IsVisible then
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Sender.EV.FOnHide ) then
+ {$ENDIF}
+ Sender.EV.FOnHide( Sender );
+ end;
+ end;
+ Sender.UpdateWndStyles;
+ Result := FALSE;
+end;
+
+procedure TControl.SetOnHide(const Value: TOnEvent);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .FOnHide := Value;
+ AttachProc( WndProcShowHide );
+end;
+
+procedure TControl.SetOnShow(const Value: TOnEvent);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .FOnShow := Value;
+ AttachProc( WndProcShowHide );
+end;
+
+function TControl.BringToFront: PControl;
+begin
+ SetWindowPos( GetWindowHandle, HWND_TOP, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or
+ SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_SHOWWINDOW );
+ Result := @Self;
+end;
+
+function TControl.SendToBack: PControl;
+begin
+ SetWindowPos( GetWindowHandle, HWND_BOTTOM, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or
+ SWP_NOACTIVATE or SWP_NOOWNERZORDER );
+ Result := @Self;
+end;
+
+procedure TControl.DragStart;
+begin
+ PostMessage( GetWindowHandle, WM_SYSCOMMAND, $F012, 0 );
+end;
+
+function WndProcDragWindow( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var P: TPoint;
+ Delta: DWORD;
+ dX, dY: Integer;
+begin
+ if Msg.message = WM_MOUSEMOVE then
+ begin
+ if {$IFDEF USE_FLAGS} G6_Dragging in Sender.fFlagsG6
+ {$ELSE} Sender.FDragging {$ENDIF} then
+ begin
+ GetCursorPos( P );
+ Delta := Sender.PropInt[ @DRAG_XY ];
+ dX := SmallInt( LoWord( Delta ) );
+ dY := SmallInt( HiWord( Delta ) );
+ P.x := P.x + dX; // - Sender.fMouseStartPos.x + Sender.fDragStartPos.x;
+ P.y := P.y + dY; // - Sender.fMouseStartPos.y + Sender.fDragStartPos.y;
+ Sender.Position := P;
+ end;
+ end;
+ Result := FALSE;
+end;
+
+procedure TControl.DragStartEx;
+var StartBounds: TRect;
+ MSP: TPoint;
+ 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;
+ dY := StartBounds.Top - MSP.Y;
+ Delta := (dX and $FFFF) or (dY shl 16);
+ PropInt[ @DRAG_XY ] := Delta;
+ SetCapture( GetWindowHandle );
+ {$IFDEF USE_FLAGS} include( fFlagsG6, G6_Dragging );
+ {$ELSE} fDragging := TRUE; {$ENDIF}
+ AttachProc( WndProcDragWindow );
+end;
+
+procedure TControl.DragStopEx;
+begin
+ if {$IFDEF USE_FLAGS} G6_Dragging in fFlagsG6
+ {$ELSE} FDragging {$ENDIF} then
+ begin
+ ReleaseCapture;
+ {$IFDEF USE_FLAGS} exclude( fFlagsG6, G6_Dragging );
+ {$ELSE} FDragging := FALSE; {$ENDIF}
+ end;
+end;
+
+function CallDragCallBack( Sender: PControl; var Stop: Boolean ): Boolean;
+var P: TPoint;
+ Shape, ShapeWas: Integer;
+begin
+ Sender.AttachProc( WndProcSetCursor );
+ GetCursorPos( P );
+ Shape := LoadCursor( 0, PKOLChar(IDC_HAND) );
+ ShapeWas := Shape;
+ Result := Sender.EV.fDragCallback( Sender, P.x, P.y, Shape, Stop );
+ if not Stop then
+ begin
+ if not Result then
+ if Shape = ShapeWas then
+ Shape := LoadCursor( 0, IDC_NO );
+ ScreenCursor := Shape;
+ end
+ else
+ begin
+ ScreenCursor := 0;
+ Shape := Sender.fCursor;
+ end;
+ Windows.SetCursor( Shape );
+end;
+
+function WndProcDrag( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var Stop: Boolean;
+begin
+ if {$IFDEF USE_FLAGS} G6_Dragging in Sender.fFlagsG6
+ {$ELSE} Sender.fDragging {$ENDIF} then
+ begin
+ Stop := FALSE;
+ case Msg.message of
+ WM_MOUSEMOVE:
+ CallDragCallBack( Sender, Stop );
+ WM_LBUTTONUP, WM_RBUTTONUP:
+ begin
+ Stop := TRUE;
+ CallDragCallBack( Sender, Stop );
+ end;
+ else Result := FALSE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ if Stop then
+ begin
+ ReleaseCapture;
+ {$IFDEF USE_FLAGS} exclude( Sender.fFlagsG6, G6_Dragging );
+ {$ELSE} Sender.fDragging := FALSE; {$ENDIF}
+ end else
+ begin
+ Result := TRUE; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ Result := FALSE;
+end;
+
+procedure TControl.DragItem(OnDrag: TOnDrag);
+begin
+ EV.fDragCallback := OnDrag;
+ {$IFDEF USE_FLAGS} include( fFlagsG6, G6_Dragging );
+ {$ELSE} fDragging := TRUE; {$ENDIF}
+ SetCapture( GetWindowHandle );
+ AttachProc( WndProcDrag );
+end;
+
+{$IFDEF USE_CONSTRUCTORS} //****************************************************//
+ //
+constructor TControl.CreateWindowed(AParent: PControl; AClassName: PKOLChar; //
+ ACtl3D: Boolean); //
+begin //
+ CreateParented( AParent ); //
+ fOnDynHandlers := WndProcDummy; //
+ fWndProcKeybd := WndProcDummy; //
+ //{-2.95}//fWndProcResizeFlicks := WndProcDummy; //
+ fCommandActions.aClear := ClearText; //
+ //fWindowed := True; // is set in TControl.Init
+ fControlClassName := AClassName; //
+ //
+ fControlClick := DummyObjProc; //
+ //
+ fColor := clBtnFace; //
+ fTextColor := clWindowText; //
+ fMargin := 2; //
+ fCtl3D := True; //
+ fCtl3Dchild := True; //
+ if AParent <> nil then //
+ begin //
+ //{-2.95}//fWndProcResizeFlicks := AParent.fWndProcResizeFlicks; //
+ fGotoControl := AParent.fGotoControl; //
+ {$IFDEF USE_FLAGS}
+ exc fFlagsG2 := fFlagsG2 - [G2_DoubleBuffered, G2_Transparent] +
+ (AParent.fFlagsG2 * [G2_DoubleBuffered, G2_Transparent]);
+ {$ELSE} fDoubleBuffered := AParent.fDoubleBuffered;
+ fTransparent := AParent.fTransparent; //
+ {$ENDIF}
+ fCtl3Dchild := AParent.fCtl3Dchild; //
+ if AParent.fCtl3Dchild then //
+ fCtl3D := ACtl3D //
+ else fCtl3D := False; //
+ fMargin := AParent.fMargin; //
+ with fBoundsRect do //
+ begin //
+ Left := AParent.fMargin + AParent.fClientLeft; //
+ Top := AParent.fMargin + AParent.fClientTop; //
+ Right := Left + 64; //
+ Bottom := Top + 64; //
+ end; //
+ fTextColor := AParent.fTextColor; //
+ fFont := fFont.Assign( AParent.fFont ); //
+ if fFont <> nil then //
+ begin //
+ fFont.fOnGTChange := FontChanged; //
+ FontChanged( fFont ); //
+ end; //
+ fColor := AParent.fColor; //
+ fBrush := fBrush.Assign( AParent.fBrush ); //
+ if fBrush <> nil then //
+ begin //
+ fBrush.fOnGTChange := BrushChanged; //
+ BrushChanged( fBrush ); //
+ end; //
+ end; //
+end; //
+ //
+constructor TControl.CreateApplet(const ACaption: AnsiString); //
+begin //
+ AppButtonUsed := True; //
+ CreateWindowed( nil, 'App', TRUE ); //
+ {$IFDEF USE_FLAGS} include( fFlagsG3, G3_IsApplet );
+ {$ELSE} FIsApplet := TRUE; {$ENDIF}
+ fStyle := WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX //
+ or WS_CAPTION; //
+ fExStyle := WS_EX_APPWINDOW; //
+ FCreateWndExt := CreateAppButton; //
+ AttachProc( WndProcApp ); //
+ Caption := ACaption; //
+end; //
+ //
+constructor TControl.CreateForm(AParent: PControl; const ACaption: AnsiString); //
+begin //
+ CreateWindowed( AParent, 'Form', TRUE ); //
+ AttachProc( WndProcForm ); //
+ AttachProc( WndProcDoEraseBkgnd ); //
+ Caption := ACaption; //
+end; //
+ //
+constructor TControl.CreateControl(AParent: PControl; AClassName: PAnsiChar; //
+ AStyle: DWORD; ACtl3D: Boolean; Actions: PCommandActions); //
+var Form: PControl; //
+begin //
+ CreateWindowed( AParent, AClassName, ACtl3D ); //
+ if Actions <> nil then //
+ fCommandActions := Actions^; //
+ fIsControl := True; //
+ fStyle := AStyle or WS_CLIPSIBLINGS or WS_CLIPCHILDREN; //
+ fVisible := (Style and WS_VISIBLE) <> 0; //
+ fTabstop := (Style and WS_TABSTOP) <> 0; //
+ if (AParent <> nil) then //
+ begin //
+ Inc( AParent.ParentForm.fTabOrder ); //
+ fTabOrder := AParent.ParentForm.fTabOrder; //
+ end; //
+ fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ]; //
+ if fCtl3D then //
+ begin //
+ fStyle := fStyle and not WS_BORDER; //
+ fExStyle := fExStyle or WS_EX_CLIENTEDGE; //
+ end; //
+ if (Style and WS_TABSTOP) <> 0 then //
+ begin //
+ Form := ParentForm; //
+ if Form <> nil then //
+ if Form.FCurrentControl = nil then //
+ Form.FCurrentControl := @Self; //
+ end; //
+ //fCreateParamsExt := CreateParams2; //
+ fMenu := CtlIdCount; //
+ Inc( CtlIdCount ); //
+ AttachProc( WndProcCtrl ); //
+end; //
+ //
+constructor TControl.CreateButton(AParent: PControl; //
+ const ACaption: AnsiString); //
+begin //
+ CreateControl( AParent, 'BUTTON', //
+ WS_VISIBLE or WS_CHILD or //
+ BS_PUSHLIKE or WS_TABSTOP, False, @ButtonActions ); //
+ with fBoundsRect do //
+ Bottom := Top + 22; //
+ fTextAlign := taCenter; //
+ Caption := ACaption; //
+end; //
+ //
+constructor TControl.CreateBitBtn(AParent: PControl; //
+ const ACaption: AnsiString; AOptions: TBitBtnOptions; ALayout: TGlyphLayout; //
+ AGlyphBitmap: HBitmap; AGlyphCount: Integer); //
+var //
+ B: TBitmapInfo; //
+ W, H: Integer; //
+begin //
+ CreateControl( AParent, 'BUTTON', WS_VISIBLE or WS_CHILD or //
+ WS_TABSTOP or BS_OWNERDRAW, False, @ButtonActions ); //
+ fBitBtnOptions := AOptions; //
+ fGlyphLayout := ALayout; //
+ fGlyphBitmap := AGlyphBitmap; //
+ with fBoundsRect do //
+ begin //
+ Bottom := Top + 22; //
+ W := 0; H := 0; //
+ if AGlyphBitmap <> 0 then //
+ begin //
+ if bboImageList in AOptions then //
+ ImageList_GetIconSize( AGlyphBitmap, W, H ) //
+ else //
+ begin //
+ if GetObject( AGlyphBitmap, Sizeof(B), @B ) > 0 then //
+ begin //
+ W := B.bmiHeader.biWidth; //
+ H := B.bmiHeader.biHeight; //
+ if AGlyphCount = 0 then //
+ AGlyphCount := W div H; //
+ if AGlyphCount > 1 then //
+ W := W div AGlyphCount; //
+ end; //
+ end; //
+ if W > 0 then //
+ if ACaption = '' then //
+ Right := Left + W //
+ else Right := Right + W; //
+ if H > 0 then //
+ Bottom := Top + H; //
+ if not ( bboNoBorder in AOptions ) then //
+ begin //
+ if W > 0 then Inc( Right, 2 ); //
+ if H > 0 then Inc( Bottom, 2 ); //
+ end; //
+ end; //
+ fGlyphWidth := W; //
+ fGlyphHeight := H; //
+ end; //
+ fGlyphCount := AGlyphCount; //
+ if AParent <> nil then //
+ AParent.AttachProc( WndProc_DrawItem ); //
+ AttachProc( WndProcBitBtn ); //
+ fTextAlign := taCenter; //
+ Caption := ACaption; //
+end; //
+ //
+constructor TControl.CreateLabel(AParent: PControl; //
+ const ACaption: AnsiString); //
+begin //
+ CreateControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or //
+ SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, //
+ False, @LabelActions );
+ aAutoSzX := 1;
+ aAutoSzY := 1;
+ {$IFDEF USE_FLAGS} fFlagsG1 := fFlagsG1 + [G1_SizeRedraw, G1_IsStaticControl];
+ {$ELSE} fSizeRedraw := True;
+ fIsStaticControl := 1; //
+ {$ENDIF} //
+ fBoundsRect.Bottom := fBoundsRect.Top + 22; //
+ Caption := ACaption; //
+end; //
+ //
+constructor TControl.CreateWordWrapLabel(AParent: PControl; //
+ const ACaption: AnsiString); //
+begin //
+ CreateLabel( AParent, ACaption ); //
+ fBoundsRect.Bottom := fBoundsRect.Top + 44; //
+ fStyle := fStyle and not SS_LEFTNOWORDWRAP; //
+end; //
+ //
+constructor TControl.CreateLabelEffect(AParent: PControl; ACaption: AnsiString; //
+ AShadowDeep: Integer); //
+begin //
+ CreateLabel( AParent, ACaption ); //
+ {$IFDEF USE_FLAGS} exclude( fFlagsG1, G1_IsStaticControl );
+ {$ELSE} fIsStaticControl := 0; {$ENDIF}
+ AttachProc( WndProcLabelEffect ); //
+ fTextAlign := taCenter; //
+ fTextColor := clBtnShadow; //
+ fShadowDeep := AShadowDeep; //
+ {$IFDEF USE_FLAGS} include( fFlagsG1, G1_IgnoreWndCaption );
+ {$ELSE} fIgnoreWndCaption := True; {$ENDIF} //
+ with fBoundsRect do //
+ begin //
+ Bottom := Top + 40; //
+ end; //
+end; //
+ //
+constructor TControl.CreatePaintBox(AParent: PControl); //
+begin //
+ CreateLabel( AParent, '' ); //
+ with fBoundsRect do //
+ begin //
+ Right := Left + 40; //
+ Bottom := Top + 40; //
+ end; //
+end; //
+ //
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal //
+constructor TControl.CreateGradientPanel(AParent: PControl; AColor1, //
+ AColor2: TColor); //
+begin //
+ CreateLabel( AParent, '' ); //
+ AttachProc( WndProcGradient ); //
+ fColor2 := AColor2; //
+ fColor1 := AColor1; //
+ with fBoundsRect do //
+ begin //
+ Right := Left + 40; //
+ Bottom := Top + 40; //
+ end; //
+end; //
+{$ENDIF PAS_VERSION} //
+ //
+constructor TControl.CreateGradientPanelEx(AParent: PControl; AColor1, //
+ AColor2: TColor; AStyle: TGradientStyle; ALayout: TGradientLayout); //
+begin //
+ CreateLabel( AParent, '' ); //
+ AttachProc( WndProcGradientEx ); //
+ fColor2 := AColor2; //
+ fColor1 := AColor1; //
+ fGradientStyle := AStyle; //
+ fGradientLayout := ALayout; //
+ with fBoundsRect do //
+ begin //
+ Right := Left + 40; //
+ Bottom := Top + 40; //
+ end; //
+end; //
+ //
+constructor TControl.CreateGroupbox(AParent: PControl; //
+ const ACaption: AnsiString); //
+begin //
+ CreateButton( AParent, ACaption ); //
+ with fBoundsRect do //
+ begin //
+ Right := Left + 100; //
+ Bottom := Top + 100; //
+ end; //
+ fStyle := WS_VISIBLE or WS_CHILD or BS_GROUPBOX or WS_TABSTOP; //
+ fClientTop := 22; //
+ fClientLeft := 2; //
+ fClientBottom := 2; //
+ fClientRight := 2; //
+ fTabstop := False; //
+end; //
+ //
+constructor TControl.CreateCheckbox(AParent: PControl; //
+ const ACaption: AnsiString); //
+begin //
+ CreateButton( AParent, ACaption ); //
+ with fBoundsRect do //
+ begin //
+ Right := Left + 72; //
+ end; //
+ fStyle := WS_VISIBLE or WS_CHILD or //
+ BS_AUTOCHECKBOX or WS_TABSTOP; //
+end; //
+ //
+constructor TControl.CreateRadiobox(AParent: PControl; //
+ const ACaption: AnsiString); //
+begin //
+ CreateCheckbox( AParent, ACaption ); //
+ fStyle := WS_VISIBLE or WS_CHILD or //
+ BS_RADIOBUTTON or WS_TABSTOP or WS_GROUP; //
+ fControlClick := ClickRadio; //
+ if AParent <> nil then //
+ begin //
+ AParent.fRadioLast := fMenu; //
+ if AParent.fRadio1st = 0 then //
+ begin //
+ AParent.fRadio1st := fMenu; //
+ SetRadioChecked; //
+ end; //
+ end; //
+end; //
+ //
+constructor TControl.CreateEditbox(AParent: PControl; //
+ AOptions: TEditOptions); //
+var Flags: Integer; //
+begin //
+ Flags := MakeFlags( @AOptions, EditFlags ); //
+ if not(eoMultiline in AOptions) then //
+ Flags := Flags and not(WS_HSCROLL or WS_VSCROLL); //
+ CreateControl( AParent, 'EDIT', WS_VISIBLE or WS_CHILD or WS_TABSTOP //
+ or WS_BORDER or Flags, True, @EditActions ); //
+ aAutoSzY := 6;
+//YS fCursor := LoadCursor( 0, IDC_IBEAM ); // //YS
+ with fBoundsRect do //
+ begin //
+ Right := Left + 100; //
+ Bottom := Top + 22; //
+ if eoMultiline in AOptions then //
+ begin //
+ Right := Right + 100; //
+ Bottom := Top + 200; //
+ end; //
+ end; //
+ fColor := clWindow; //
+ fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ]; //
+ if eoMultiline in AOptions then //
+ fLookTabKeys := [ tkTab ]; //
+ if eoWantTab in AOptions then //
+ exclude( fLookTabKeys, tkTab );
+end; //
+ //
+constructor TControl.CreatePanel(AParent: PControl; AStyle: TEdgeStyle); //
+begin //
+ CreateControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or //
+ SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, False, //
+ @LabelActions );
+ aAutoSzX := 1;
+ aAutoSzY := 1;
+ with fBoundsRect do //
+ begin //
+ Right := Left + 100; //
+ Bottom := Top + 100; //
+ end; //
+ Style := Style or Edgestyles[ AStyle ]; //
+ ExStyle := ExStyle or WS_EX_CONTROLPARENT; //
+end; //
+ //
+constructor TControl.CreateSplitter(AParent: PControl; AMinSizePrev, //
+ AMinSizeNext: Integer; EdgeStyle: TEdgeStyle); //
+var PrevCtrl: PControl; //
+ Sz0: Integer; //
+begin //
+ CreatePanel( AParent, EdgeStyle ); //
+ fSplitMinSize1 := AMinSizePrev; //
+ fSplitMinSize2 := AMinSizeNext; //
+ Sz0 := 4; //
+ with fBoundsRect do //
+ begin //
+ Right := Left + Sz0; //
+ Bottom := Top + Sz0; //
+ end; //
+ if AParent <> nil then //
+ begin //
+ if AParent.fChildren.fCount > 1 then //
+ begin //
+ PrevCtrl := AParent.fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ AParent.fChildren.fCount - 2 ]; //
+ case PrevCtrl.FAlign of //
+ caLeft, caRight: //
+ begin //
+ fCursor := LoadCursor( 0, IDC_SIZEWE ); //
+ end; //
+ caTop, caBottom: //
+ begin //
+ fCursor := LoadCursor( 0, IDC_SIZENS ); //
+ end; //
+ end; //
+ Align := PrevCtrl.FAlign; //
+ end; //
+ end; //
+ AttachProc( WndProcSplitter ); //
+end; //
+ //
+constructor TControl.CreateListbox(AParent: PControl; //
+ AOptions: TListOptions); //
+var Flags: Integer; //
+begin //
+ Flags := MakeFlags( @AOptions, ListFlags ); //
+ CreateControl( AParent, 'LISTBOX', WS_VISIBLE or WS_CHILD or WS_TABSTOP //
+ or WS_BORDER or WS_VSCROLL //
+ or LBS_NOTIFY or Flags, True, @ListActions ); //
+ with fBoundsRect do //
+ begin //
+ Right := Right + 100; //
+ Bottom := Top + 200; //
+ end; //
+ fColor := clWindow; //
+ fLookTabKeys := [ tkTab, tkLeftRight ]; //
+end; //
+ //
+constructor TControl.CreateCombobox(AParent: PControl; //
+ AOptions: TComboOptions); //
+var Flags: Integer; //
+begin //
+ Flags := MakeFlags( @AOptions, ComboFlags ); //
+ CreateControl( AParent, 'COMBOBOX', //
+ WS_VISIBLE or WS_CHILD or WS_VSCROLL or //
+ CBS_DROPDOWN or CBS_HASSTRINGS or WS_TABSTOP or Flags, //
+ True, @ComboActions ); //
+ aAutoSzY := 6;
+ fCreateWndExt := CreateComboboxWnd; //
+ //fDropDownProc := ComboboxDropDown; //
+ fClsStyle := fClsStyle or CS_DBLCLKS; //
+ with fBoundsRect do //
+ begin //
+ Right := Left + 100; //
+ Bottom := Top + 22; //
+ end; //
+ fColor := clWindow; //
+ fLookTabKeys := [ tkTab ]; //
+ if coReadOnly in AOptions then //
+ fLookTabKeys := [ tkTab, tkLeftRight ]; //
+end; //
+ //
+constructor TControl.CreateCommonControl(AParent: PControl; //
+ AClassName: PAnsiChar; AStyle: DWORD; ACtl3D: Boolean; //
+ Actions: PCommandActions); //
+begin //
+ {*************} DoInitCommonControls( ICC_WIN95_CLASSES ); //
+ CreateControl( AParent, AClassName, AStyle, ACtl3D, Actions ); //
+ {$IFDEF USE_FLAGS} include( fFlagsG2, G2_IsCommonCtl );
+ {$ELSE} fIsCommonControl := True; {$ENDIF}
+ if AParent <> nil then //
+ begin //
+ AttachProc( WndProcParentResize ); //
+ AParent.AttachProc( WndProcResize ); //
+ AttachProc( WndProcCommonNotify ); //
+ AParent.AttachProc( WndProcNotify ); //
+ end; //
+end; //
+ //
+constructor TControl.CreateRichEdit1(AParent: PControl; //
+ AOptions: TEditOptions); //
+var Flags, I: Integer; //
+begin //
+ if FRichEditModule = 0 then //
+ begin //
+ for I := 0 to High( RichEditLibnames ) do //
+ begin //
+ FRichEditModule := LoadLibrary( RichEditLibnames[ I ] ); //
+ if FRichEditModule > HINSTANCE_ERROR then break; //
+ RichEditClass := RichEditClasses[ I ]; //
+ end; //
+ if FRichEditModule <= HINSTANCE_ERROR then //
+ FRichEditModule := 0; //
+ end; //
+ Flags := MakeFlags( @AOptions, RichEditFlags ); //
+ CreateCommonControl( AParent, RichEditClass, WS_VISIBLE or WS_CHILD //
+ or WS_TABSTOP or WS_BORDER or ES_MULTILINE or Flags, //
+ True, @RichEditActions ); //
+ //
+ AttachProc( WndProcRichEditNotify ); //
+ {$IFDEF USE_FLAGS} exclude( fFlagsG2, G2_DoubleBuffered );
+ {$ELSE} fDoubleBuffered := False; {$ENDIF}
+ {$IFDEF USE_FLAGS} include( fFlagsG1, G1_CanNotDoublebuf );
+ {$ELSE} fCannotDoubleBuf := True; {$ENDIF} //
+ with fBoundsRect do //
+ begin //
+ Right := Right + 100; //
+ Bottom := Top + 200; //
+ end; //
+ fColor := clWindow; //
+ fLookTabKeys := [ tkTab ]; //
+ if eoWantTab in AOptions then //
+ fLookTabKeys := [ ]; //
+ Perform( EM_SETEVENTMASK, 0, //
+ ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or //
+ ENM_PROTECTED or $04000000 {ENM_LINK} ); //
+ Perform( EM_SETBKGNDCOLOR, 0, Color2RGB(fColor)); //
+end; //
+ //
+constructor TControl.CreateRichEdit(AParent: PControl; //
+ AOptions: TEditOptions); //
+var OldRichEditClass, OldRichEditLib: PAnsiChar; //
+begin //
+ if OleInit then //
+ begin //
+ OldRichEditClass := RichEditClass; //
+ OldRichEditLib := RichEditLib; //
+ CreateRichEdit1( AParent, AOptions ); //
+ fCharFmtDeltaSz := 24; //
+ fParaFmtDeltaSz := sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat ); //
+ RichEditClass := OldRichEditClass; //
+ RichEditLib := OldRichEditLib; //
+ end else //
+ CreateRichEdit1( AParent, AOptions ); //
+end; //
+ //
+constructor TControl.CreateProgressbar(AParent: PControl); //
+const ProgressBarFlags: array[ TProgressbarOption ] of Integer = //
+ (PBS_VERTICAL, PBS_SMOOTH ); //
+begin //
+ CreateCommonControl( AParent, PROGRESS_CLASS, //
+ WS_CHILD or WS_VISIBLE, True, nil ); //
+ with fBoundsRect do //
+ begin //
+ Right := Left + 300; //
+ Bottom := Top + 20; //
+ end; //
+ fMenu := 0; //
+ fTextColor := clHighlight; //
+end; //
+ //
+constructor TControl.CreateProgressbarEx(AParent: PControl; //
+ AOptions: TProgressbarOptions); //
+const ProgressBarFlags: array[ TProgressbarOption ] of Integer = //
+ (PBS_VERTICAL, PBS_SMOOTH ); //
+begin //
+ CreateProgressbar( AParent ); //
+ fStyle := fStyle or DWORD( MakeFlags( @AOptions, ProgressBarFlags ) ); //
+end; //
+ //
+constructor TControl.CreateListView(AParent: PControl; //
+ AStyle: TListViewStyle; AOptions: TListViewOptions; AImageListSmall, //
+ AImageListNormal, AImageListState: PImageList); //
+begin //
+ CreateCommonControl( AParent, WC_LISTVIEW, ListViewStyles[ AStyle ] or //
+ LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE or WS_TABSTOP, //
+ True, @ListViewActions ); //
+ fLVOptions := AOptions; //
+ fLVStyle := AStyle; //
+ fCreateWndExt := ApplyImageLists2ListView; //
+ with fBoundsRect do //
+ begin //
+ Right := Left + 200; //
+ Bottom := Top + 150; //
+ end; //
+ ImageListSmall := AImageListSmall; //
+ ImageListNormal := AImageListNormal; //
+ ImageListState := AImageListState; //
+ fLVTextBkColor := clWindow; //
+ fLookTabKeys := [ tkTab ]; //
+end; //
+ //
+constructor TControl.CreateTreeView(AParent: PControl; //
+ AOptions: TTreeViewOptions; AImgListNormal, AImgListState: PImageList); //
+var Flags: Integer; //
+begin //
+ Flags := MakeFlags( @AOptions, TreeViewFlags ); //
+ CreateCommonControl( AParent, WC_TREEVIEW, Flags or WS_VISIBLE or //
+ WS_CHILD or WS_TABSTOP, True, @TreeViewActions ); //
+ fCreateWndExt := ApplyImageLists2Control; //
+ fColor := clWindow; //
+ AttachProc( WndProcTreeView ); //
+ with fBoundsRect do //
+ begin //
+ Right := Left + 150; //
+ Bottom := Top + 200; //
+ end; //
+ ImageListNormal := AImgListNormal; //
+ ImageListState := AImgListState; //
+ fLookTabKeys := [ tkTab ]; //
+end; ///////////////////////////////////////////////////////////////////////////
+constructor TControl.CreateTabControl(AParent: PControl; ATabs: array of String;//
+ AOptions: TTabControlOptions; //
+ AImgList: PImageList; AImgList1stIdx: Integer); //
+var I, II : Integer; //
+ Flags: Integer; //
+begin Flags := MakeFlags( @AOptions, TabControlFlags ); //
+ if tcoFocusTabs in AOptions then //
+ Flags := Flags or (WS_TABSTOP or TCS_FOCUSONBUTTONDOWN); //
+ CreateCommonControl( AParent, WC_TABCONTROL, //
+ Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or //
+ WS_VISIBLE), True, @TabControlActions ); //
+ if not( tcoBorder in AOptions ) then //
+ fExStyle := fExStyle and not WS_EX_CLIENTEDGE; //
+ AttachProc( WndProcTabControl ); //
+ with fBoundsRect do //
+ begin //
+ Right := Left + 100; //
+ Bottom := Top + 100; //
+ end; //
+ if AImgList <> nil then //
+ Perform( TCM_SETIMAGELIST, 0, AImgList.Handle ); //
+ II := AImgList1stIdx; //
+ for I := 0 to High( ATabs ) do //
+ begin //
+ TC_Insert( I, ATabs[ I ], II ); //
+ Inc( II ); //
+ end; //
+ fLookTabKeys := [ tkTab ]; //
+end; ///////////////////////////////////////////////////////////////////////////
+constructor TControl.CreateToolbar(AParent: PControl; //
+ AAlign: TControlAlign; AOptions: TToolbarOptions; ABitmap: HBitmap; //
+ AButtons: array of PAnsiChar; ABtnImgIdxArray: array of Integer); //
+var Flags: DWORD; //
+begin //
+ if not( tboTextBottom in AOptions ) then //
+ include( AOptions, tboTextRight );
+ if tboTextRight in AOptions then //
+ exclude( AOptions, tboTextBottom );
+ Flags := MakeFlags( @AOptions, ToolbarOptions ); //
+ CreateCommonControl( AParent, TOOLBARCLASSNAME, ToolbarAligns[ Align ] or //
+ WS_CHILD or WS_VISIBLE {or WS_TABSTOP} //
+ or TBSTYLE_TOOLTIPS or Flags, //
+ (not (Align in [caNone])) and //
+ not (tboNoDivider in AOptions), nil ); //
+ fCommandActions.aClear := ClearToolbar; //
+ fCommandActions.aGetCount := TB_BUTTONCOUNT; //
+ with fBoundsRect do //
+ begin if AAlign in [ caNone ] then //
+ begin Bottom := Top + 26; //
+ Right := Left + 1000; //
+ end else //
+ begin Left := 0; Right := 0; //
+ Top := 0; Bottom := 0; //
+ end; //
+ end; //
+ Perform(TB_SETEXTENDEDSTYLE, 0, Perform(TB_GETEXTENDEDSTYLE, 0, 0) or //
+ TBSTYLE_EX_DRAWDDARROWS); //
+ AttachProc( WndProcToolbarCtrl ); //
+ Perform( TB_BUTTONSTRUCTSIZE, Sizeof( TTBButton ), 0 ); //
+ Perform( TB_SETINDENT, fMargin, 0 ); //
+ with fBoundsRect do //
+ begin //
+ if AAlign in [ caLeft, caRight ] then //
+ Right := Left + 24 //
+ else if not (AAlign in [caNone]) then //
+ Bottom := Top + 22; //
+ end; //
+ if ABitmap <> 0 then //
+ TBAddBitmap( ABitmap ); //
+ TBAddButtons( AButtons, ABtnImgIdxArray ); //
+ Perform( WM_SIZE, 0, 0 ); //
+end; ///////////////////////////////////////////////////////////////////////////
+constructor TImageList.CreateImageList(POwner: Pointer); //
+var AOwner: PControl; //
+begin {*************} DoInitCommonControls( ICC_WIN95_CLASSES ); //
+ Create; //
+ FAllocBy := 1; //
+ FMasked := True; //
+ if POwner = nil then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ FBkColor := TColor( CLR_NONE );
+ AOwner := POwner; //
+ FControl := AOwner; //
+ fNext := PImageList( AOwner.fImageList ); //
+ if AOwner.fImageList <> nil then //
+ PImageList( AOwner.fImageList ).fPrev := @Self; //
+ AOwner.fImageList := @Self; //
+end;////////////////////////////////////////////////////////////////////////////
+constructor TThread.ThreadCreate; //
+begin IsMultiThread := True; //
+ Create; //
+ FSuspended := True; //
+ FHandle := CreateThread( nil, // no security //
+ 0, // the same stack size //
+ @ThreadFunc, // thread entry point //
+ @Self, // parameter to pass to ThreadFunc //
+ CREATE_SUSPENDED, // always SUSPENDED //
+ FThreadID ); // receive thread ID //
+end;////////////////////////////////////////////////////////////////////////////
+constructor TThread.ThreadCreateEx( const Proc: TOnThreadExecute ); //
+begin //
+ ThreadCreate; //
+ OnExecute := Proc; //
+ Resume; //
+end; //
+{$ENDIF USE_CONSTRUCTORS} //****************************************************//
+procedure InvalidateExW( Wnd: HWnd );
+begin InvalidateRect( Wnd, nil, TRUE );
+ Wnd := GetWindow( Wnd, GW_CHILD );
+ while Wnd <> 0 do
+ begin
+ InvalidateExW( Wnd );
+ Wnd := GetWindow( Wnd, GW_HWNDNEXT );
+ end;
+end; ///////////////////////////////////////////////////////////////////////////
+procedure TControl.InvalidateEx;
+begin if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ InvalidateExW( fHandle );
+end; ///////////////////////////////////////////////////////////////////////////
+procedure InvalidateNCW( Wnd: HWnd; Recursive: Boolean );
+begin SendMessage( Wnd, WM_NCPAINT, 1, 0 );
+ if not Recursive then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Wnd := GetWindow( Wnd, GW_CHILD );
+ while Wnd <> 0 do
+ begin
+ InvalidateNCW( Wnd, Recursive );
+ Wnd := GetWindow( Wnd, GW_HWNDNEXT );
+ end;
+end; ///////////////////////////////////////////////////////////////////////////
+procedure TControl.InvalidateNC(Recursive: Boolean);
+begin
+ if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ InvalidateNCW( fHandle, Recursive );
+end; ///////////////////////////////////////////////////////////////////////////
+procedure TControl.SetClientMargin(const Index: Integer; Value: ShortInt);
+begin
+ case Index of
+ 1: fClientTop := Value;
+ 2: fClientBottom := Value;
+ 3: fClientLeft := Value;
+ 4: fClientRight := Value;
+ end;
+ {$IFNDEF OLD_ALIGN}include(fAligning,oaFromSelf);{$ENDIF}//???
+ Global_Align( @Self );
+end;
+{$IFDEF F_P}
+function TControl.GetClientMargin(const Index: Integer): Integer;
+begin
+ CASE Index OF
+ 1: Result := fClientTop;
+ 2: Result := fClientBottom;
+ 3: Result := fClientLeft;
+ 4: Result := fClientRight;
+ END;
+end;
+{$ENDIF F_P}
+{------------------------------------------------------------------------------}
+{ G R A P H C O N T R O L S }
+{------------------------------------------------------------------------------}
+type TGrayTextData = packed record
+ Ctl: PControl;
+ W, H: Integer;
+ Flags: DWORD;
+ end;
+ PGrayTextData = ^TGrayTextData; ///////////////////////////////////////////
+function DrawTextGrayed( DC: HDC; lData, wData, cX, cY: Integer ): BOOL; stdcall;
+var GDT: PGrayTextData;
+ R: TRect;
+begin
+ GDT := Pointer( lData );
+ R := MakeRect( 0, 0, cX, cY );
+ DrawFormattedText( GDT.Ctl, DC, R, GDT.Flags or $80000000 );
+ Result := TRUE;
+end; ///////////////////////////////////////////////////////////////////////////
+procedure DrawFormattedText( Ctl: PControl; DC: HDC; var R: TRect; Flags: DWORD {EditCtl: Boolean} );
+var Fmt: DWORD;
+ OldFont: Integer;
+ OldBrush: Integer;
+ OldBk: Integer;
+ ParentHavingFont: PControl;
+ GTD: TGrayTextData;
+ dX, dY: Integer;
+ R1: TRect;
+begin Fmt := DT_EXPANDTABS or Flags and $7FFFFFFF;
+ if Ctl.WordWrap then
+ Fmt := Fmt or DT_WORDBREAK;
+ if Flags and DT_EDITCONTROL <> 0 then
+ Inc( R.Left, 4 );
+ ParentHavingFont := Ctl;
+ while (ParentHavingFont <> nil) and ( ParentHavingFont.FFont = nil )
+ and {$IFDEF USE_FLAGS} not(G3_IsForm in ParentHavingFont.fFlagsG3)
+ {$ELSE} not ParentHavingFont.IsForm {$ENDIF} do
+ ParentHavingFont := ParentHavingFont.Parent;
+ OldFont := 0;
+ if ( ParentHavingFont <> nil ) then
+ begin OldFont := SelectObject( DC, ParentHavingFont.Font.Handle );
+ SetTextColor( DC, ParentHavingFont.Font.FColorRGB );
+ end;
+ R1 := R;
+ {$IFDEF UNICODE_CTRLS}Windows.DrawTextW
+ {$ELSE} Windows.DrawTextA
+ {$ENDIF}( DC, PKOLChar( Ctl.Caption ), Length( Ctl.Caption ), R,
+ Fmt or DT_CALCRECT ); // TODO: fixme (Length('kanji') != WStrLen('kanji'))
+ CASE Ctl.fTextAlign OF
+ taCenter: dX := (R1.Right - R1.Left - (R.Right - R.Left)) div 2;
+ taRight: dX := R1.Right - R.Right;
+ else dX := 0;
+ END;
+ CASE Ctl.fVerticalAlign OF
+ vaCenter: dY := (R1.Bottom - R1.Top - (R.Bottom - R.Top)) div 2;
+ vaBottom: dY := R1.Bottom - R.Bottom;
+ else dY := 0;
+ END;
+ OffsetRect( R, dX, dY );
+ if {$IFDEF USE_FLAGS} not(F3_Disabled in Ctl.fStyle.f3_Style)
+ {$ELSE} Ctl.fEnabled {$ENDIF}
+ or (Flags and $80000000 <> 0) then
+ begin OldBk := SetBkMode( DC, TRANSPARENT );
+ OldBrush := SelectObject( DC, GetStockObject( NULL_BRUSH ) );
+ {$IFDEF UNICODE_CTRLS}Windows.DrawTextW
+ {$ELSE} Windows.DrawTextA
+ {$ENDIF}( DC, PKOLChar( Ctl.Caption ), Length( Ctl.Caption ), R, Fmt );
+ SelectObject( DC, OldBrush );
+ SetBkMode( DC, OldBk );
+ end else
+ begin GTD.Ctl := Ctl;
+ GTD.W := R.Right - R.Left;
+ GTD.H := R.Bottom - R.Top;
+ GTD.Flags := Flags;
+ Windows.DrawState( DC, GetStockObject( NULL_BRUSH ), @ DrawTextGrayed,
+ Integer( @ GTD ), Length( Ctl.fCaption ), R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top,
+ DST_COMPLEX or DSS_DISABLED );
+ end;
+ if ( ParentHavingFont <> nil ) then
+ SelectObject( DC, OldFont );
+end;
+
+{$IFDEF USE_GRAPHCTLS}
+{$IFDEF GRAPHCTL_XPSTYLES}
+type TOpenThemeDataProc = function( Wnd: HWnd; pszClassList: PWideChar ): THandle;
+ stdcall;
+ TDrawThemeBackground = function( Theme: THandle; DC: HDC; iPartId: Integer;
+ iStateId: Integer; Rect, ClipRect: PRect ): Integer;
+ stdcall;
+ TGetThemeBackgroundContentRect = function( Theme: THandle; DC: HDC;
+ iPartId, iStateId: Integer; Rect, ContentRect: PRect ):
+ Integer; stdcall;
+ TDrawThemeText = function( Theme: THandle; DC: HDC; iPartId, iStateId: Integer;
+ pszText: PWideChar; iCharCount: Integer;
+ dwTextFlags, dwTextFlags2: DWORD; Rect: PRect ): Integer;
+ stdcall;
+ TCloseThemeData = function( Theme: THandle ): Integer; stdcall;
+var fOpenThemeDataProc: TOpenThemeDataProc;
+ fDrawthemeBackground: TDrawThemeBackground;
+ fGetThemeBackgroundcontentRect: TGetThemeBackgroundContentRect;
+ fDrawThemeText: TDrawThemeText;
+ fCloseThemeData: TCloseThemeData;
+ uxtheme_lib: THandle;
+function OpenThemeDataProc: TOpenThemeDataProc;
+begin Result := nil;
+ if Integer(uxtheme_lib) = -1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if uxtheme_lib = 0 then
+ uxtheme_lib := LoadLibrary( 'uxtheme' );
+ if uxtheme_lib = 0 then
+ begin uxtheme_lib := DWORD( -1 ); Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ fOpenThemeDataProc := GetProcAddress( uxtheme_lib, 'OpenThemeData' );
+ fDrawthemeBackground := GetProcAddress( uxtheme_lib, 'DrawThemeBackground' );
+ fGetThemeBackgroundcontentRect := GetProcAddress( uxtheme_lib, 'GetThemeBackgroundContentRect' );
+ fDrawThemeText := GetProcAddress( uxtheme_lib, 'DrawThemeText' );
+ fCloseThemeData := GetProcAddress( uxtheme_lib, 'CloseThemeData' );
+ if not Assigned( fOpenThemeDataProc ) or
+ not Assigned( fDrawThemeBackground ) or
+ not Assigned( fGetThemeBackgroundcontentRect ) or
+ not Assigned( fDrawThemeText ) or
+ not Assigned( fCloseThemeData ) then
+ begin
+ FreeLibrary( uxtheme_lib );
+ uxtheme_lib := DWORD( -1 );
+ fOpenThemeDataProc := nil;
+ fDrawThemeBackground := nil;
+ fGetThemeBackgroundcontentRect := nil;
+ fDrawThemeText := nil;
+ fCloseThemeData := nil;
+ end;
+ Result := fOpenThemeDataProc;
+end;
+
+procedure DrawFormattedTextXP( Theme: THandle; Ctl: PControl; DC: HDC;
+ var R: TRect; CtlType, CtlStates, Flags1, Flags2: Integer );
+var OldFont: Integer;
+ OldBrush: Integer;
+ ParentHavingFont: PControl;
+begin ParentHavingFont := Ctl;
+ while (ParentHavingFont <> nil) and ( ParentHavingFont.FFont = nil )
+ and {$IFDEF USE_FLAGS} not(G3_IsForm in ParentHavingFont.fFlagsG3)
+ {$ELSE} not ParentHavingFont.IsForm {$ENDIF} do
+ ParentHavingFont := ParentHavingFont.Parent;
+ OldFont := 0;
+ if ( ParentHavingFont <> nil ) then
+ OldFont := SelectObject( DC, ParentHavingFont.Font.Handle );
+ OldBrush := SelectObject( DC, GetStockObject( NULL_BRUSH ) );
+ fDrawThemeText( Theme, DC, CtlType, CtlStates, @ KOLWideString( Ctl.fCaption )[ 1 ],
+ Length( Ctl.fCaption ), Flags1, Flags2, @ R );
+ SelectObject( DC, OldBrush );
+ if ( ParentHavingFont <> nil ) then SelectObject( DC, OldFont );
+end;
+{$ENDIF}
+
+procedure PaintGraphicChildren( Self_, _Sender: PControl; DC: HDC );
+var i, sav: Integer;
+ C: PControl;
+ R: TRect;
+ rgn: HRgn;
+begin
+ for i := Self_.ChildCount-1 downto 0 do
+ begin
+ C := Self_.Children[ i ];
+ if not C.Visible then continue;
+ R := C.BoundsRect;
+ if (C.Handle = 0)
+ and {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6)
+ {$ELSE} not C.fWindowed {$ENDIF}
+ {$IFDEF SAFE_CODE} and Assigned( C.EV.fPaintProc ) {$ENDIF} then
+ begin
+ sav := SaveDC( DC );
+ rgn := CreateRectRgnIndirect( R );
+ ExtSelectClipRgn( DC, rgn, RGN_AND );
+ SelectClipRgn( DC, rgn );
+ DeleteObject( rgn );
+ Free_And_Nil( C.fCanvas );
+ C.fCanvas := Self_.Canvas;
+ Self_.Canvas.Brush.Assign( Self_.Brush );
+ Self_.Canvas.Font.Assign( Self_.Font ); // не присваивается?
+ Self_.fCanvas.DeselectHandles; // не помогает???
+ {$IFDEF NIL_EVENTS}
+ if Assigned( C.EV.fOnPrepaint ) then
+ {$ENDIF}
+ C.EV.fOnPrePaint( C, DC );
+ C.EV.fPaintProc( DC );
+ if Assigned( C.EV.fOnPaint ) then
+ C.EV.fOnPaint( C, DC );
+ {$IFDEF NIL_EVENTS}
+ if Assigned( C.EV.fOnPostPaint ) then
+ {$ENDIF}
+ C.EV.fOnPostPaint( C, DC );
+ C.fCanvas := nil;
+ Self_.Canvas.Brush.Assign( Self_.Brush );
+ Self_.Canvas.Font.Assign( Self_.Font );
+ RestoreDC( DC, sav );
+ ExcludeClipRect( DC, R.Left, R.Top, R.Right, R.Bottom );
+ end;
+ end;
+ if {$IFDEF USE_FLAGS} G5_IsGroupbox in Self_.fFlagsG5
+ {$ELSE} Self_.fIsGroupBox {$ENDIF} then
+ begin
+ Self_.DF.fErasingBkgnd := TRUE;
+ R := Self_.BoundsRect;
+ OffsetRect( R, -R.Left, -R.Top );
+ Self_.Canvas.FillRect( R );
+ Self_.GroupBoxPaint( DC );
+ Self_.DF.fErasingBkgnd := FALSE;
+ end else
+ if Assigned( Self_.EV.fOnPaint2 ) then
+ Self_.EV.fOnPaint2( Self_, DC )
+ else Self_.Canvas.FillRect( Self_.ClientRect );
+end;
+
+function WndProc_ParentOfGraphicCtl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var WasOnPaint: TOnPaint;
+ i: Integer;
+ C: PControl;
+ Pt: TPoint;
+ PF: PControl;
+ save_Paint2: TOnPaint;
+begin
+ Result := FALSE;
+ if (Msg.message = WM_PAINT) {or (Msg.message = WM_PRINT)} then
+ begin WasOnPaint := Self_.EV.fOnPaint;
+ Self_.{$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnPaint2 := Self_.EV.fOnPaint;
+ //Self_.fPaintMsg := Msg;
+ {$IFDEF MAKE_METHOD}
+ TMethod( Self_.EV.fOnPaint ) := MakeMethod( Self_, @ PaintGraphicChildren );
+ {$ELSE}
+ TMethod( Self_.EV.fOnPaint ).Code := @ PaintGraphicChildren;
+ TMethod( Self_.EV.fOnPaint ).Data := Self_;
+ {$ENDIF}
+ save_Paint2 := Self_.EV.fOnPaint2;
+ if not Assigned( Self_.EV.fOnPaint2 ) then
+ begin
+ {$IFDEF MAKE_METHOD}
+ Self_.EV.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyPaintClear ) );
+ {$ELSE}
+ TMethod( Self_.EV.fOnPaint2 ).Code := @ DummyPaintClear;
+ //TMethod( Self_.EV.fOnPaint2 ).Data := nil;
+ {$ENDIF}
+ end;
+ i := Self_.fDynHandlers.fCount;
+ Self_.fDynHandlers.fCount := Self_.fDynHandlers.IndexOf( @ WndProc_ParentOfGraphicCtl );
+ Result := EnumDynHandlers( Self_, Msg, Rslt );
+ Self_.fDynHandlers.fCount := i;
+ if not Result then
+ {Result :=} WndProcPaint( Self_, Msg, Rslt );
+ Self_.EV.fOnPaint := WasOnPaint;
+ Result := TRUE;
+ end else
+ if (Msg.message >= WM_MOUSEFIRST) and (Msg.message <= WM_MOUSELAST) then
+ begin
+ Pt.X := SmallInt( LoWord( Msg.lParam ) );
+ Pt.Y := SmallInt( HiWord( Msg.lParam ) );
+ for i := 0 to Self_.ChildCount-1 do
+ begin
+ if (i = 0) and (Self_.fPushedBtn <> nil) then
+ C := Self_.fPushedBtn
+ else C := Self_.Children[ i ];
+ if (C = Self_.fPushedBtn) OR
+ {$IFDEF USE_FLAGS}
+ (F3_Visible in C.fStyle.f3_Style)
+ and not (F3_Disabled in C.fStyle.f3_Style)
+ {$ELSE} C.fVisible and C.fEnabled {$ENDIF}
+ and PtInRect( C.BoundsRect, Pt ) then
+ begin
+ if {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6)
+ {$ELSE} not C.fWindowed {$ENDIF}
+ and (C.fCursor <> 0) and (C.fCursor <> Self_.fCursor) and
+ (ScreenCursor = 0) then
+ begin if Self_.fSaveCursor = 0 then
+ begin Self_.fSaveCursor := Self_.fCursor;
+ if Self_.fCursor = 0 then
+ Self_.fSaveCursor := LoadCursor( 0, IDC_ARROW );
+ end;
+ Self_.Cursor := C.fCursor;
+ Windows.SetCursor( C.fCursor );
+ end;
+ {$IFDEF GRAPHCTL_HOTTRACK}
+ if {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6)
+ {$ELSE} not C.fWindowed {$ENDIF}
+ and (Applet.DF.fHotCtl <> C) then
+ begin
+ if Applet.DF.fHotCtl <> nil then
+ begin
+ {$IFDEF USE_FLAGS}
+ exclude( Applet.DF.fHotCtl.fFlagsG4, G4_Hot );
+ {$ELSE} Applet.DF.fHotCtl.fHot := FALSE; {$ENDIF}
+ if {$IFDEF USE_FLAGS} (G6_GraphicCtl in Applet.DF.fHotCtl.fFlagsG6)
+ {$ELSE} not Applet.DF.fHotCtl.fWindowed {$ENDIF} then
+ begin
+ Applet.DF.fHotCtl.Invalidate;
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Applet.DF.fHotCtl.EV.fOnMouseLeave ) then
+ {$ENDIF}
+ Applet.DF.fHotCtl.EV.fOnMouseLeave( Applet.DF.fHotCtl );
+ end;
+ Applet.DF.fHotCtl.RefDec;
+ end;
+ C.RefInc;
+ Applet.DF.fHotCtl := C;
+ {$IFDEF USE_FLAGS} include( C.fFlagsG4, G4_Hot );
+ {$ELSE} C.fHot := TRUE; {$ENDIF}
+ C.Invalidate;
+ Self_.EV.fMouseLeaveProc := Self_.MouseLeaveFromParentOfGraphCtl;
+ ProvideMouseEnterLeave( Self_ );
+ {$IFDEF NIL_EVENTS}
+ if Assigned( C.EV.fOnMouseEnter ) then
+ {$ENDIF}
+ C.EV.fOnMouseEnter( C );
+ end;
+ {$ENDIF GRAPHCTL_HOTTRACK}
+ if {$IFDEF USE_FLAGS} not(G6_GraphicCtl in C.fFlagsG6)
+ {$ELSE} C.fWindowed {$ENDIF} then
+ begin
+ Msg.hwnd := C.fHandle;
+ Pt := Self_.Client2Screen( Pt );
+ Pt := C.Screen2Client( Pt );
+ Msg.lParam := Pt.Y shl 16 or (Pt.X and $FFFF);
+ end;
+ Rslt := C.WndProc( Msg );
+ if {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6)
+ {$ELSE} not C.fWindowed {$ENDIF} then
+ {$IFDEF NIL_EVENTS}
+ if Assigned( C.EV.fGraphCtlMouseEvent ) then
+ {$ENDIF}
+ C.EV.fGraphCtlMouseEvent( Msg )
+ else if (Msg.message = WM_LBUTTONDOWN) or
+ (Msg.message = WM_RBUTTONDOWN) or
+ (Msg.message = WM_MBUTTONDOWN) then C.DoClick;
+ Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ end;
+ {$IFDEF GRAPHCTL_HOTTRACK}
+ Self_.MouseLeaveFromParentOfGraphCtl( Self_ );
+ {$ENDIF GRAPHCTL_HOTTRACK}
+ if {$IFDEF USE_FLAGS} (G5_IsGroupbox in Self_.fFlagsG5)
+ {$ELSE} Self_.fIsGroupBox {$ENDIF}
+ and (
+ (Msg.message = WM_LBUTTONDOWN) or
+ (Msg.message = WM_LBUTTONDBLCLK) or
+ (Msg.message = WM_LBUTTONUP)
+ ) then
+ begin
+ Self_.Invalidate;
+ end;
+ if Self_.fSaveCursor <> 0 then
+ begin Self_.Cursor := Self_.fSaveCursor;
+ Self_.fSaveCursor := 0;
+ if ScreenCursor = 0 then Windows.SetCursor( Self_.fCursor );
+ end;
+ end else
+ if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
+ begin
+ if Self_.IsControl then
+ PF := Self_.ParentForm
+ else PF := Self_;
+ if (PF.DF.fCurrentControl <> nil)
+ and {$IFDEF USE_FLAGS} (G6_GraphicCtl in PF.DF.fCurrentControl.fFlagsG6)
+ {$ELSE} not PF.DF.fCurrentControl.fWindowed {$ENDIF} then
+ begin if Assigned( PF.DF.fCurrentControl.fKeyboardProcess ) and
+ PF.DF.fCurrentControl.fKeyboardProcess( Msg, Rslt ) then
+ else Rslt := PF.DF.fCurrentControl.WndProc( Msg );
+ Result := TRUE;
+ end else
+ begin
+ if {$IFDEF USE_FLAGS} (G5_IsGroupbox in Self_.fFlagsG5)
+ {$ELSE} Self_.fIsGroupBox {$ENDIF}
+ and (Msg.wParam = WORD( ' ' )) and
+ (
+ (Msg.message = WM_KEYDOWN) or
+ (Msg.message = WM_SYSKEYDOWN) or
+ (Msg.message = WM_KEYUP) or
+ (Msg.message = WM_SYSKEYUP) or
+ (Msg.message = WM_CHAR) or
+ (Msg.message = WM_SYSCHAR)
+ ) then
+ begin
+ Self_.Invalidate;
+ end;
+ end;
+ end else
+ if Msg.message = CM_QUIT then
+ begin
+ C := Pointer( Msg.wParam );
+ C.Free;
+ end else
+ if Msg.message = CM_FOCUSGRAPHCTL then
+ begin
+ C := Pointer( Msg.wParam );
+ PF := C.ParentForm;
+ if (PF.DF.fCurrentControl <> nil) and (PF.DF.fCurrentControl <> C) then
+ begin
+ {$IFDEF USE_FLAGS}
+ exclude( PF.DF.fCurrentControl.fFlagsG6, G6_Focused );
+ {$ELSE} PF.DF.fCurrentControl.fFocused := FALSE; {$ENDIF}
+ PF.DF.fCurrentControl.Invalidate;
+ end;
+ PF.DF.fCurrentControl := C;
+ C.Parent.DF.fCurrentControl := C;
+ //C.Parent.fFocusHandle := C.Parent.fHandle;
+ {$IFDEF USE_FLAGS} include( C.fFlagsG6, G6_Focused );
+ {$ELSE} C.fFocused := TRUE; {$ENDIF}
+ if Assigned( C.EV.fOnEnter ) then
+ C.EV.fOnEnter( C );
+ C.Invalidate;
+ C.EV.fLeave := C.LeaveGraphButton;
+ C.RefDec;
+ end;
+end;////////////////////////////////////////////////////////////////////////////
+function WndProc_FormHavingGraphCtl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
+var Msg2: TMsg;
+begin Result := FALSE;
+ if Msg.message = WM_ACTIVATE then
+ begin if Self_.DF.fCurrentControl <> nil then
+ Self_.DF.fCurrentControl.Invalidate;
+ end else
+ if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
+ begin if (Self_.DF.fCurrentControl <> nil)
+ and {$IFDEF USE_FLAGS} (G6_GraphicCtl in Self_.DF.fCurrentControl.fFlagsG6)
+ {$ELSE} not Self_.DF.fCurrentControl.fWindowed {$ENDIF} then
+ begin if (Msg.message = WM_KEYDOWN) and ((Msg.wParam = 32) or (Msg.wParam = 13)) then
+ begin if not PeekMessage( Msg2, Msg.hwnd, WM_CHAR, WM_CHAR, pm_noRemove )
+ or (Msg2.wParam <> Msg.wParam) then
+ Msg.message := WM_CHAR;
+ end else
+ if (Msg.message = WM_SYSKEYDOWN) and ((Msg.wParam = 32) or (Msg.wParam = 13)) then
+ begin if not PeekMessage( Msg2, Msg.hwnd, WM_SYSCHAR, WM_SYSCHAR, pm_noRemove ) or
+ (Msg2.wParam <> Msg.wParam) then
+ Msg.message := WM_SYSCHAR;
+ end;
+ if Assigned( Self_.DF.fCurrentControl.fKeyboardProcess ) and
+ Self_.DF.fCurrentControl.fKeyboardProcess( Msg, Rslt ) then
+ else Rslt := Self_.DF.fCurrentControl.WndProc( Msg );
+ Result := TRUE;
+ end;
+ end;
+end;////////////////////////////////////////////////////////////////////////////
+{$IFDEF GRAPHCTL_HOTTRACK}
+procedure TControl.MouseLeaveFromParentOfGraphCtl(Sender: PObj);
+var C: PControl;
+ Pt: TPoint;
+begin
+ if AppletTerminated then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ GetCursorPos( Pt );
+ Pt := Screen2Client( Pt );
+ if (Applet.DF.fHotCtl <> nil) and (fChildren.IndexOf( Applet.DF.fHotCtl ) >= 0) then
+ begin
+ C := Applet.DF.fHotCtl;
+ if PtInRect( C.BoundsRect, Pt ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Applet.DF.fHotCtl := nil;
+ {$IFDEF USE_FLAGS} exclude( C.fFlagsG4, G4_Hot );
+ {$ELSE} C.fHot := FALSE; {$ENDIF}
+ if {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6)
+ {$ELSE} not C.fWindowed {$ENDIF} then
+ C.Invalidate;
+ if Assigned( C.OnMouseLeave ) then
+ C.OnMouseLeave( C );
+ C.RefDec;
+ end;
+end;
+{$ENDIF GRAPHCTL_HOTTRACK}
+
+procedure NotifyGraphCtlAboutNewParent(Prnt, Chld: PControl);
+begin
+ if (Chld <> nil) and (Prnt <> nil) then
+ Prnt.AttachProc( WndProc_ParentOfGraphicCtl );
+end;
+
+function _NewGraphCtl( AParent: PControl; ATabStop: Boolean;
+ ACommandActions: TCommandActionsParam ): PControl;
+var IdxActions: Integer;
+begin new( Result, Create );
+ {$IFDEF DEBUG_OBJKIND} Result.fObjKind := 'TControl:GraphicControl';
+ {$ENDIF}
+ {$IFDEF COMMANDACTIONS_OBJ}
+ IdxActions := Integer( ACommandActions );
+ if IdxActions >= 120 then
+ IdxActions := PByte( ACommandActions )^;
+ if AllActions_Objs[IdxActions] <> nil then
+ begin Result.fCommandActions := AllActions_Objs[IdxActions];
+ Result.fCommandActions.RefInc;
+ end else
+ begin new( Result.fCommandActions, Create );
+ {$IFDEF DEBUG_OBJKIND}
+ 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}
+ {$IFDEF USE_FLAGS}
+ include( Result.fFlagsG3, G3_IsControl );
+ include( Result.fFlagsG4, G4_CreateVisible );
+ if ATabStop then
+ include( Result.fStyle.f2_Style, F2_TabStop );
+ {$ELSE} Result.fCreateVisible := TRUE;
+ Result.fVisible := TRUE;
+ Result.fIsControl := TRUE;
+ Result.fTabstop := ATabStop;
+ {$ENDIF}
+ Result.fMenu := CtlIdCount;
+ Inc( CtlIdCount );
+ Result.DF.fBitBtnOptions := [ bboFixed ]; // to return Checked = fChecked w/o window handle
+ {$IFDEF USE_FLAGS}
+ Result.fFlagsG1 := Result.fFlagsG1 + [ G1_IgnoreWndCaption, G1_SizeRedraw ];
+ {$ELSE} Result.fIgnoreWndCaption := TRUE;
+ Result.fSizeRedraw := TRUE;
+ {$ENDIF}
+ Result.PP.fNotifyChild := @ NotifyGraphCtlAboutNewParent;
+ if ATabStop then
+ Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ];
+ if AParent <> nil then
+ begin Result.Parent := AParent;
+ Result.Border := AParent.Border;
+ AParent.AttachProc( WndProc_ParentOfGraphicCtl );
+ if ATabStop then
+ begin Inc( AParent.ParentForm.fTabOrder );
+ Result.fTabOrder := AParent.ParentForm.fTabOrder;
+ end;
+ if {$IFDEF USE_FLAGS} G3_IsControl in AParent.fFlagsG3
+ {$ELSE} AParent.fIsControl {$ENDIF} then
+ AParent.ParentForm.AttachProc( WndProc_FormHavingGraphCtl );
+ if {$IFDEF USE_FLAGS} G5_IsGroupbox in APArent.fFlagsG5
+ {$ELSE} AParent.fIsGroupBox {$ENDIF} then
+ begin AParent.Style := AParent.Style and
+ not BS_GROUPBOX; // otherwise the groupbox is flickering A LOT!
+ AParent.Parent.AttachProc( WndProc_ParentOfGraphicCtl );
+ end;
+
+ Result.fFont := Result.fFont.Assign( AParent.fFont );
+ if Result.fFont <> nil then
+ begin Result.fFont.fParentGDITool := AParent.fFont;
+ Result.fFont.fOnGTChange := Result.FontChanged;
+ Result.FontChanged( Result.fFont );
+ end;
+ end;
+ Result.fBoundsRect.Right := Result.fBoundsRect.Left + 64;
+ Result.fBoundsRect.Bottom := Result.fBoundsRect.Top + 22;
+ Result.EV.fOnPaint := nil;
+
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ if WinVer < wvXP then
+ DoNotDrawGraphCtlsUsingXPStyles := TRUE;
+ {$ENDIF}
+end;////////////////////////////////////////////////////////////////////////////
+function NewGraphLabel( AParent: PControl; const ACaption: AnsiString ): PControl;
+begin {$IFDEF INPACKAGE} Result := NewLabel( AParent, ACaption );
+ {$ELSE} Result := _NewGraphCtl( AParent, FALSE,
+ {$IFDEF PACK_COMMANDACTIONS} LabelActions_Packed
+ {$ELSE} @LabelActions {$ENDIF} );
+ Result.aAutoSzX := 1;
+ Result.aAutoSzY := 1;
+ Result.EV.fPaintProc := Result.GraphicLabelPaint;
+ Result.Caption := ACaption;
+ {$ENDIF}
+end;////////////////////////////////////////////////////////////////////////////
+function NewWordWrapGraphLabel( AParent: PControl; const ACaption: KOLString ): PControl;
+begin {$IFDEF INPACKAGE} Result := NewWordWrapLabel( AParent, ACaption );
+ {$ELSE} Result := NewGraphLabel( AParent, ACaption );
+ {$IFDEF USE_FLAGS} include( Result.fFlagsG1, G1_WordWrap );
+ {$ELSE} Result.fWordWrap := TRUE; {$ENDIF}
+ {$ENDIF}
+end;////////////////////////////////////////////////////////////////////////////
+function NewGraphPaintBox( AParent: PControl ): PControl;
+begin {$IFDEF INPACKAGE} Result := NewPaintbox( AParent );
+ {$ELSE} Result := NewGraphLabel( AParent, '' ); {$ENDIF}
+end;////////////////////////////////////////////////////////////////////////////
+procedure ClickGraphCheck(Sender: PObj);
+var Ctl: PControl;
+begin Ctl := Pointer( Sender );
+ if not Ctl.Enabled then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Ctl.Focused := TRUE;
+ if Assigned( Ctl.OnEnter ) then
+ Ctl.OnEnter( Ctl );
+ {$IFDEF USE_FLAGS}
+ if G4_Checked in Ctl.fFlagsG4 then
+ exclude( Ctl.fFlagsG4, G4_Checked )
+ else include( Ctl.fFlagsG4, G4_Checked );
+ {$ELSE} Ctl.fChecked := not Ctl.fChecked; {$ENDIF}
+ Ctl.Invalidate;
+ if Assigned( Ctl.OnClick ) then
+ Ctl.OnClick( Ctl );
+end;////////////////////////////////////////////////////////////////////////////
+function NewGraphCheckBox( AParent: PControl; const ACaption: KOLString ): PControl;
+begin {$IFDEF INPACKAGE} Result := NewCheckbox( AParent, ACaption );
+ {$ELSE} Result := NewGraphButton( AParent, ACaption );
+ Result.TextAlign := taLeft;
+ Result.aAutoSzX := GetSystemMetrics( SM_CXMENUCHECK ) + 4;
+ Result.EV.fPaintProc := Result.GraphicCheckBoxPaint;
+ Result.EV.fGraphCtlMouseEvent := Result.GraphicCheckBoxMouse;
+ Result.PP.fControlClick := @ ClickGraphCheck;
+ {$ENDIF}
+end;////////////////////////////////////////////////////////////////////////////
+procedure ClickGraphRadio(Sender: PObj);
+var Ctl, C: PControl;
+ i: Integer;
+begin Ctl := Pointer( Sender );
+ if not Ctl.Enabled then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ Ctl.Focused := TRUE;
+ Ctl.Checked := TRUE;
+ if Ctl.Parent <> nil then
+ for i := 0 to Ctl.Parent.ChildCount-1 do
+ begin C := Ctl.Parent.Children[ i ];
+ if (C <> Ctl) and (@ C.PP.fControlClick = @ ClickGraphRadio) then
+ C.Checked := FALSE;
+ end;
+end;////////////////////////////////////////////////////////////////////////////
+function NewGraphRadioBox( AParent: PControl; const ACaption: KOLString ): PControl;
+begin {$IFDEF INPACKAGE} Result := NewRadiobox( AParent, ACaption );
+ if (@ ClickGraphRadio) <> nil then;
+ {$ELSE} Result := NewGraphButton( AParent, ACaption );
+ Result.TextAlign := taLeft;
+ Result.aAutoSzX := GetSystemMetrics( SM_CXMENUCHECK ) + 4;
+ Result.EV.fPaintProc := Result.GraphicRadioBoxPaint;
+ Result.PP.fControlClick := @ ClickGraphRadio;
+ {$IFDEF USE_FLAGS}
+ if not(G1_HasRadio in AParent.fFlagsG1) then
+ begin
+ include( AParent.fFlagsG1, G1_HasRadio );
+ Result.SetRadioChecked;
+ end;
+ {$ELSE}
+ AParent.PropInt[ @RADIO_LAST ] := Result.fMenu;
+ if AParent.PropInt[ @RADIO_1ST ] = 0 then
+ begin
+ AParent.PropInt[ @RADIO_1ST ] := Result.fMenu;
+ Result.SetRadioChecked;
+ end;
+ {$ENDIF}
+ {$ENDIF}
+end;////////////////////////////////////////////////////////////////////////////
+procedure GraphButtonSetFocus(Ctl: PControl);
+var PF, CC: PControl;
+ W: HWnd;
+begin if {$IFDEF USE_FLAGS} not(F2_Tabstop in Ctl.fStyle.f2_Style)
+ {$ELSE} not Ctl.fTabStop {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ PF := Ctl.ParentForm;
+ if (PF.DF.fCurrentControl <> nil) and (PF.DF.fCurrentControl <> Ctl) and
+ (PF.DF.fCurrentControl <> Ctl.fParent) then
+ begin CC := PF.DF.fCurrentControl;
+ CC.RefInc;
+ Ctl.fParent.Focused := TRUE;
+ if Assigned( CC.EV.fLeave ) then
+ CC.EV.fLeave( PF.DF.fCurrentControl )
+ else
+ Windows.SetFocus( 0 );
+ CC.RefDec;
+ end else
+ begin W := GetFocus;
+ if (W <> Ctl.Parent.fHandle) and (W <> 0) then
+ begin Windows.SetFocus( 0 );
+ Ctl.fParent.Focused := TRUE;
+ end;
+ end;
+ if Ctl.fParent.fHandle <> 0 then
+ begin {$IFDEF USE_FLAGS} include( Ctl.fFlagsG6, G6_Focused );
+ {$ELSE} Ctl.fFocused := TRUE; {$ENDIF}
+ Ctl.fParent.Postmsg( CM_FOCUSGRAPHCTL, Integer( Ctl ), 0 );
+ Ctl.RefInc;
+ end;
+ if Assigned( Ctl.EV.fOnEnter ) then
+ Ctl.EV.fOnEnter( Ctl );
+end;////////////////////////////////////////////////////////////////////////////
+function NewGraphButton( AParent: PControl; const ACaption: KOLString ): PControl;
+begin {$IFDEF INPACKAGE}
+ Result := NewButton( AParent, ACaption );
+ {$ELSE}
+ Result := _NewGraphCtl( AParent, TRUE,
+ {$IFDEF PACK_COMMANDACTIONS} ButtonActions_Packed
+ {$ELSE} @ButtonActions {$ENDIF} );
+ Result.EV.fPaintProc := Result.GraphicButtonPaint;
+ Result.Caption := ACaption;
+ Result.TextAlign := taCenter;
+ Result.VerticalAlign := vaCenter;
+ Result.EV.fGraphCtlMouseEvent := Result.GraphicButtonMouse;
+ Result.fSetFocus := @GraphButtonSetFocus;
+ Result.fKeyboardProcess := Result.GraphButtonKeyboardProcess;
+ {$ENDIF}
+end;////////////////////////////////////////////////////////////////////////////
+function EditGraphEdit(Ctl: PControl): PControl;
+var E: PControl;
+begin E := NewEditBox( Ctl.fParent, Ctl.DF.fEditOptions );
+ E.SetBoundsRect( Ctl.BoundsRect );
+ E.SetAlign( Ctl.Align );
+ E.fTabOrder := Ctl.fTabOrder;
+ E.Text := Ctl.Text;
+ E.OnChange := Ctl.ChangeGraphEdit;
+ E.Color := Ctl.Color;
+ E.fCursor := Ctl.fCursor;
+ E.CreateWindow;
+ E.OnLeave := Ctl.LeaveGraphEdit;
+ E.EV.fLeave := Ctl.LeaveGraphEdit;
+ E.Focused := TRUE;
+ E.OnChar := Ctl.OnChar;
+ E.OnKeyDown := Ctl.OnKeyDown;
+ E.OnKeyUp := Ctl.OnKeyUp;
+ E.OnDestroy := Ctl.DestroyGraphEdit;
+ //E.Font.Assign( Font );
+ Result := E;
+ Ctl.Visible := FALSE;
+ Ctl.DF.fEditCtl := E;
+ {$IFDEF NIL_EVENTS}
+ if Assigned( Ctl.EV.fOnEnter ) then
+ {$ENDIF}
+ Ctl.EV.fOnEnter( Ctl );
+end;////////////////////////////////////////////////////////////////////////////
+function NewGraphEditbox( AParent: PControl; Options: TEditOptions ): PControl;
+begin {$IFDEF INPACKAGE}
+ Result := NewEditbox( AParent, Options );
+ {$ELSE}
+ Result := _NewGraphCtl( AParent, TRUE,
+ {$IFDEF PACK_COMMANDACTIONS} EditActions_Packed
+ {$ELSE} @EditActions {$ENDIF} );
+ Result.aAutoSzY := 1;
+ Result.EV.fPaintProc := Result.GraphicEditPaint;
+ Result.DF.fEditOptions := Options;
+ Result.VerticalAlign := vaCenter;
+ Result.fColor := clWindow;
+ Result.EV.fGraphCtlMouseEvent := Result.GraphicEditMouse;
+ Result.fSetFocus := @EditGraphEdit;
+ Result.fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ];
+ Result.EV.fLeave := Result.LeaveGraphEdit;
+ {$ENDIF}
+end;////////////////////////////////////////////////////////////////////////////
+{ TGraphicControl }
+
+function TControl.DoGraphCtlPrepaint: TRect;
+begin
+ Result := ClientRect;
+ if not Assigned( TMethod( EV.fOnPrepaint ).Data ) and not Transparent then
+ begin if fBrush <> nil then
+ Canvas.Brush.Assign( fBrush )
+ else Canvas.Brush.Color := Color;
+ Canvas.FillRect( Result );
+ end;
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.GraphicLabelPaint(DC: HDC);
+var R: TRect;
+begin R := DoGraphCtlPrepaint;
+ if Text <> '' then DrawFormattedText( @ Self, DC, R, 0 );
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.GraphicCheckBoxPaint(DC: HDC);
+var R, R1: TRect;
+ Flag: DWORD;
+ W, H: Integer;
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ Theme: THandle;
+ {$ENDIF}
+begin R := DoGraphCtlPrepaint;
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ OpenThemeDataProc;
+ Theme := 0;
+ if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
+ Theme := fOpenThemeDataProc( 0, 'Button' );
+ if Theme <> 0 then begin
+ W := GetSystemMetrics( SM_CXMENUCHECK );
+ H := GetSystemMetrics( SM_CYMENUCHECK );
+ R1 := R;
+ R1.Right := R1.Left + W;
+ if {$IFDEF USE_FLAGS} G1_WordWrap in fFlagsG1
+ {$ELSE} fWordWrap {$ENDIF} then
+ R1.Top := R1.Top + Border
+ else R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2;
+ R1.Bottom := R1.Top + H;
+ Flag := 1; {CBS_UNCHECKEDNORMAL}
+ if not Enabled then
+ Flag := 4 {CBS_UNCHECKEDDISABLED}
+ else if {$IFDEF USE_FLAGS} G4_Hot in fFlagsG4
+ {$ELSE} fHot {$ENDIF} then
+ Flag := 2; {CBS_UNCHECKEDHOT}
+ if {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4
+ {$ELSE} fChecked {$ENDIF} then
+ Inc( Flag, 4 );
+ fDrawThemeBackground( Theme, DC, 3 {BP_CHECKBOX}, Flag, @R1, @R );
+ R.Left := R1.Left + W + Border;
+ if fCaption <> '' then begin
+ DrawFormattedText( @ Self, DC, R, DT_CALCRECT );
+ if {$IFDEF USE_FLAGS} G1_WordWrap in fFlagsG1
+ {$ELSE} fWordWrap {$ENDIF} then begin
+ DrawFormattedText( @ Self, DC, R, 0 );
+ GraphCtlDrawFocusRect( DC, R );
+ end else begin
+ GraphCtlDrawFocusRect( DC, R );
+ DrawFormattedTextXP( Theme, @ Self, DC, R, 3 {BP_CHECKBOX}, Flag, 0, 0 );
+ end;
+ end;
+ fCloseThemeData( Theme );
+ end else
+ {$ENDIF}
+ begin W := GetSystemMetrics( SM_CXMENUCHECK );
+ H := GetSystemMetrics( SM_CYMENUCHECK );
+ R1 := R;
+ R1.Right := R1.Left + W;
+ if {$IFDEF USE_FLAGS} G1_WordWrap in fFlagsG1
+ {$ELSE} fWordWrap {$ENDIF} then
+ R1.Top := R1.Top + Border
+ else R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2;
+ R1.Bottom := R1.Top + H;
+ Flag := 0;
+ if {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4
+ {$ELSE} fChecked {$ENDIF} then
+ Flag := DFCS_CHECKED;
+ DrawFrameControl( DC, R1, DFC_BUTTON, DFCS_BUTTONCHECK or
+ $800 {DFCS_TRANSPARENT} or Flag );
+ R.Left := R1.Left + W + Border;
+ DrawFormattedText( @ Self, DC, R, 0 );
+ GraphCtlDrawFocusRect( DC, R );
+ end;
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.GraphicCheckBoxMouse(var Msg: TMsg);
+begin if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_LBUTTONDBLCLK) then
+ ClickGraphCheck( @ Self );
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.GraphicRadioBoxPaint(DC: HDC);
+var R, R1: TRect;
+ Flag: DWORD;
+ W, H: Integer;
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ Theme: THandle;
+ {$ENDIF}
+begin R := DoGraphCtlPrepaint;
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ OpenThemeDataProc;
+ Theme := 0;
+ if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
+ Theme := fOpenThemeDataProc( 0, 'Button' );
+ if Theme <> 0 then begin
+ W := GetSystemMetrics( SM_CXMENUCHECK );
+ H := GetSystemMetrics( SM_CYMENUCHECK );
+ R1 := R;
+ R1.Right := R1.Left + W;
+ if {$IFDEF USE_FLAGS} G1_WordWrap in fFlagsG1
+ {$ELSE} fWordWrap {$ENDIF} then
+ R1.Top := R1.Top + Border
+ else R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2;
+ R1.Bottom := R1.Top + H;
+ Flag := 1; {CBS_UNCHECKEDNORMAL}
+ if not Enabled then
+ Flag := 4 {CBS_UNCHECKEDDISABLED}
+ else if {$IFDEF USE_FLAGS} G4_Hot in fFlagsG4
+ {$ELSE} fHot {$ENDIF} then
+ Flag := 2; {CBS_UNCHECKEDHOT}
+ if {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4
+ {$ELSE} fChecked {$ENDIF} then
+ Inc( Flag, 4 );
+ fDrawThemeBackground( Theme, DC, 2 {BP_RADIOBOX}, Flag, @R1, @R );
+ R.Left := R1.Left + W + Border;
+ if fCaption <> '' then begin
+ DrawFormattedText( @ Self, DC, R, DT_CALCRECT );
+ if {$IFDEF USE_FLAGS} G1_WordWrap in fFlagsG1
+ {$ELSE} fWordWrap {$ENDIF} then begin
+ DrawFormattedText( @ Self, DC, R, 0 );
+ GraphCtlDrawFocusRect( DC, R );
+ end else begin
+ GraphCtlDrawFocusRect( DC, R );
+ DrawFormattedTextXP( Theme, @ Self, DC, R, 2 {BP_RADIOBOX}, Flag, 0, 0 );
+ end;
+ end;
+ fCloseThemeData( Theme );
+ end else
+ {$ENDIF}
+ begin W := GetSystemMetrics( SM_CXMENUCHECK );
+ H := GetSystemMetrics( SM_CYMENUCHECK );
+ R1 := R;
+ R1.Right := R1.Left + W;
+ if {$IFDEF USE_FLAGS} G1_WordWrap in fFlagsG1
+ {$ELSE} fWordWrap {$ENDIF} then
+ R1.Top := R1.Top + Border
+ else R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2;
+ R1.Bottom := R1.Top + H;
+ Flag := 0;
+ if {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4
+ {$ELSE} fChecked {$ENDIF} then
+ Flag := DFCS_CHECKED;
+ DrawFrameControl( DC, R1, DFC_BUTTON, DFCS_BUTTONRADIO
+ or $800 {DFCS_TRANSPARENT} {or DFCS_ADJUSTRECT} or Flag );
+ R.Left := R1.Right + 2;
+ DrawFormattedText( @ Self, DC, R, 0 );
+ GraphCtlDrawFocusRect( DC, R );
+ end;
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.GraphicButtonPaint(DC: HDC);
+var R: TRect;
+ Flag: DWORD;
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ Flag1: DWORD;
+ Theme: THandle;
+ {$ENDIF}
+ II: TIconInfo;
+ BI: TagBitmap;
+ Y: Integer;
+ R1: TRect;
+begin R := DoGraphCtlPrepaint;
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ OpenThemeDataProc;
+ Theme := 0;
+ if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
+ Theme := fOpenThemeDataProc( 0, 'Button' );
+ if Theme <> 0 then begin
+ Flag := 1; {PBS_UNCHECKEDNORMAL}
+ if not Enabled then
+ Flag := 4 {PBS_UNCHECKEDDISABLED}
+ else
+ if {$IFDEF USE_FLAGS} G4_Pushed in fFlagsG4
+ {$ELSE} fPushed {$ENDIF} then
+ Flag := 3 {PBS_UNCHECKEDPRESSED}
+ else
+ if {$IFDEF USE_FLAGS} G4_Hot in fFlagsG4
+ {$ELSE} fHot {$ENDIF} then
+ Flag := 2; {PBS_UNCHECKEDHOT}
+ if {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4
+ {$ELSE} fChecked {$ENDIF} then
+ Inc( Flag, 4 );
+ fDrawThemeBackground( Theme, DC, 1 {BP_PUSHBUTTON}, Flag, @R, @R );
+ fGetThemeBackgroundContentRect( Theme, DC, 1 {BS_PUSHBUTTON}, Flag, @R, @R1 );
+ GraphCtlDrawFocusRect( DC, R1 );
+ if (DF.fButtonIcon <> 0) and GetIconInfo( DF.fButtonIcon, II ) then begin
+ if GetObject( II.hbmColor, Sizeof( BI ), @ BI ) <> 0 then begin
+ CASE fVerticalAlign OF
+ vaTop: Y := R.Top + Border;
+ vaBottom: Y := R.Bottom - Border - BI.bmHeight;
+ else {vaCenter:}Y := R.Top + (R.Bottom - R.Top - BI.bmHeight) div 2;
+ END;
+ DrawIcon( DC, R.Left + Border, Y, DF.fButtonIcon );
+ Inc( R1.Left, BI.bmWidth + Border * 2 );
+ end;
+ DeleteObject( II.hbmColor );
+ if II.hbmMask <> 0 then
+ DeleteObject( II.hbmMask );
+ end;
+ if fCaption <> '' then begin
+ Flag1 := DT_SINGLELINE;
+ if WordWrap then Flag1 := DT_WORDBREAK;
+ DrawFormattedText( @ Self, DC, R1, DT_CALCRECT );
+ DrawFormattedTextXP( Theme, @ Self, DC, R1, 1 {BP_PUSHBUTTON}, Flag,
+ Flag1, 0 );
+ end;
+ fCloseThemeData( Theme );
+ end else
+ {$ENDIF}
+ begin
+ Flag := 0;
+ if {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4
+ {$ELSE} fChecked {$ENDIF} then Flag := DFCS_CHECKED
+ else if {$IFDEF USE_FLAGS} G4_Pushed in fFlagsG4
+ {$ELSE} fPushed {$ENDIF} then
+ Flag := DFCS_PUSHED;
+ if {$IFDEF USE_FLAGS} G3_Flat in fFlagsG3
+ {$ELSE} fFlat {$ENDIF} then
+ Flag := Flag or DFCS_FLAT;
+ DrawFrameControl( DC, R, DFC_BUTTON, DFCS_BUTTONPUSH or
+ $800 {DFCS_TRANSPARENT} or DFCS_ADJUSTRECT or Flag );
+ R1 := R;
+ if (DF.fButtonIcon <> 0) and GetIconInfo( DF.fButtonIcon, II ) then begin
+ if GetObject( II.hbmColor, Sizeof( BI ), @ BI ) <> 0 then begin
+ CASE fVerticalAlign OF
+ vaTop: Y := R.Top + Border;
+ vaBottom: Y := R.Bottom - Border - BI.bmHeight;
+ else {vaCenter:}Y := R.Top + (R.Bottom - R.Top - BI.bmHeight) div 2;
+ END;
+ DrawIcon( DC, R.Left + Border, Y, DF.fButtonIcon );
+ Inc( R1.Left, BI.bmWidth + Border * 2 );
+ end;
+ DeleteObject( II.hbmColor );
+ if II.hbmMask <> 0 then DeleteObject( II.hbmMask );
+ end;
+ DrawFormattedText( @ Self, DC, R1, 0 );
+ GraphCtlDrawFocusRect( DC, R );
+ end;
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.GraphicButtonMouse(var Msg: TMsg);
+var Pt: TPoint;
+begin CASE Msg.message OF
+ WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
+ begin GraphButtonSetFocus(@Self);
+ RefInc;
+ SetCapture( Parent.Handle );
+ Parent.fPushedBtn := @ Self;
+ {$IFDEF USE_FLAGS} include( fFlagsG4, G4_Pushed );
+ {$ELSE} fPushed := TRUE; {$ENDIF}
+ Invalidate;
+ end;
+ WM_LBUTTONUP:
+ begin
+ ReleaseCapture;
+ Invalidate;
+ if {$IFDEF USE_FLAGS} G4_Pushed in fFlagsG4
+ {$ELSE} fPushed {$ENDIF} then begin
+ Pt.X := SmallInt( LoWord( Msg.lParam ) );
+ Pt.Y := SmallInt( HiWord( Msg.lParam ) );
+ if PtInRect( ClientRect, Pt ) then DoClick;
+ {$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_Pushed );
+ {$ELSE} fPushed := FALSE; {$ENDIF}
+ Parent.fPushedBtn := nil;
+ RefDec;
+ end;
+ end;
+ END;
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.LeaveGraphButton( Sender: PObj );
+begin {$IFDEF USE_FLAGS} exclude( fFlagsG6, G6_Focused );
+ {$ELSE} fFocused := FALSE; {$ENDIF}
+ if Parent.DF.fCurrentControl = @ Self then
+ Parent.DF.fCurrentControl := nil;
+ if ParentForm.DF.fCurrentControl = @ Self then
+ ParentForm.DF.fCurrentControl := nil;
+ Invalidate;
+ {$IFDEF NIL_EVENTS}
+ if Assigned( EV.fOnLeave ) then
+ {$ENDIF}
+ EV.fOnLeave( @ Self );
+end;////////////////////////////////////////////////////////////////////////////
+function TControl.GraphButtonKeyboardProcess(var Msg: TMsg;
+ var Rslt: Integer): Boolean;
+var SpacePressed: Boolean;
+begin Result := FALSE;
+ SpacePressed := Msg.wParam = Word( ' ' );
+ {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
+ SpacePressed := SpacePressed or (Msg.wParam = 13);
+ {$ENDIF}
+ if not SpacePressed then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ if (Msg.message = WM_KEYDOWN) or (Msg.message = WM_SYSKEYDOWN) then
+ begin
+ Parent.fPushedBtn := @ Self;
+ {$IFDEF USE_FLAGS} include( fFlagsG4, G4_Pushed );
+ {$ELSE} fPushed := TRUE; {$ENDIF}
+ Invalidate;
+ Result := TRUE; /////
+ end else
+ if (Msg.message = WM_KEYUP) or (Msg.message = WM_SYSKEYUP) then
+ begin
+ {$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_Pushed );
+ {$ELSE} fPushed := FALSE; {$ENDIF}
+ Parent.fPushedBtn := nil;
+ Invalidate;
+ Result := TRUE; /////
+ end else
+ if (Msg.message = WM_CHAR) or (Msg.message = WM_SYSCHAR) then
+ begin
+ DoClick;
+ Result := TRUE;
+ end;
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.GraphicEditPaint(DC: HDC);
+var R: TRect;
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ R1: TRect;
+ Flag, Flag1: DWORD;
+ Theme: THandle;
+ {$ENDIF}
+begin R := ClientRect;
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ OpenThemeDataProc;
+ Theme := 0;
+ if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
+ Theme := fOpenThemeDataProc( 0, 'Edit' );
+ if Theme <> 0 then
+ begin
+ Flag := 1; {ETS_NORMAL}
+ if not Enabled then
+ Flag := 4 {ETS_DISABLED}
+ else if eoReadonly in DF.fEditOptions then
+ Flag := 6 {ETS_READONLY}
+ else if {$IFDEF USE_FLAGS} G6_Focused in fFlagsG6
+ {$ELSE} fFocused {$ENDIF} then
+ Flag := 5 {ETS_FOCUSED}
+ else if {$IFDEF USE_FLAGS} G4_Hot in fFlagsG4
+ {$ELSE} fHot {$ENDIF} then
+ Flag := 2; {ETS_HOT}
+ fDrawThemeBackground( Theme, DC, 1 {EP_EDITTEXT}, Flag, @R, @R );
+ Inc( R.Left, 2 );
+ Dec( R.Right, 2 );
+ fGetThemeBackgroundContentRect( Theme, DC, 1 {EP_EDITTEXT}, Flag, @R, @R1 );
+ if fCaption <> '' then
+ begin
+ Flag1 := DT_SINGLELINE;
+ if eoMultiline in DF.fEditOptions then
+ Flag1 := DT_WORDBREAK;
+ CASE fTextAlign OF
+ taCenter: Flag1 := Flag1 or DT_CENTER;
+ taRight: Flag1 := Flag1 or DT_RIGHT;
+ END;
+ CASE fVerticalAlign OF
+ vaCenter: Flag1 := Flag1 or DT_VCENTER;
+ vaBottom: Flag1 := Flag1 or DT_BOTTOM;
+ END;
+ DrawFormattedTextXP( Theme, @ Self, DC, R1, 1 {EP_EDITTEXT}, Flag,
+ Flag1, 0 );
+ end;
+ fCloseThemeData( Theme );
+ end else
+ {$ENDIF}
+ begin
+ if not Assigned( EV.fOnPrepaint ) and not Transparent then begin
+ Canvas.Brush.Color := fColor;
+ Canvas.FillRect( R );
+ end;
+ DrawEdge( DC, R, BDR_SUNKENINNER or BDR_SUNKENOUTER, BF_ADJUST or BF_RECT );
+ DrawFormattedText( @ Self, DC, R, DT_EDITCONTROL );
+ end;
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.GraphicEditMouse(var Msg: TMsg);
+var E: PControl;
+ Pt: TPoint;
+begin CASE Msg.message OF
+ WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
+ if not ( eoReadOnly in DF.fEditOptions ) then begin
+ E := EditGraphEdit(@Self);
+ Pt.X := Smallint( LoWord( Msg.lParam ) ) - Left;
+ Pt.Y := Smallint( HiWord( Msg.lParam ) ) - Top;
+ PostMessage( E.Handle, Msg.message, Msg.wParam,
+ Pt.Y shl 16 or Pt.X and $FFFF );
+ end;
+ END;
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.LeaveGraphEdit(Sender: PObj);
+begin if {$IFDEF USE_FLAGS} not(G6_GraphicCtl in PControl(Sender).fFlagsG6)
+ {$ELSE} PControl( Sender ).fWindowed {$ENDIF}
+ and ( DF.fEditCtl <> nil ) then begin
+ Text := PControl( Sender ).Text;
+ DF.fEditCtl := nil;
+ Visible := TRUE;
+ ParentForm.DF.fCurrentControl := @ Self;
+ Parent.DF.fCurrentControl := @ Self;
+ Parent.Postmsg( CM_QUIT, DWORD( Sender ), 0 );
+ end else
+ if Assigned( DF.fEditCtl ) then
+ DF.fEditCtl.EV.fLeave( DF.fEditCtl );
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.ChangeGraphEdit(Sender: PObj);
+begin Text := PControl( Sender ).Text;
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.DestroyGraphEdit(Sender: PObj);
+begin
+ DF.fEditCtl := nil;
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.GraphCtlDrawFocusRect(DC: HDC; const R: TRect);
+var rgn: HRgn;
+begin if {$IFDEF USE_FLAGS} (G6_Focused in fFlagsG6)
+ {$ELSE} fFocused {$ENDIF}
+ and (GetActiveWindow = ParentForm.Handle) then begin
+ BeginPath( DC );
+ Canvas.FrameRect( R );
+ EndPath( DC );
+ Canvas.FrameRect( R );
+ DrawFocusRect( DC, R );
+ rgn := PathToRegion( DC );
+ ExtSelectClipRgn( DC, rgn, RGN_DIFF );
+ DeleteObject( rgn );
+ end;
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.GroupBoxPaint(DC: HDC);
+var bk_erased: Boolean;
+ procedure DoEraseBkgnd;
+ var R: TRect;
+ begin
+ bk_erased := TRUE;
+ If Assigned( EV.fOnEraseBkgnd ) then
+ EV.fOnEraseBkgnd( @ Self, DC )
+ else begin
+ R := BoundsRect;
+ OffsetRect( R, -R.Left, -R.Top );
+ SetBkMode( DC, OPAQUE );
+ SetBkColor( DC, Color2RGB( fColor ) );
+ SetBrushOrgEx( DC, 0, 0, nil );
+ Windows.FillRect( DC, R, Global_GetCtlBrushHandle( @ Self ) );
+ End;
+ end;
+var R, R1, R0: TRect;
+ rgn, rgn2, rgntxt, rgnsav, rgnsavall: HRgn;
+ i: Integer;
+ C: PControl;
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ Theme: THandle;
+ Flag: DWORD;
+ {$ENDIF}
+begin if not DF.fErasingBkgnd then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ R := ClientRect;
+ Dec( R.Top, 14 { Self_.fClientTop div 2 } );
+ Dec( R.Left, fClientLeft );
+ Inc( R.Right, fClientRight );
+ Inc( R.Bottom, fClientBottom );
+ rgnsavall := CreateRectRgn( 0, 0, 0, 0 );
+ GetClipRgn( DC, rgnsavall );
+ TRY
+ For i := 0 to ChildCount-1 do begin
+ C := Children[ i ];
+ If {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6)
+ {$ELSE} not C.fWindowed {$ENDIF}
+ and {$IFDEF USE_FLAGS} (F3_Visible in C.fStyle.f3_Style)
+ {$ELSE} C.fVisible {$ENDIF} then begin
+ rgn := CreateRectRgnIndirect( C.BoundsRect );
+ ExtSelectClipRgn( DC, rgn, RGN_DIFF );
+ DeleteObject( rgn );
+ End;
+ End;
+ {$IFDEF GRAPHCTL_XPSTYLES}
+ OpenThemeDataProc;
+ Theme := 0;
+ if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
+ Theme := fOpenThemeDataProc( 0, 'Button' );
+ If Theme <> 0 then begin
+ DoEraseBkgnd;
+ Flag := 1; {GBS_NORMAL}
+ if not Enabled then Flag := 2; {GBS_DISABLED}
+ R1 := R;
+ rgnsav := 0;
+ if fCaption <> '' then
+ begin
+ R1.Top := 0;
+ Inc( R1.Left, 8 );
+ Dec( R1.Right, 8 );
+ BeginPath( DC );
+ DrawFormattedTextXP( Theme, @ Self, DC, R1, 4 {BP_GROUPBOX}, Flag, 0, 0 );
+ EndPath( DC );
+ rgntxt := PathToRegion( DC );
+ if rgntxt = 0 then begin
+ R1.Right := R1.Left + Canvas.TextWidth( fCaption );
+ R1.Bottom := R1.Top + Canvas.TextHeight( fCaption );
+ rgntxt := CreateRectRgnIndirect( R1 );
+ end;
+ DrawFormattedTextXP( Theme, @ Self, DC, R1, 4 {BP_GROUPBOX}, Flag, 0, 0 );
+ GetRgnBox( rgntxt, R0 );
+ Dec( R0.Left, 3 );
+ Inc( R0.Right, 3 );
+ DeleteObject( rgntxt );
+ rgn := CreateRectRgnIndirect( R0 );
+ end else rgn := 0;
+ if rgn <> 0 then
+ begin
+ rgnsav := CreateRectRgn( 0, 0, 0, 0 );
+ GetClipRgn( DC, rgnsav );
+ ExtSelectClipRgn( DC, rgn, RGN_DIFF );
+ DeleteObject( rgn );
+ end;
+ fDrawThemeBackground( Theme, DC, 4 {BP_GROUPBOX}, Flag, @R, @R );
+ if rgnsav <> 0 then begin
+ SelectClipRgn( DC, rgnsav );
+ DeleteObject( rgnsav );
+ end;
+ fCloseThemeData( Theme );
+ end else
+ {$ENDIF}
+ begin
+ bk_erased := FALSE;
+ R1 := R;
+ R1.Top := 0;
+ R1.Bottom := ClientRect.Top;
+ Inc( R1.Left, 16 );
+ Dec( R1.Right, 16 );
+ fVerticalAlign := vaCenter;
+ BeginPath( DC );
+ Canvas.TextOut( R1.Left, R1.Top, fCaption );
+ EndPath( DC );
+ Canvas.TextOut( R1.Left, R1.Top, fCaption );
+ rgntxt := PathToRegion( DC );
+ if rgntxt = 0 then // такое - в случае шрифта по умолчанию!
+ begin
+ R1.Right := R1.Left + Canvas.TextWidth( fCaption );
+ R1.Bottom := R1.Top + Canvas.TextHeight( fCaption );
+ rgntxt := CreateRectRgnIndirect( R1 );
+ end;
+
+ GetRgnBox( rgntxt, R0 );
+ rgn2 := CreateRectRgnIndirect( R0 );
+
+ rgnsav := CreateRectRgn( 0, 0, 0, 0 );
+ GetClipRgn( DC, rgnsav );
+ ExtSelectClipRgn( DC, rgn2, RGN_DIFF );
+ DeleteObject( rgn2 );
+
+ BeginPath( DC );
+ DrawEdge( DC, R, BDR_RAISEDINNER or BDR_SUNKENOUTER, BF_RECT );
+ EndPath( DC );
+ rgn := PathToRegion( DC );
+ if rgn = 0 then DoEraseBkgnd;
+ DrawEdge( DC, R, BDR_RAISEDINNER or BDR_SUNKENOUTER, BF_RECT );
+
+ SelectClipRgn( DC, rgnsav );
+ DeleteObject( rgnsav );
+
+ if rgn <> 0 then
+ begin
+ ExtSelectClipRgn( DC, rgn, RGN_DIFF );
+ DeleteObject( rgn );
+ end;
+ ExtSelectClipRgn( DC, rgntxt, RGN_DIFF );
+ DeleteObject( rgntxt );
+
+ if not bk_erased then DoEraseBkgnd;
+ End;
+ FINALLY
+ SelectClipRgn( DC, rgnsavall );
+ DeleteObject( rgnsavall );
+ END;
+end;
+{$ENDIF USE_GRAPHCTLS}//--------------------------------------------------------
+
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+function TControl.MakeWordWrap: PControl;
+begin {$IFDEF USE_FLAGS} include( fFlagsG1, G1_WordWrap );
+ {$ELSE} fWordWrap := TRUE; {$ENDIF}
+ if IsButton then
+ Style := fStyle.Value or BS_MULTILINE
+ else
+ Style := fStyle.Value and not SS_LEFTNOWORDWRAP;
+ Result := @ Self;
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+function ParentAnchorChildren( Sender: PControl; var Msg: TMsg;
+ var Rslt: Integer ): Boolean;
+var NewW, NewH: Integer;
+ dW, dH: Integer;
+ i: Integer;
+ C: PControl;
+ {$IFNDEF ANCHORS_WM_SIZE}
+ CR: TRect;
+ {$ENDIF}
+begin Result := FALSE;
+ If (Msg.message = {$IFDEF ANCHORS_WM_SIZE} WM_SIZE {$ELSE} WM_WINDOWPOSCHANGED {$ENDIF} )
+ and not IsIconic(Sender.Handle) then begin
+ {$IFDEF ANCHORS_WM_SIZE}
+ NewW := LoWord( Msg.lParam );
+ NewH := HiWord( Msg.lParam );
+ {$ELSE}
+ CR := Sender.ClientRect;
+ NewW := CR.Right;
+ NewH := CR.Bottom;
+ {$ENDIF}
+ dW := NewW - Sender.fOldWidth;
+ dH := NewH - Sender.fOldHeight;
+ For i := 0 to Sender.ChildCount - 1 do begin
+ C := Sender.Children[ i ];
+ If dW <> 0 then begin
+ if C.AnchorRight and C.AnchorLeft then
+ C.Width := C.Width + dW
+ else if C.AnchorRight then
+ C.Left := C.Left + dW;
+ End;
+ If dH <> 0 then begin
+ if C.AnchorBottom and C.AnchorTop then
+ C.Height := C.Height + dH
+ else if C.AnchorBottom then
+ C.Top := C.Top + dH;
+ End;
+ End;
+ Sender.fOldWidth := NewW;
+ Sender.fOldHeight := NewH;
+ End;
+end;////////////////////////////////////////////////////////////////////////////
+function TControl.Anchor(aLeft, aTop, aRight, aBottom: Boolean): PControl;
+begin if (not aLeft) and aRight then
+ 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;
+begin Result := Perform(LB_GETTOPINDEX,0,0);
+end;////////////////////////////////////////////////////////////////////////////
+function TControl.LBItemAtPos(X, Y: Integer): Integer;
+var R: TRect;
+ P: TPoint;
+ i: Integer;
+begin P := MakePoint(X,Y);
+ For i := LBTopIndex to Count -1 do begin
+ Perform(LB_GETITEMRECT, i , Integer(@R));
+ if PointInRect(P,R) then begin
+ Result := i; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
+ end;
+ End;
+ Result := -1;
+end;////////////////////////////////////////////////////////////////////////////
+procedure TControl.SetLBTopIndex(const Value: Integer);
+begin Perform(LB_SETTOPINDEX,Value,0); end;/////////////////////////////////////
+{$ENDIF WIN_GDI}//--------------------------------------------------------------
+{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION}
+function TControl.FormGetIntParam: Integer;
+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;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE}
+function TControl.FormGetColorParam: Integer;
+begin Result := FormGetIntParam;
+ Result := (Result shr 1) or (Result shl 31);
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure TControl.FormGetStrParam;
+var i: Integer;
+begin i := FormGetIntParam;
+ SetString( FormString, DF.FormParams, i );
+ inc( DF.FormParams, i );
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+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 PASCAL}
+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( Integer(AForm)
+ + (ControlPtrOffsets[0] shl 2) ) );
+ ControlPtrOffsets := Pointer( Integer( 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;
+{$ENDIF}////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE}
+function FormNewWordWrapLabel( Form: PControl ): PControl;
+begin Form.FormGetStrParam;
+ Result := NewWordWrapLabel( Form.DF.FormCurrentParent, Form.FormString );
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE}
+function FormNewLabelEffect( Form: PControl ): PControl;
+var Shd: Integer;
+begin Form.FormGetStrParam;
+ Shd := Form.FormGetIntParam;
+ Result := NewLabelEffect( Form.DF.FormCurrentParent, Form.FormString, Shd );
+end;
+{$ENDIF}////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE}
+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 USE_RICHEDIT}///////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE}
+function FormNewRichEdit( Form: PControl ): PControl;
+type PEditOptions = ^TEditOptions;
+var i: Integer;
+begin i := Form.FormGetIntParam;
+ Result := NewRichEdit( Form.DF.FormCurrentParent,
+ PEditOptions( @ i )^ );
+end;
+{$ENDIF PAS_VERSION}
+{$ENDIF USE_RICHEDIT}///////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE}
+function FormNewComboBox( Form: PControl ): PControl;
+type PComboOptions = ^TComboOptions;
+var i: Integer;
+begin i := Form.FormGetIntParam;
+ Result := NewCombobox( Form.DF.FormCurrentParent, PComboOptions( @ i )^ );
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE}
+function FormNewCheckbox( Form: PControl ): PControl;
+begin Form.FormGetStrParam;
+ Result := NewCheckbox( Form.DF.FormCurrentParent, Form.FormString );
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE}
+function FormNewRadiobox( Form: PControl ): PControl;
+begin Form.FormGetStrParam;
+ Result := NewRadiobox( Form.DF.FormCurrentParent, Form.FormString );
+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;////////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE}
+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 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;////////////////////////////////////////////////////////////////////////////
+{$IFDEF _D4orHigher}
+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;
+{$ENDIF}////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ENDIF PAS_VERSION}////////////////////////////////////////
+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): Integer;
+begin Result := Form.FormParentForm.FormGetIntParam; end;///////////////////////////
+function ParentForm_ColorParamPas(Form: PControl): Integer;
+begin Result := Form.FormParentForm.FormGetColorParam; end;/////////////////////////
+{$IFDEF ASM_VERSION} // only to call from asm -- returns EAX=Parent Form, EDX=ECX=PChar param
+{$ENDIF ASM_VERSION}////////////////////////////////////////////////////////////
+{$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;
+{$ENDIF}////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetClientSize( Form: PControl );
+var W, H: Integer;
+begin W := ParentForm_IntParamPas(Form);
+ H := ParentForm_IntParamPas(Form);
+ Form.SetClientSize( W, H );
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+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;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+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;
+{$ENDIF}////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetVisibleFalse( Form: PControl );
+begin Form.Visible := FALSE; end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetEnabledFalse( Form: PControl );
+begin Form.Enabled := FALSE; end;
+{$ENDIF}////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormResetStyles( Form: PControl );
+begin Form.Style := Form.Style and not ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetStyle( Form: PControl );
+begin Form.Style := Form.Style or DWORD( ParentForm_IntParamPas(Form)); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetAlphaBlend( Form: PControl );
+begin Form.AlphaBlend := ParentForm_IntParamPas( Form ); end;
+{$ENDIF}////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetHasBorderFalse( Form: PControl );
+begin Form.HasBorder := FALSE; end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetHasCaptionFalse( Form: PControl );
+begin Form.HasCaption := FALSE; end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormResetCtl3D( Form: PControl );
+begin Form.Ctl3D := FALSE; end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormIconLoad_hInstance( Form: PControl );
+begin Form.IconLoad( hInstance,
+ MAKEINTRESOURCE( ParentForm_IntParamPas(Form) ) );
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormIconLoadCursor_0( Form: PControl );
+begin Form.IconLoadCursor( 0, MakeIntResource( ParentForm_IntParamPas(Form) ) );
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+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;////////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetWindowState( Form: PControl );
+begin Form.WindowState := TWindowState( ParentForm_IntParamPas(Form) ); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormCursorLoad_0( Form: PControl );
+begin Form.CursorLoad( 0, MAKEINTRESOURCE( ParentForm_IntParamPas(Form) ) ); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+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 FormSetColor( Form: PControl );
+begin Form.Color := ParentForm_ColorParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetBrushStyle( Form: PControl );
+begin Form.Brush.BrushStyle := TBrushStyle( ParentForm_IntParamPas(Form) ); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+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;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetFontColor( Form: PControl );
+begin Form.Font.Color := ParentForm_ColorParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetFontStyles( Form: PControl );
+type PFontStyle = ^TFontStyle;
+var fs: Byte;
+begin fs := ParentForm_IntParamPas(Form);
+ Form.Font.FontStyle := PFontStyle( @ fs )^;
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetFontHeight( Form: PControl );
+begin Form.Font.FontHeight := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+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;////////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetFontOrientation( Form: PControl );
+begin Form.Font.FontOrientation := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetFontCharset( Form: PControl );
+begin Form.Font.FontCharset := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetFontPitch( Form: PControl );
+begin Form.Font.FontPitch := TFontPitch( ParentForm_IntParamPas(Form) ); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetBorder( Form: PControl );
+begin Form.Border := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetMarginTop( Form: PControl );
+begin Form.MarginTop := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetMarginBottom( Form: PControl );
+begin Form.MarginBottom := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetMarginLeft( Form: PControl );
+begin Form.MarginLeft := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetMarginRight( Form: PControl );
+begin Form.MarginRight := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetSimpleStatusText( Form: PControl );
+begin Form.SimpleStatusText := ParentForm_PCharParam(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetStatusText( Form: PControl );
+var I: Integer;
+begin I := ParentForm_IntParamPas(Form);
+ Form.StatusText[I] := ParentForm_PCharParam(Form);
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormRemoveCloseIcon( Form: PControl );
+begin DeleteMenu( GetSystemMenu( Form.GetWindowHandle, False ),
+ SC_CLOSE, MF_BYCOMMAND );
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+procedure FormSetEraseBkgndTrue( Form: PControl );
+begin Form.EraseBackground := TRUE; end;
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetMinWidth( Form: PControl );
+begin Form.MinWidth := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetMaxWidth( Form: PControl );
+begin Form.MaxWidth := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetMinHeight( Form: PControl );
+begin Form.MinHeight := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetMaxHeight( Form: PControl );
+begin Form.MaxHeight := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$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;////////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetTextShiftX( Form: PControl );
+begin Form.TextShiftX := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetTextShiftY( Form: PControl );
+begin Form.TextShiftY := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetColor2( Form: PControl );
+begin Form.Color2 := ParentForm_ColorParamPas( Form ); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetTextAlign( Form: PControl );
+begin Form.TextAlign := TTextAlign( ParentForm_IntParamPas(Form) ); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetTextVAlign( Form: PControl );
+begin Form.VerticalAlign := TVerticalAlign( ParentForm_IntParamPas(Form) ); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+procedure FormSetTabStopFalse( Form: PControl );
+begin Form.TabStop := FALSE; end;
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetIgnoreDefault( Form: PControl );
+begin Form.IgnoreDefault := Boolean( ParentForm_IntParamPas(Form) ); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+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 FormSetCaption( Form: PControl );
+var Ctl: PControl;
+begin Ctl := Form;
+ Form := Form.FormParentForm;
+ Form.FormGetStrParam;
+ Ctl.Caption := Form.FormString;
+end;
+{$ENDIF PAS_VERSION}
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+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;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetRE_AutoFontSizeAdjustFalse( Form: PControl );
+begin Form.RE_AutoFontSizeAdjust := FALSE; end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetRE_DualFontTrue( Form: PControl );
+begin Form.RE_DualFont := TRUE; end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetRE_UIFontsTrue( Form: PControl );
+begin Form.RE_UIFonts := TRUE; end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetRE_IMECancelCompleteTrue( Form: PControl );
+begin Form.RE_IMECancelComplete := TRUE; end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetRE_IMEAlwaysSendNotifyTrue( Form: PControl );
+begin Form.RE_IMEAlwaysSendNotify := TRUE; end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetMaxTextSize( Form: PControl );
+begin Form.MaxTextSize := DWORD( ParentForm_IntParamPas(Form) ); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetRE_AutoKeyboardTrue( Form: PControl );
+begin Form.RE_AutoKeyboard := TRUE; end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+procedure FormSetRE_DisableOverwriteChangeTrue( Form: PControl );
+begin Form.RE_DisableOverwriteChange := TRUE;
+end;////////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+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}////////////////////////////////////////////////////////////
+{$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;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+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;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+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;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetProgress( Form: PControl );
+begin Form.Progress := ParentForm_IntParamPas(Form);
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+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;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetLVColOrder( Form: PControl );
+var N, i: Integer;
+begin N := ParentForm_IntParamPas(Form);
+ i := ParentForm_IntParamPas(Form);
+ Form.LVColOrder[N] := i;
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetLVColImage( Form: PControl );
+var N, i: Integer;
+begin N := ParentForm_IntParamPas(Form);
+ i := ParentForm_IntParamPas(Form);
+ Form.LVColImage[N] := i;
+end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+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;////////////////////////////////////////////////////////////////////////////
+{$IFDEF _D4orHigher}
+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;
+{$ENDIF _D4orHigher}////////////////////////////////////////////////////////////
+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;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetCurIdx( Form: PControl );
+begin Form.CurIndex := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetSBMin( Form: PControl );
+begin Form.SBMin := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetSBMax( Form: PControl );
+begin Form.SBMax := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetSBPosition( Form: PControl );
+begin Form.SBPosition := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+procedure FormSetSBPageSize( Form: PControl );
+begin Form.SBPageSize := ParentForm_IntParamPas(Form); end;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}
+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;
+{$ENDIF PAS_VERSION}////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE PASCAL}//////////////////////////////////////////////
+procedure FormSetCurCtl( Form: PControl );
+var i: Integer;
+ C: PControl;
+begin Form := Form.FormParentForm;
+ i := Form.FormGetIntParam;
+ C := PPControl(Integer( Form.DF.FormAddress ) + i * 4)^;
+ 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;
+{$ENDIF}////////////////////////////////////////////////////////////////////////
+{$IFDEF ASM_VERSION}{$ELSE}/////////////////////////////////////////////////////
+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} //<<<<<<<<<<<<<<<<<<<<<<< KOL_ASM.inc
+ {$IFnDEF UNICODE_CTRLS}
+ {$I KOL_ASM_NOUNICODE.inc} //<<<<<<<<< KOL_ASM_NOUNICODE.inc
+ {$ENDIF noUNICODE}
+{$ENDIF PAS_VERSION}
+{$IFDEF LIN}
+ {$DEFINE implementation} {$I KOL_Linux.inc} {$UNDEF implementation}
+{$ENDIF LIN}
+
+{$IFDEF USE_CUSTOMEXTENSIONS}
+ {$I CUSTOM_CODE_EXTENSION.inc} // See comments in TControl
+{$ENDIF USE_CUSTOMEXTENSIONS}
+
+{$IFDEF EVENTS_DYNAMIC}//-------------------------------------------------------
+{$IFDEF ASM_VERSION}
+function TControl.ProvideUniqueEvents: PEvents;
+const Size_TEvents = Sizeof(TEvents);
+asm PUSH ESI
+ XCHG ESI, EAX
+ MOV EAX, [ESI].TControl.EV
+ CMP EAX, offset[EmptyEvents]
+ JNZ @@ready
+
+ MOV EAX, Size_TEvents
+ CALL System.@GetMem
+ MOV [ESI].TControl.EV, EAX
+ PUSH EAX
+ XCHG EDX, EAX
+ MOV EAX, offset[EmptyEvents]
+ MOV ECX, Size_TEvents
+ CALL Move
+ PUSH ESI
+ PUSH offset[FreeEV]
+ XCHG EAX, ESI
+ CALL TControl.Add2AutoFreeEx
+ POP EAX
+@@ready:
+ POP ESI
+end;
+{$ELSE}
+function TControl.ProvideUniqueEvents: PEvents;
+begin if EV = @EmptyEvents then
+ begin
+ GetMem( EV, Sizeof(TEvents) );
+ Move( EmptyEvents, EV^, Sizeof(TEvents) );
+ Add2AutoFreeEx( FreeEV );
+ end;
+ Result := EV;
+end; {$ENDIF PAS_VERSION}///////////////////////////////////////////////////////
+
+procedure TControl.FreeEV;
+begin FreeMem( EV );
+ EV := @EmptyEvents;
+end;////////////////////////////////////////////////////////////////////////////
+function TControl.Get_OnHelp: TOnHelp;
+begin Result := EV.fOnHelp; end;
+procedure TControl.Set_OnHelp(const Value: TOnHelp);
+begin ProvideUniqueEvents.fOnHelp := Value; end;
+function TControl.Get_OnBitBtnDraw: TOnBitBtnDraw;
+begin Result := EV.FOnBitBtnDraw; end;
+procedure TControl.Set_OnBitBtnDraw(const Value: TOnBitBtnDraw);
+begin ProvideUniqueEvents.FOnBitBtnDraw := Value; end;
+function TControl.Get_OnMeasureItem: TOnMeasureItem;
+begin Result := EV.fOnMeasureItem; end;
+function TControl.Get_OnShow: TOnEvent;
+begin Result := EV.fOnShow; end;
+function TControl.Get_OnHide: TOnEvent;
+begin Result := EV.fOnHide; end;
+function TControl.Get_OnClose: TOnEventAccept;
+begin Result := EV.fOnClose; end;
+function TControl.Get_OnQueryEndSession: TOnEventAccept;
+begin Result := EV.fOnQueryEndSession; end;
+function TControl.Get_OnPaint: TOnPaint;
+begin Result := EV.fOnPaint; end;
+function TControl.Get_OnPrePaint: TOnPaint;
+begin Result := EV.fOnPrepaint; end;
+procedure TControl.Set_OnPrePaint(const Value: TOnPaint);
+begin ProvideUniqueEvents.fOnPrepaint := Value; end;
+function TControl.Get_OnPostPaint: TOnPaint;
+begin Result := EV.fOnPostPaint; end;
+procedure TControl.Set_OnPostPaint(const Value: TOnPaint);
+begin ProvideUniqueEvents.fOnPostPaint := Value; end;
+function TControl.Get_OnEraseBkgnd: TOnPaint;
+begin Result := EV.fOnEraseBkgnd; end;
+procedure TControl.Set_OnEraseBkgnd(const Value: TOnPaint);
+begin ProvideUniqueEvents.fOnEraseBkgnd := Value;
+ AttachProc( WndProcEraseBkgnd );
+end;////////////////////////////////////////////////////////////////////////////
+function TControl.Get_OnClick: TOnEvent;
+begin Result := EV.fOnClick; end;
+function TControl.Get_OnResize: TOnEvent;
+begin Result := EV.fOnResize; end;
+function TControl.Get_OnMove: TOnEvent;
+begin Result := EV.fOnMove; end;
+function TControl.Get_OnMoving: TOnEventMoving;
+begin Result := EV.fOnMoving; end;
+function TControl.Get_OnSplit: TOnSplit;
+begin Result := EV.FOnSplit; end;
+procedure TControl.Set_OnSplit(const Value: TOnSplit);
+begin ProvideUniqueEvents.FOnSplit := Value; end;
+function TControl.Get_OnKeyDown: TOnKey;
+begin Result := EV.fOnKeyDown; end;
+function TControl.Get_OnKeyUp: TOnKey;
+begin Result := EV.fOnKeyUp; end;
+function TControl.Get_OnChar: TOnChar;
+begin Result := EV.fOnChar; end;
+function TControl.Get_OnDeadChar: TOnChar;
+begin Result := EV.fOnDeadChar; end;
+function TControl.Get_OnMouseUp: TOnMouse;
+begin Result := EV.fOnMouseUp; end;
+function TControl.Get_OnMouseDown: TOnMouse;
+begin Result := EV.fOnMouseDown; end;
+function TControl.Get_OnMouseMove: TOnMouse;
+begin Result := EV.fOnMouseMove; end;
+function TControl.Get_OnMouseDblClk: TOnMouse;
+begin Result := EV.fOnMouseDblClk; end;
+function TControl.Get_OnMouseWheel: TOnMouse;
+begin Result := EV.fOnMouseWheel; end;
+function TControl.Get_OnMouseEnter: TOnEvent;
+begin Result := EV.fOnMouseEnter; end;
+function TControl.Get_OnMouseLeave: TOnEvent;
+begin Result := EV.fOnMouseLeave; end;
+function TControl.Get_OnTestMouseOver: TOnTestMouseOver;
+begin Result := EV.fOnTestMouseOver; end;
+function TControl.Get_OnEndEditLVItem: TOnEditLVItem;
+begin Result := EV.fOnEndEditLVItem; end;
+function TControl.Get_OnDeleteLVItem: TOnDeleteLVItem;
+begin Result := EV.fOnDeleteLVItem; end;
+function TControl.Get_OnLVData: TOnLVData;
+begin Result := EV.fOnLVData; end;
+function TControl.Get_OnCompareLVItems: TOnCompareLVItems;
+begin Result := EV.fOnCompareLVItems; end;
+procedure TControl.Set_OnCompareLVItems(const Value: TOnCompareLVItems);
+begin ProvideUniqueEvents.fOnCompareLVItems := Value; end;
+function TControl.Get_OnColumnClick: TOnLVColumnClick;
+begin Result := EV.fOnColumnClick; end;
+function TControl.Get_OnLVStateChange: TOnLVStateChange;
+begin Result := EV.FOnLVStateChange; end;
+function TControl.Get_OnDrawItem: TOnDrawItem;
+begin Result := EV.fOnDrawItem; end;
+function TControl.Get_OnLVCustomDraw: TOnLVCustomDraw;
+begin Result := EV.fOnLVCustomDraw; end;
+function TControl.Get_OnTVBeginDrag: TOnTVBeginDrag;
+begin Result := EV.FOnTVBeginDrag; end;
+procedure TControl.Set_OnTVBeginDrag(const Value: TOnTVBeginDrag);
+begin ProvideUniqueEvents.FOnTVBeginDrag := Value; end;
+function TControl.Get_OnTVBeginEdit: TOnTVBeginEdit;
+begin Result := EV.FOnTVBeginEdit; end;
+procedure TControl.Set_OnTVBeginEdit(const Value: TOnTVBeginEdit);
+begin ProvideUniqueEvents.FOnTVBeginEdit := Value; end;
+function TControl.Get_OnTVEndEdit: TOnTVEndEdit;
+begin Result := EV.FOnTVEndEdit; end;
+procedure TControl.Set_OnTVEndEdit(const Value: TOnTVEndEdit);
+begin ProvideUniqueEvents.fOnTVEndEdit := Value; end;
+function TControl.Get_OnTVExpanding: TOnTVExpanding;
+begin Result := EV.FOnTVExpanding; end;
+procedure TControl.Set_OnTVExpanding(const Value: TOnTVExpanding);
+begin ProvideUniqueEvents.FOnTVExpanding := Value; end;
+function TControl.Get_OnTVExpanded: TOnTVExpanded;
+begin Result := EV.FOnTVExpanded; end;
+procedure TControl.Set_OnTVExpanded(const Value: TOnTVExpanded);
+begin ProvideUniqueEvents.FOnTVExpanded := Value; end;
+function TControl.Get_OnTVDelete: TOnTVDelete;
+begin Result := EV.FOnTVDelete; end;
+function TControl.Get_OnTVSelChanging: TOnTVSelChanging;
+begin Result := EV.fOnTVSelChanging; end;
+procedure TControl.Set_OnTVSelChanging(const Value: TOnTVSelChanging);
+begin ProvideUniqueEvents.FOnTVSelChanging := Value; end;
+function TControl.Get_OnDTPUserString: TDTParseInputEvent;
+begin Result := EV.FOnDTPUserString; end;
+procedure TControl.Set_OnDTPUserString(const Value: TDTParseInputEvent);
+begin ProvideUniqueEvents.FOnDTPUserString := Value; end;
+function TControl.Get_OnSBBeforeScroll: TOnSBBeforeScroll;
+begin Result := EV.FOnSBBeforeScroll; end;
+procedure TControl.Set_OnSBBeforeScroll(const Value: TOnSBBeforeScroll);
+begin ProvideUniqueEvents.fOnSBBeforeScroll := Value; end;
+function TControl.Get_OnSBScroll: TOnSBScroll;
+begin Result := EV.FOnSBScroll; end;
+procedure TControl.Set_OnSBScroll(const Value: TOnSBScroll);
+begin ProvideUniqueEvents.FOnSBScroll := Value; end;
+function TControl.Get_OnScroll: TOnScroll;
+begin Result := EV.fOnScroll; end;
+function TControl.Get_OnMessage: TOnMessage;
+begin Result := EV.fOnMessage; end;
+procedure TControl.Set_OnMessage(const Value: TOnMessage);
+begin ProvideUniqueEvents.fOnMessage := Value; end;
+function TControl.Get_TOnEvent(const Index: Integer): TOnEvent;
+begin Result := TOnEvent( EV.MethodEvents[Index] ); end;
+procedure TControl.Set_TOnEvent(const Index: Integer; const Value: TOnEvent);
+begin ProvideUniqueEvents.MethodEvents[Index] := TMethod( Value ); end;
+function TControl.Get_OnDropFiles: TOnDropFiles;
+begin Result := EV.fOnDropFiles; end;
+{$ENDIF EVENTS_DYNAMIC}//-------------------------------------------------------
+{$IFnDEF NOT_USE_RICHEDIT}
+procedure TControl.FreeCharFormatRec;
+begin {$IFnDEF STATIC_RICHEDIT_DATA} FreeMem( DF.fRECharFormatRec ); {$ENDIF} end;
+{$ENDIF}
+function TControl.GetAnchor(const Index: Integer): Boolean;
+begin Result := fAnchors and Index <> 0; end;
+procedure TControl.SetAnchor(const Index: Integer; const Value: Boolean);
+begin if Value then
+ fAnchors := fAnchors or Index
+ else fAnchors := fAnchors and not Index;
+ if Parent <> nil then
+ begin
+ fParent.AttachProc( ParentAnchorChildren );
+ Parent.fOldWidth := Parent.ClientWidth;
+ Parent.fOldHeight := Parent.ClientHeight;
+ end;
+end;////////////////////////////////////////////////////////////////////////////
+function TControl.Get_StatusWnd: HWND;
+begin Result := 0;
+ if fStatusCtl <> nil then
+ Result := fStatusCtl.GetWindowHandle;
+end;////////////////////////////////////////////////////////////////////////////
+function TControl.Get_Prop_Int(PropName: PKOLChar): Integer;
+begin Result := GetProp( GetWindowHandle, PropName ); end;
+procedure TControl.Set_Prop_Int(PropName: PKOLChar; const Value: Integer);
+begin SetProp( GetWindowHandle, PropName, Value ); end;
+function TControl.GetHelpContext: Integer;
+begin Result := 0;
+ if fHandle <> 0 then
+ Result := GetWindowContextHelpId( fHandle );
+end;////////////////////////////////////////////////////////////////////////////
+function TControl.Get_Ctl3D: Boolean;
+begin Result := fCtl3D_child and 2 <> 0; end;
+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}////////////////////////////////////////////////////////////
+destructor TCommandActionsObj.Destroy;
+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}///////////////////////////////////////////////////////////////////
+{$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}//-----------------------------------------------------------
+
+end.
+
+
+
+
+
+
+
+
|