8255c47a3d
git-svn-id: https://svn.code.sf.net/p/kolmck/code@110 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
61421 lines
2.1 MiB
61421 lines
2.1 MiB
//[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.16
|
|
****************************************************************
|
|
|
|
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 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}
|
|
|
|
{$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}
|
|
{$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 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..MaxInt div SizeOf(Pointer) - 1] 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}
|
|
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}
|
|
|
|
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;
|
|
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: Integer;
|
|
{* Returns Handle value (if allocated), releasing it from the
|
|
object (so, it is no more knows about this handle and its
|
|
HandleAllocated function returns False. }
|
|
{$ENDIF GDI}
|
|
property Color: TColor {index go_Color} read fData.Color write SetColor;
|
|
{* Color is the most common property for all Pen, Brush and
|
|
Font objects, so it is placed in its common for all of them. }
|
|
function Assign( Value: PGraphicTool ): PGraphicTool;
|
|
{* Assigns properties of the same (only) type graphic object,
|
|
excluding Handle. If assigning is really leading to change
|
|
object, procedure Changed is called. }
|
|
{$IFDEF GDI}
|
|
procedure AssignHandle( NewHandle: Integer );
|
|
{* Assigns value to Handle property. }
|
|
|
|
property BrushBitmap: HBitmap read {-BCB-}fData.Brush.Bitmap{+BCB+}
|
|
{BCB++}(*GetBrushBitmap*){--BCB}
|
|
write SetBrushBitmap;
|
|
{* Brush bitmap. For more info about using brush bitmap,
|
|
see Delphi or Win32 help files. }
|
|
{$ENDIF GDI}
|
|
property BrushStyle: TBrushStyle read {-BCB-}fData.Brush.Style{+BCB+}
|
|
{BCB++}(*GetBrushStyle*){--BCB}
|
|
write SetBrushStyle;
|
|
{$IFDEF GDI}
|
|
{* Brush style. }
|
|
property BrushLineColor: TColor index go_BrushLineColor
|
|
{$IFDEF F_P}
|
|
read GetInt
|
|
{$ELSE DELPHI}
|
|
read {-BCB-}fData.Brush.LineColor{+BCB+}
|
|
{BCB++}(*GetInt*){--BCB}
|
|
{$ENDIF F_P/DELPHI}
|
|
write SetInt;
|
|
{* Brush line color, used to represent lines in hatched brush. Default value is clBlack. }
|
|
|
|
{$ENDIF GDI}
|
|
property FontHeight: Integer index go_FontHeight
|
|
{$IFDEF F_P}
|
|
read GetInt
|
|
{$ELSE DELPHI}
|
|
read {-BCB-}fData.Font.Height{+BCB+}
|
|
{BCB++}(*GetInt*){--BCB}
|
|
{$ENDIF F_P/DELPHI}
|
|
write SetInt;
|
|
{* Font height. Value 0 (default) 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: -11;
|
|
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: 'Tahoma';
|
|
{$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}
|
|
procedure SpeakerBeep( Freq: Word; Duration: DWORD );
|
|
{* On Windows NT, calls Windows.Beep. On Windows 9x, produces beep on speaker
|
|
of desired frequency during given duration time (in milliseconds). }
|
|
{$ENDIF WIN}
|
|
|
|
function 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;
|
|
{* }
|
|
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;
|
|
{*
|
|
|
|
<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 }
|
|
function TruncD( D: Double ): Double;
|
|
{* 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}
|
|
function Format( const fmt: KOLString; params: array of const ): KOLString;
|
|
{* Uses API call to wvsprintf, so does not understand extra formats,
|
|
such as floating point, date/time, currency conversions. See list of
|
|
available formats in win32.hlp (topic wsprintf).
|
|
|<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 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}
|
|
|
|
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(const 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;
|
|
{* }
|
|
function CompareAnsiCase( const S1, S2: PAnsiChar ): Integer;
|
|
function CompareAnsiNoCase( const S1, S2: PAnsiChar ): 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 Pascal-style string into null-terminaed one. }
|
|
function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar;
|
|
{* Copyes first MaxLen characters of Pascal-style string into
|
|
null-terminated one. }
|
|
|
|
function DelimiterLast( const Str, Delimiters: KOLString ): Integer;
|
|
{* Returns index of the last of delimiters given by same named parameter
|
|
among characters of Str. If there are no delimiters found, length of
|
|
Str is returned. This function is intended mainly to use in filename
|
|
parsing functions. }
|
|
function __DelimiterLast( Str, Delimiters: PKOLChar ): PKOLChar;
|
|
{* Returns address of the last of delimiters given by Delimiters parameter
|
|
among characters of Str. If there are no delimeters found, position of
|
|
the null terminator in Str is returned. This function is intended
|
|
mainly to use in filename parsing functions. }
|
|
{$IFDEF _D3orHigher}
|
|
function W__DelimiterLast( Str, Delimiters: PWideChar ): PWideChar;
|
|
{* }
|
|
{$ENDIF _D3orHigher}
|
|
function SkipSpaces( P: PKOLChar ): PKOLChar;
|
|
{* Skips all characters #1..' ' in a string.
|
|
}
|
|
{$IFDEF F_P}
|
|
function DummyStrFun( const S: 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 charactertime marker string (usually P or A, in English locales).
|
|
tt Multicharactertime marker string (usually PM or AM, in English locales).
|
|
|</pre>
|
|
E.g., 'D, yyyy/MM/dd h:mm:ss'.
|
|
See also Str2DateTimeShort function.
|
|
}
|
|
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.
|
|
|<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;
|
|
{* }
|
|
function DiskFreeSpace( const Path: KOLString ): I64;
|
|
{* 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 SwapStrListExItems( const Sender: Pointer; const e1, e2: DWORD );
|
|
|
|
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. }
|
|
function DirectorySize( const Path: KOLString ): I64;
|
|
{* Returns directory size in bytes as large 64 bit integer. }
|
|
|
|
{$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}
|
|
procedure Chk_BitBlt;
|
|
{$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;
|
|
|
|
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). }
|
|
|
|
//......... these declarations are here to stop hints from Delphi5 while compiling MCK:
|
|
function CallTControlCreateWindow( Ctl: PControl ): Boolean;
|
|
function DumpWindowed( c: PControl ): PControl;
|
|
function WndProcAppAsm( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
|
|
//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}
|
|
{$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 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}
|
|
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 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}
|
|
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}
|
|
|
|
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;
|
|
|
|
////////////////////////////////////////////////////////////////////////////////
|
|
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;
|
|
|
|
{$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}
|
|
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 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}
|
|
|
|
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}
|
|
|
|
{$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}
|
|
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}
|
|
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: Integer);
|
|
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: Integer;
|
|
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;
|
|
|
|
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;
|
|
|
|
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;
|
|
|
|
function IntPower(Base: Extended; Exponent: Integer): Extended;
|
|
{$IFDEF F_P}
|
|
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 F_P/DELPHI}
|
|
|
|
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;
|
|
|
|
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;
|
|
|
|
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
|
|
asm
|
|
FLD [E]
|
|
FBSTP [Buf1]
|
|
end;
|
|
if Buf1[ 7 ] <> 0 then break;
|
|
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}
|
|
|
|
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};
|
|
|
|
function StrCat( Dest, Source: PAnsiChar ): PAnsiChar;
|
|
begin
|
|
StrCopy( StrScan( Dest, #0 ), Source );
|
|
Result := Dest;
|
|
end;
|
|
|
|
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};
|
|
|
|
function StrRScan(const 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};
|
|
|
|
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};
|
|
|
|
{$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;
|
|
|
|
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};
|
|
|
|
{$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;
|
|
|
|
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};
|
|
|
|
{$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}
|
|
|
|
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};
|
|
|
|
|
|
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 );
|
|
begin
|
|
Swap( Integer( R.A[AnsiChar(e1)] ),
|
|
Integer( R.A[AnsiChar(e2)] ) );
|
|
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;
|
|
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
|
|
Swap( Integer( R.A[Pred(c)] ), Integer( R.A[c] ) );
|
|
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;
|
|
|
|
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};
|
|
|
|
{$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;
|
|
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;
|
|
|
|
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};
|
|
|
|
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 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};
|
|
|
|
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}
|
|
|
|
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};
|
|
{$IFDEF WIN}
|
|
{$IFNDEF _FPC}
|
|
{$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;
|
|
|
|
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 _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 );
|
|
Result := CompareFileTime( ft1, ft2 );
|
|
{$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
|
|
Result := CompareFileTime( FT1, FT2 );
|
|
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;
|
|
|
|
function DirectorySize( const Path: KOLString ): I64;
|
|
var DirList: PDirList;
|
|
I: Integer;
|
|
begin
|
|
Result := MakeInt64( 0, 0 );
|
|
DirList := NewDirList( Path, {$IFDEF LIN} '*' {$ELSE} '*.*' {$ENDIF}, 0 );
|
|
for I := 0 to DirList.Count-1 do
|
|
begin
|
|
if LongBool( DirList.Items[ I ].dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY ) then
|
|
Result := Add64( Result, DirectorySize( DirList.Path + DirList.Names[ I ] ) )
|
|
else Result := Add64( Result, MakeInt64( DirList.Items[ I ].nFileSizeLow,
|
|
DirList.Items[ I ].nFileSizeHigh ) );
|
|
end;
|
|
DirList.Free;
|
|
end;
|
|
|
|
{$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
|
|
function GetFileList(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;
|
|
|
|
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;
|
|
|
|
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 _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}
|
|
if Data.Rules[ I ] = sdrBySizeDescending then
|
|
Result := -Result;
|
|
end;
|
|
sdrByDateCreate:
|
|
Result := CompareFileTime( Item1.ftCreationTime, Item2.ftCreationTime );
|
|
sdrByDateChanged:
|
|
Result := CompareFileTime( Item1.ftLastWriteTime, Item2.ftLastWriteTime );
|
|
sdrByDateAccessed:
|
|
Result := CompareFileTime( Item1.ftLastAccessTime, Item2.ftLastAccessTime );
|
|
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. }
|
|
|
|
procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: Word);
|
|
{$IFDEF F_P}
|
|
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;
|
|
|
|
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;
|
|
|
|
// + ECM
|
|
function Str2DateTimeShortEx( const S: KOLString ): TDateTime;
|
|
var St: KOLString;
|
|
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;
|
|
St := S;
|
|
if Pos(DateSeparator,S) = 0 then
|
|
St := '0.0.0 '+S;
|
|
Result := Str2DateTimeShort(St);
|
|
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}
|
|
if not SetPriorityClass(GetCurrentProcess, Value) then
|
|
begin
|
|
ShowMessage( SysErrorMessage( GetLastError ) );
|
|
end;
|
|
{$ELSE}
|
|
{$IFDEF PSEUDO_THREADS}
|
|
FPrtyCls := Value;
|
|
{$ELSE}
|
|
SetPriorityClass(GetCurrentProcess, Value);
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
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}
|
|
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;
|
|
//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}
|
|
F := nil;
|
|
TRY
|
|
F := ParentForm; // or Applet - for form ???
|
|
EXCEPT
|
|
asm
|
|
nop
|
|
end;
|
|
END;
|
|
{$ELSE}
|
|
F := ParentForm; // or Applet - for form ???
|
|
{$ENDIF}
|
|
if F <> nil then
|
|
if F.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}
|
|
{$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 FPC21}@{$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;
|
|
begin
|
|
Result := True;
|
|
case Msg.message of
|
|
WM_KEYDOWN, WM_SYSKEYDOWN:
|
|
{$IFDEF NIL_EVENTS}
|
|
if assigned( Self_.EV.fOnKeyDown ) then
|
|
{$ENDIF}
|
|
Self_.EV.fOnKeyDown( Self_, Msg.wParam, GetShiftState );
|
|
WM_KEYUP, WM_SYSKEYUP:
|
|
{$IFDEF NIL_EVENTS}
|
|
if assigned( Self_.EV.fOnKeyUp ) then
|
|
{$ENDIF}
|
|
Self_.EV.fOnKeyUp( Self_, Msg.wParam, GetShiftState );
|
|
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_DESTROY:
|
|
begin
|
|
{$IFDEF USE_FLAGS} include( fFlagsG2, G2_BeginDestroying );
|
|
{$ELSE} fBeginDestroying := TRUE; {$ENDIF}
|
|
{$IFDEF SAFE_CODE}
|
|
(*{$IFDEF USE_PROP}
|
|
PropInt[ ID_SELF ] := 0;
|
|
{$ELSE}
|
|
SetWindowLong( fHandle, GWL_USERDATA, 0 );
|
|
{$ENDIF}*)
|
|
{$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;
|
|
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
|
|
TranslateMessage( Windows.TMsg( Msg ) );
|
|
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 ord(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}
|
|
try
|
|
{$ENDIF}
|
|
if fCommandActions.aGetCount = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
|
|
Result := Perform( fCommandActions.aGetCount, 0, 0 );
|
|
{$IFDEF DEBUG}
|
|
except
|
|
asm
|
|
int 3
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
{$ENDIF 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 );
|
|
/// WTF?? Dufa 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 ////////////////
|
|
|
|
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;
|
|
|
|
procedure WStrLCopy( Dest, Src: PWideChar; MaxLen: Integer );
|
|
begin
|
|
while MaxLen > 0 do
|
|
begin
|
|
Dest^ := Src^;
|
|
if Src^ = #0 then break;
|
|
inc( Dest );
|
|
inc( Src );
|
|
dec( MaxLen );
|
|
if MaxLen = 0 then
|
|
Dest^ := Src^;
|
|
end;
|
|
end;
|
|
|
|
function WStrCmp( 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;
|
|
|
|
{$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;
|
|
|
|
{ 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}
|
|
ShowMessage( AnsiString('Can not load bitmap ') + BmpRsrcName + ', error ' +
|
|
Int2Str( GetLastError ) + ': ' + SysErrorMessage( GetLastError ) );
|
|
{$ENDIF}
|
|
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}
|
|
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}
|
|
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
|
|
asm
|
|
nop
|
|
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 Msg.wParam = 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.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|