pascal/kolmck
pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity
a9b1bcfe0f
kolmck/KOL.pas
dkolmck a9b1bcfe0f v3k 
git-svn-id: https://svn.code.sf.net/p/kolmck/code@81 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
2010-10-16 14:08:10 +00:00

65182 lines
2.1 MiB
Raw Blame History

//[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 Kladov Vladimir.
****************************************************************
* VERSION 3.00.L
****************************************************************
K.O.L. - is a set of objects to create small programs
with the Delphi, but without the VCL. KOL allows to
create executables of size about 10 times smaller then
those created with the VCL. 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-2003.
For code provided by other developers (even if later
changed by me) authors are noted in the source.
mailto: bonanzas@online.sinor.ru
Web-Page: http://bonanzas.rinet.ru
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=&nbsp;&nbsp;&nbsp;<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.
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.
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 - 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
{$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}
{$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}
{$DEFINE SAFE_CODE}
{$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 UNICODE_CTRLS}
{$IFDEF _D2}
{$ERROR 'Delphi 2 cannot compile with UNICODE_CTRLS defined!'}
{$ENDIF}
const
SizeOfKOLChar = SizeOf(WideChar);
type
KOLString = WideString;
KOL_String = type WideString;
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}
{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 4 - 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;
{$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}
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: WideString ): 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: WideString;
{* 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: WideString ): PStream;
{* Creates file stream for read only. }
function NewWriteFileStreamW( const FileName: WideString ): PStream;
{* Creates file stream for write only. Truncating of file (if needed)
is provided automatically. }
function NewReadWriteFileStreamW( const FileName: WideString ): PStream;
{* Creates stream for read and write file. To truncate file, if it is
necessary, change Size property. }
{$ENDIF}
function NewExFileStream( F: HFile ): PStream;
{* Creates read only stream to read from opened file or pipe from the current
position.
When stream is destroyed, file handle still not closed (your code should do
this) and file position is not changed (after the last read operation). }
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 procedure
GetAddressOfWrittenBlock. It is guarantee that blocks of memory allocated
during write process never are relocated until destruction the stream. }
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=... }
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}
end;
var DefaultNameDelimiter: AnsiChar = '=';
ThsSeparator: AnsiChar = ',';
function NewStrList: PStrList;
{* Creates string list object. }
{$IFDEF WIN}
function GetFileList(const dir: Ansistring): PStrList;
{* By Alexander Shakhaylo. Returns list of file names of the given directory. }
{$ENDIF WIN}
{$IFNDEF _FPC}
function WStrLen( W: PWideChar ): Integer;
{* Returns Length of null-terminated Unicode string. }
{$IFDEF _D3orHigher}
function UTF8_2WideString( const s: AnsiString ): WideString;
{$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. }
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): WideString;
procedure SetItems(Idx: Integer; const Value: WideString);
function GetPtrs(Idx: Integer): PWideChar;
function GetText: WideString;
protected
fList: PList;
fText: PWideChar;
fTextBufSz: Integer;
fTmp1, fTmp2: WideString;
procedure Init; virtual;
public
procedure SetText(const Value: WideString);
{* See also TStrList.SetText }
destructor Destroy; virtual;
{* }
procedure Clear;
{* See also TStrList.Clear }
property Items[ Idx: Integer ]: WideString read GetItems write SetItems;
{* See also TStrList.Items }
property ItemPtrs[ Idx: Integer ]: PWideChar read GetPtrs;
{* See also TStrList.ItemPtrs }
property Count: Integer read GetCount;
{* See also TStrList.Count }
function Add( const W: WideString ): Integer;
{* See also TStrList.Add }
procedure Insert( Idx: Integer; const W: WideString );
{* See also TStrList.Insert }
procedure Delete( Idx: Integer );
{* See also TStrList.Delete }
property Text: WideString read GetText write SetText;
{* See also TStrList.Text }
procedure AddWStrings( WL: PWStrList );
{* See also TStrList.AddStrings }
procedure Assign( WL: PWStrList );
{* See also TStrList.Assign }
function LoadFromFile( const Filename: KOLString ): Boolean;
{* See also TStrList.LoadFromFile }
procedure LoadFromStream( Strm: PStream );
{* See also TStrList.LoadFromStream }
function MergeFromFile( const Filename: KOLString ): Boolean;
{* See also TStrList.MergeFromFile }
procedure MergeFromStream( Strm: PStream );
{* See also TStrList.MergeFromStream }
function SaveToFile( const Filename: KOLString ): Boolean;
{* See also TStrList.SaveToFile }
procedure SaveToStream( Strm: PStream );
{* See also TStrList.SaveToStream }
function AppendToFile( const Filename: KOLString ): Boolean;
{* See also TStrList.AppendToFile }
procedure Swap( Idx1, Idx2: Integer );
{* See also TStrList.Swap }
procedure Sort( CaseSensitive: Boolean );
{* See also TStrList.Sort }
procedure Move( IdxOld, IdxNew: Integer );
{* See also TStrList.Move }
function IndexOf( const s: WideString ): Integer;
{* }
function IndexOf_NoCase( const s: WideString ): Integer;
{* }
function Last: WideString;
{* }
procedure Put(Idx: integer; const Value: WideString);
{* +azsd for TBButton }
protected // by Alexander Pravdin:
fNameDelim: WideChar;
function GetLineName( Idx: Integer ): WideString;
procedure SetLineName( Idx: Integer; const NV: WideString );
function GetLineValue(Idx: Integer): WideString;
procedure SetLineValue(Idx: Integer; const Value: WideString);
public
property LineName[ Idx: Integer ]: WideString read GetLineName write SetLineName;
property LineValue[ Idx: Integer ]: WideString read GetLineValue write SetLineValue;
property NameDelimiter: WideChar read fNameDelim write fNameDelim;
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 );
{* }
function AddObject( const S: WideString; Obj: DWORD ): Integer;
{* Adds a string and associates given number with it. Index of the item added
is returned. }
procedure InsertObject( Before: Integer; const S: WideString; Obj: DWORD );
{* Inserts a string together with object associated. }
function IndexOfObj( Obj: Pointer ): Integer;
{* Returns an index of a string associated with the object passed as a
parameter. If there are no such strings, -1 is returned. }
end;
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;
////////////////////////////////////////////////////////////////////////////////
// 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;
fOnChange: TOnGraphicChange;
fData: TGDIToolData;
fNewProc: TNewGraphicTool;
{$IFDEF GDI}
fMakeHandleProc: function( Self_: PGraphicTool ): THandle;
{$ENDIF GDI}
procedure SetInt( const Index: Integer; Value: Integer );
function GetInt( const Index: Integer ): Integer;
procedure SetColor( Value: TColor );
{$IFDEF GDI}
function GetBrushBitmap: HBitmap; // for BCB only
procedure SetBrushBitmap(const Value: HBitmap);
function GetBrushStyle: TBrushStyle; // for BCB only
{$ENDIF GDI}
procedure SetBrushStyle(const Value: TBrushStyle);
function GetFontName: KOLString;
procedure SetFontName(const Value: KOLString);
function GetFontStyle: TFontStyle;
procedure SetFontStyle(const Value: TFontStyle);
function GetFontWeight: Integer; // for BCB only
procedure SetFontWeight(const Value: Integer);
{$IFDEF GDI}
function GetFontCharset: TFontCharset; // for BCB only
procedure SetFontCharset(const Value: TFontCharset);
function GetFontQuality: TFontQuality; // for BCB only
procedure SetFontQuality(const Value: TFontQuality);
function GetFontOrientation: Integer; // for BCB only
procedure SetFontOrientation(Value: Integer);
function GetFontPitch: TFontPitch; // for BCB only
procedure SetFontPitch(const Value: TFontPitch);
function GetPenMode: TPenMode; // for BCB only
procedure SetPenMode(const Value: TPenMode);
function GetPenStyle: TPenStyle; // for BCB only
procedure SetPenStyle(const Value: TPenStyle);
function GetGeometricPen: Boolean; // for BCB only
procedure SetGeometricPen(const Value: Boolean);
function GetPenEndCap: TPenEndCap; // for BCB only
procedure SetPenEndCap(const Value: TPenEndCap);
function GetPenJoin: TPenJoin; // for BCB only
procedure SetPenJoin(const Value: TPenJoin);
procedure SetLogFontStruct(const Value: TLogFont);
function GetLogFontStruct: TLogFont;
{$ENDIF GDI}
protected
procedure Changed;
{* }
{$IFDEF GDI}
function GetHandle: THandle;
{* }
{$ENDIF GDI}
protected
{$IFDEF _X_}
{$IFDEF GTK}
fPangoFontDesc: PPangoFontDescription;
FUNCTION GetPangoFontDesc: PPangoFontDescription;
{$ENDIF GTK}
{$ENDIF _X_}
public
destructor Destroy; virtual;
{* }
{$IFDEF _X_}
{$IFDEF GTK}
PROPERTY FontHandle: PPangoFontDescription read GetPangoFontDesc;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
property Handle: THandle read GetHandle;
{* Every time, when accessed, real GDI object is created (if it is
not yet created). So, to prevent creating of the handle, use
HandleAllocated instead of comparing Handle with value 0. }
function HandleAllocated: Boolean;
{* Returns True, if handle is allocated (i.e., if real GDI
objet is created. }
{$ENDIF GDI}
property OnChange: TOnGraphicChange read fOnChange write fOnChange;
{* Called, when object is changed. }
{$IFDEF GDI}
function ReleaseHandle: Integer;
{* Returns Handle value (if allocated), releasing it from the
object (so, it is no more knows about this handle and its
HandleAllocated function returns False. }
{$ENDIF GDI}
property Color: TColor {index go_Color} read fData.Color write SetColor;
{* Color is the most common property for all Pen, Brush and
Font objects, so it is placed in its common for all of them. }
function Assign( Value: PGraphicTool ): PGraphicTool;
{* Assigns properties of the same (only) type graphic object,
excluding Handle. If assigning is really leading to change
object, procedure Changed is called. }
{$IFDEF GDI}
procedure AssignHandle( NewHandle: Integer );
{* Assigns value to Handle property. }
property BrushBitmap: HBitmap read {-BCB-}fData.Brush.Bitmap{+BCB+}
{BCB++}(*GetBrushBitmap*){--BCB}
write SetBrushBitmap;
{* Brush bitmap. For more info about using brush bitmap,
see Delphi or Win32 help files. }
{$ENDIF GDI}
property BrushStyle: TBrushStyle read {-BCB-}fData.Brush.Style{+BCB+}
{BCB++}(*GetBrushStyle*){--BCB}
write SetBrushStyle;
{$IFDEF GDI}
{* Brush style. }
property BrushLineColor: TColor index go_BrushLineColor
{$IFDEF F_P}
read GetInt
{$ELSE DELPHI}
read {-BCB-}fData.Brush.LineColor{+BCB+}
{BCB++}(*GetInt*){--BCB}
{$ENDIF F_P/DELPHI}
write SetInt;
{* Brush line color, used to represent lines in hatched brush. Default value is clBlack. }
{$ENDIF GDI}
property FontHeight: Integer index go_FontHeight
{$IFDEF F_P}
read GetInt
{$ELSE DELPHI}
read {-BCB-}fData.Font.Height{+BCB+}
{BCB++}(*GetInt*){--BCB}
{$ENDIF F_P/DELPHI}
write SetInt;
{* Font height. Value 0 (default) 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>&nbsp;&nbsp;&nbsp;
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;
fOnChange: TOnEvent;
{$ENDIF GDI}
fOnGetHandle: TOnGetHandle;
{$IFDEF _X_}
{$IFDEF GTK}
fSavedState: TGdkGCValues;
PROCEDURE SaveState;
PROCEDURE RestoreState;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
procedure SetHandle( Value : HDC );
{$ENDIF GDI}
procedure SetPenPos( const Value : TPoint );
{$IFDEF GDI}
procedure CreatePen;
procedure CreateBrush;
procedure CreateFont;
procedure Changing;
{$ENDIF GDI}
procedure ObjectChanged( Sender : PGraphicTool );
function GetBrush: PGraphicTool;
function GetFont: PGraphicTool;
function GetPen: PGraphicTool;
function GetHandle: HDC;
procedure AssignChangeEvents;
{$IFDEF GDI}
function GetPixels(X, Y: Integer): TColor;
procedure SetPixels(X, Y: Integer; const Value: TColor);
protected
fIsPaintDC : Boolean;
{* TRUE, if DC obtained during current WM_PAINT (or WM_ERASEBKGND?)
processing for a control. This affects a way how Handle is released. }
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 : WideString; 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} //------- WideString not supported in D2
procedure WTextOut(X, Y: Integer; const WText: WideString); stdcall;
{* Draws a Unicode text. }
procedure WExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect;
const WText: WideString; const Spacing: array of Integer );
{* }
procedure WDrawText(WText: WideString; var Rect:TRect; Flags:DWord);
{* }
procedure WTextRect(const Rect: TRect; X, Y: Integer;
const WText: WideString);
{* Draws a Unicode text, clipping output into given rectangle. }
function WTextExtent( const WText: WideString ): TSize;
{* Calculates Unicode text width and height. }
function WTextWidth( const WText: WideString ): Integer;
{* Calculates Unicode text width. }
function WTextHeight( const WText: WideString ): Integer;
{* Calculates Unicode text height. }
{$ENDIF _D2}
{$ENDIF _FPC}
property ModeCopy : TCopyMode read fCopyMode write fCopyMode;
{* Current copy mode. Is used in CopyRect method. }
procedure CopyRect( const DstRect : TRect; SrcCanvas : PCanvas; const SrcRect : TRect );
{* Copyes a rectangle from source to destination, using StretchBlt. }
property OnChange: TOnEvent read fOnChange write fOnChange;
{* }
function Assign( SrcCanvas : PCanvas ) : Boolean;
{* }
{$ENDIF GDI}
{$IFDEF _X_}
protected // for _X_ case, RequiredState is protected yet (???)
procedure ForeBack(fg_color, bk_color: TColor); // install colors just before drawing
{$ENDIF _X_}
{$IFDEF GDI}
function RequiredState( ReqState : DWORD ): HDC; 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 )
{* 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). }
{$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;
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 LoadFromStream( Strm: PStream );
{* Loads bitmap from stream. Follow loading, bitmap has DIB format (without
handle allocated). It is possible to draw DIB bitmap without creating
handle for it, which can economy GDI resources. }
function LoadFromStreamEx( Strm: PStream ): Boolean;
{* Loads bitmap from a stream. Difference is that RLE decoding supported.
Code given by Vyacheslav A. Gavrik. }
procedure SaveToStream( Strm: PStream );
{* Saves bitmap to stream. If bitmap is not DIB, it is converted to DIB
before saving. }
procedure LoadFromResourceID( Inst: DWORD; ResID: Integer );
{* Loads bitmap from resource using integer ID of resource. To load by name,
use LoadFromResurceName. To load resource of application itself, pass
hInstance as first parameter. This method also can be used to load system
predefined bitmaps, if 0 is passed as Inst parameter:
|<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 = 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 );
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 );
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_fOnChange = 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_FOnTVEndEdit = 50;
idx_FOnTVExpanded = 51;
idx_FOnTVExpanding = 52;
idx_FOnTVSelChanging = 53;
idx_FOnSBBeforeScroll = 54;
idx_FOnSBScroll = 55;
idx_FOnDropDown = 56;
idx_FOnCloseUp = 57;
idx_FOnSplit = 58;
idx_FOnProgress = 59;
idx_FOnBitBtnDraw = 60;
idx_FOnTVBeginDrag = 61;
idx_FOnTVBeginEdit = 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>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<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>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<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_NotUpdate ); //
T1Flags = Set of T1Flag;
T2Flag = ( G2_Transparent, G2_DoubleBuffered, G2_ClassicTransparent,
G2_Destroying, G2_BeginDestroying,
G2_ChangedPos, G2_ChangedSize, G2_Focused ); //
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_AllBtnReturnClick, G6_DefaultBtn, G6_CancelBtn,
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;
bVertAlignCenter, bVertAlignTop, 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;
bVertAlignCenter, bVertAlignTop, 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 = ( vaCenter, vaTop, 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: Ansistring;
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}
{$I KOLMHToolTip}
{$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;
fOnChange: 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;
FOnTVEndEdit: TOnTVEndEdit;
FOnTVExpanded: TOnTVExpanded;
FOnTVExpanding: TOnTVExpanding;
FOnTVSelChanging: TOnTVSelChanging;
FOnSBBeforeScroll: TOnSBBeforeScroll;
FOnSBScroll: TOnSBScroll;
FOnDropDown: TOnEvent;
FOnCloseUp: TOnEvent;
FOnSplit: TOnSplit;
FOnProgress: TOnEvent;
FOnBitBtnDraw: TOnBitBtnDraw;
FOnTVBeginDrag: TOnTVBeginDrag;
FOnTVBeginEdit: TOnTVBeginEdit;
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
{$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;
fReserved_Form: Byte;
//-- ! 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;
{$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>&nbsp;&nbsp;&nbsp;<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>. }
protected
function GetAnchor(const Index: Integer): Boolean;
procedure SetAnchor(const Index: Integer; const Value: 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_MDIClient: PControl;
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}
procedure SetOnResize(const Value: TOnEvent);
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);
procedure SetOnDeleteAllLVItems(const Value: TOnEvent);
procedure SetOnDeleteLVItem(const Value: TOnDeleteLVItem);
procedure SetOnEndEditLVItem(const Value: TOnEditLVItem);
procedure SetOnLVData(const Value: TOnLVData);
procedure SetOnColumnClick(const Value: TOnLVColumnClick);
procedure SetOnDrawItem(const Value: TOnDrawItem);
procedure SetOnMeasureItem(const Value: TOnMeasureItem);
procedure SetItemsCount(const Value: Integer);
function GetItemData(Idx: Integer): DWORD;
procedure SetItemData(Idx: Integer; const Value: DWORD);
function GetLVCurItem: Integer;
procedure SetLVCurItem(const Value: Integer);
function GetLVFocusItem: Integer;
procedure SetOnDropFiles(const Value: TOnDropFiles);
procedure SetOnHide(const Value: TOnEvent);
procedure SetOnShow(const Value: TOnEvent);
procedure SetClientMargin(const Index: Integer; Value: ShortInt);
{$IFDEF F_P}
function GetClientMargin(const Index: Integer): Integer;
{$ENDIF F_P}
{$ENDIF GDI}
protected
{$IFDEF _X_}
{$IFDEF GTK}
{} fExposeEvent: Integer;
{$ENDIF GTK}
{$ENDIF _X_}
procedure SetOnPaint(const Value: TOnPaint);
{$IFDEF GDI}
procedure SetOnEraseBkgnd(const Value: TOnPaint);
public procedure SetTVRightClickSelect(const Value: Boolean);
protected
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);
public 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;
{} 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;
{} fAllBtnReturnClick: 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}
{$I KOLMHToolTip}
{$UNDEF var}
{$DEFINE function}
{$I KOLMHToolTip}
{$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. }
{$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>&nbsp;&nbsp;&nbsp;
This method made public, so it can be called directly to
fill some device context's rectangle. But remember, that
independantly of Rect, top left corner of background piece
will be located so, if drawing is occure into ControlRect
rectangle. }
property WindowedParent: PControl read fParent;
{* Returns nearest windowed parent, the same as Parent. }
{$ENDIF GDI}
function ParentForm: PControl;
{* |<#form>
Returns parent form for a control (of @Self for form itself. }
{$IFDEF GDI}
property ActiveControl: PControl read 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>&nbsp;&nbsp;&nbsp;
Call this method to ensure, that a hanle is allocated for a form,
an application button or a control. (It is not necessary to do so in
the most cases, even if You plan to work with control's handle directly.
But immediately after creating the object, if You want to pass its
handle to API function, this can be helpful). }
{$ENDIF GDI}
{$IFDEF _X_}
procedure VisualizyWindow; // for _X_, makes actually visible a window and
// all its subwindows recursively, if they are having Visible = TRUE
{$ENDIF _X_}
{$IFDEF GDI}
procedure Close;
{* |<#appbutton>
|<#form>
Closes window. If a window is the main form, this closes application,
terminating it. Also it is possible to call Close method for Applet
window to stop application. }
{$IFDEF USE_MHTOOLTIP}
{$DEFINE public}
{$I KOLMHToolTip}
{$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>&nbsp;&nbsp;&nbsp;
<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. }
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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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. }
protected
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_fOnChange
read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnChange {$ENDIF}
write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnChange {$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>
Only for listbox and combobox. }
procedure Clear;
{* Clears object content. Has different sense for different controls.
E.g., for label, editbox, button and other simple controls it
assigns empty string to Caption property. For listbox, combobox,
listview it deletes all items. For toolbar, it deletes all buttons.
Et so on. }
property Progress: Integer index ((PBM_SETPOS or $8000) shl 16) or PBM_GETPOS
read GetIntVal write SetIntVal;
{* |<#progressbar>
Only for ProgressBar. }
property MaxProgress: Integer index ((PBM_SETRANGE32 or $8000) shl 16) or PBM_GETRANGE
read GetIntVal write SetMaxProgress;
{* |<#progressbar>
Only for ProgressBar. 100 is the default value. }
property ProgressColor: TColor read fTextColor write SetProgressColor;
{* |<#progressbar>
Only for ProgressBar. }
property ProgressBkColor: TColor read fColor write SetCtlColor; //SetProgressBkColor;
{* |<#progressbar>
Obsolete. Now the same as Color. }
property StatusText[ Idx: Integer ]: 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 TBMoveBtn( FromIdx, ToIdx: Integer ): Boolean;
{* |<#toolbar>
By TR"]F. Moves button from one position to another. }
property TBRows: Integer read TBGetRows write TBSetRows;
{* |<#toolbar>
Returns number of rows for toolbar and allows to try to set
desired number of rows (but system can set another number of
rows in some cases). This property has no effect if tboWrapable
style not present in Options when toolbar is created. }
procedure TBSetTooltips( BtnID1st: Integer; const Tooltips: array of PKOLChar );
{* |<#toolbar>
Allows to assign tooltips to several buttons. Until this procedure
is not called, tooltips list is not created and no code is added
to executable. This method of tooltips maintainance for toolbar buttons
is useful both for static and dynamic toolbars (meaning "dynamic" -
toolbars with buttons, deleted and inserted at run-time). }
property 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 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>&nbsp;&nbsp;&nbsp;
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;
//fMDIClient: PControl;
//{* MDI client window control }
//fMDIChildren: PList;
//{* List of MDI children. It is filled for MDI client window. }
{$IFDEF USE_fNCDestroyed}
{} fNCDestroyed: Boolean;
{$ENDIF USE_fNCDestroyed}
public
property MDIClient: PControl read 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. }
{$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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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} //------- WideString not supported in D2
function RE_WSearchText( const Value: WideString; MatchCase, WholeWord, ScanForward: Boolean;
SearchFrom, SearchTo: Integer ): Integer;
{* |<#richedit>
Searches given string starting from SearchFrom position up to SearchTo
position (to the end of text, if SearchTo is -1). Returns zero-based
character position of the next match, or -1 if there are no more matches.
To search in bacward direction, set ScanForward to False, and pass
SearchFrom > SearchTo (or even SearchFrom = -1 and SearchTo = 0). }
{$ENDIF}
{$ENDIF}
{$ENDIF DISABLE_DEPRECATED}
property RE_AutoURLDetect: Boolean read REGetAutoURLDetect write RESetAutoURLDetect;
{* |<#richedit>
If set to True, automatically detects URLs (and highlights it with
blue color, applying fsItalic and fsUnderline font styles (while
typing and loading). Default value is False. Note: if event OnRE_URLClick
or event OnRE_OverURL are set, property RE_AutoURLDetect is set to True
automatically. }
property RE_URL: 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}
{$UNDEF interface_part}
{$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 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 );
{$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 );
{$IFDEF KEY_PREVIEW}
procedure FormSetKeyPreviewTrue( Form: PControl );
{$ENDIF}
// 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 );
// 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&nbsp;Bao</a>. Implementation:
| <a href=mailto:"bonanzas@xcl.cjb.net">Kladov&nbsp;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 AppletWnd: PControl );
{* |<#appbutton>
Call this procedure to process messages loop of your program.
Pass here pointer to applet button object (if You have created it
- see NewApplet) or your main form object of type PControl (created
using NewForm).
|<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 AppletWnd: 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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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). }
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. }
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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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' );
| &nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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 ): AnsiString;
{* }
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 ): AnsiString;
{* 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 ): AnsiString;
{* 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 ) : AnsiString;
{* 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: PAnsiChar ): 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 : AnsiString) : 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 : AnsiString) : 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: WideString): WideString;
{* Obvious. }
function WLowerCase(const S: WideString): WideString;
{* Obvious. }
{$ENDIF}
{$IFNDEF _D2}
{$IFNDEF _FPC}
function WAnsiUpperCase(const S: WideString): WideString;
{* Obvious. }
function WAnsiLowerCase(const S: WideString): WideString;
{* Obvious. }
function WStrComp(const S1, S2: WideString): Integer;
{* }
function _WStrComp(S1, S2: PWideChar): Integer;
{* }
function WStrScan(Str: PWideChar; Chr: WideChar): PWideChar;
{* Fast search of given character in a string. Pointer to found character
(or nil) is returned. }
function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar;
{* StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr
does not occur in Str, StrRScan returns NIL. The null terminator is
considered to be part of the string. }
{$ENDIF _FPC}
{$ENDIF _D2}
//--- set of functions to work either with AnsiString or with WideString
// 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;
{* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare
operation is controlled by the current Windows locale. The return value
is the same as for CompareStr. }
function _AnsiCompareStrNoCase(S1, S2: PKOLChar): Integer;
{* The same, but for PChar ANSI strings }
function AnsiCompareText( const S1, S2: 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 AnsiCompareStrNoCaseA(const S1, S2: AnsiString): Integer;
{* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare
operation is controlled by the current Windows locale. The return value
is the same as for CompareStr. }
function _AnsiCompareStrNoCaseA_Slow(S1, S2: PAnsiChar): Integer;
function _AnsiCompareStrNoCaseA_Fast(S1, S2: PAnsiChar): Integer;
var _AnsiCompareStrNoCaseA: function(S1, S2: PAnsiChar): Integer =
{$IFDEF SPEED_FASTER} _AnsiCompareStrNoCaseA_Fast
{$ELSE} _AnsiCompareStrNoCaseA_Slow {$ENDIF};
{* The same, but for PChar ANSI strings }
function AnsiCompareTextA( const S1, S2: AnsiString ): Integer;
{* }
{$IFDEF WIN}
{$IFNDEF _FPC}
function LStrFromPWCharLen(Source: PWideChar; Length: Integer): AnsiString;
{* from Delphi5 - because D2 does not contain it. }
function LStrFromPWChar(Source: PWideChar): AnsiString;
{* from Delphi5 - because D2 does not contain it. }
{$ENDIF _FPC}
function WCharIn( C: KOLChar; const Chars: array of KOLChar ): Boolean;
{$ENDIF WIN}
function CopyEnd( const S : KOLString; Idx : Integer ) : KOLString;
{* Returns copy of source string S starting from Idx up to the end of
string S. Works correctly for case, when Idx > Length( S ) (returns
empty string for such case). }
function CopyTail( const S : KOLString; Len : Integer ) : KOLString;
{* Returns last Len characters of the source string. If Len > Length( S ),
entire string S is returned. }
procedure DeleteTail( var S : KOLString; Len : Integer );
{* Deletes last Len characters from string. }
function IndexOfChar( const S : KOLString; Chr : KOLChar ) : Integer;
{* Returns index of given character (1..Length(S)), or
-1 if a character not found. }
function IndexOfCharsMin( const S, Chars : KOLString ) : Integer;
{* Returns index (in string S) of those character, what is taking place
in Chars string and located nearest to start of S. If no such
characters in string S found, -1 is returned. }
{$IFDEF _D3orHigher}
function WIndexOfChar( const S : WideString; Chr : WideChar ) : Integer;
function WIndexOfCharsMin( const S, Chars : WideString ) : Integer;
{$ENDIF}
{$IFNDEF _D2}
{$IFNDEF _FPC}
function IndexOfWideCharsMin( const S, Chars : WideString ) : Integer;
{* Returns index (in wide string S) of those wide character, what
is taking place in Chars wide string and located nearest to start of S.
If no such characters in string S found, -1 is returned. }
{$ENDIF _FPC}
{$ENDIF _D2}
function IndexOfStr( const S, Sub : 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 : WideString; const Separators : WideString ) : WideString;
{$ENDIF}
{$IFNDEF _FPC}
{$IFNDEF _D2}
function WParse( var S : WideString; const Separators : WideString ) : WideString;
{* Returns first wide characters of wide string S, separated from others
by one of wide characters, taking place in Separators wide string,
assigning a tail of wide string (following found separator) to the
source one. If there are no separator characters found, source wide
string S is returned, and source wide string itself becomes empty. }
{$ENDIF _D2}
{$ENDIF _FPC}
function ParsePascalString( var S : AnsiString; const Separators : AnsiString ) : AnsiString;
{* 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 : AnsiString ) : AnsiString;
{* 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 : WideString ) : Boolean;
{* Returns True, if AnsiLowerCase(S1) = AnsiLowerCase(S2). I.e., if ANSI
stringsare equal to each other without caring of characters case
sensitivity. }
{$ENDIF _FPC}
{$ENDIF _D2}
function StrIn( const S : AnsiString; const A : array of String ) : Boolean;
{* Returns True, if S is "equal" to one of strings, taking place
in A array. To check equality, StrEq function is used, i.e.
comaprison is taking place without case sensitivity. }
{$IFNDEF _FPC}
type TSetOfChar = Set of AnsiChar;
{$IFNDEF _D2}
function WStrIn( const S : WideString; const A : array of WideString ) : Boolean;
{* Returns True, if S is "equal" to one of strings, taking place
in A array. To check equality, WAnsiEq function is used, i.e.
comaprison is taking place without case sensitivity. }
function CharIn( C: KOLChar; const A: TSetOfChar ): Boolean;
{* To replace expressions like S[1] in [ '0'..'z' ] to CharIn( S[ 1 ], [ '0'..'z' ] )
(and to avoid problems with Unicode version of code). }
{$ENDIF _D2}
{$ENDIF _FPC}
function StrIs( const S : 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: AnsiString; const From, ReplTo: AnsiString ): Boolean;
{* Replaces first occurance of From to ReplTo in S, returns True,
if pattern From was found and replaced. }
function KOLStrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean;
{* Replaces first occurance of From to ReplTo in S, returns True,
if pattern From was found and replaced. }
{$IFNDEF _FPC}
{$IFNDEF _D2}
function WStrReplace( var S: WideString; const From, ReplTo: WideString ): Boolean;
{* Replaces first occurance of From to ReplTo in S, returns True,
if pattern From was found and replaced. See also function StrReplace.
This function is not available in Delphi2 (this version of Delphi
does not support WideString type). }
{$ENDIF _D2}
{$ENDIF _FPC}
function StrRepeat( const S: AnsiString; Count: Integer ): AnsiString;
{* Repeats given string Count times. E.g., StrRepeat( 'A', 5 ) gives 'AAAAA'. }
{$IFNDEF _FPC}
{$IFNDEF _D2}
function WStrRepeat( const S: WideString; Count: Integer ): WideString;
{* Repeats given wide string Count times. E.g., StrRepeat( 'A', 5 ) gives 'AAAAA'. }
{$ENDIF _D2}
{$ENDIF _FPC}
procedure NormalizeUnixText( var S: 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) }
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: WideString;
{* 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: WideString ): 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}
type
//TDateTime = Double; // well, it is already defined so in System.pas
{* Basic date and time type. Integer part represents year and days (as is,
i.e. 1-Jan-2000 is representing by value 730141, which is a number of
days from 1-Jan-0001 to 1-Jan-2000 inclusively). Fractional part is
representing hours, minutes, seconds and milliseconds of a day
proportionally (like in VCL TDateTime type, e.g. 0.5 = 12:00, 0.25 = 6:00,
etc.). }
PDayTable = ^TDayTable;
TDayTable = array[1..12] of Word;
TDateFormat = ( dfShortDate, dfLongDate );
{* Date formats available to use in formatting date/time to string. }
TTimeFormatFlag = ( tffNoMinutes, tffNoSeconds, tffNoMarker, tffForce24 );
{* Additional flags, used for formatting time. }
TTimeFormatFlags = Set of TTimeFormatFlag;
{* Set of flags, used for formatting time. }
const
MonthDays: array [Boolean] of TDayTable =
((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
(31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31));
{* The MonthDays array can be used to quickly find the number of
days in a month: MonthDays[IsLeapYear(Y), M]. }
SecsPerDay = 24 * 60 * 60;
{* Seconds per day. }
MSecsPerDay = SecsPerDay * 1000;
{* Milliseconds per day. }
VCLDate0 = 693594;
{* Value to convert VCL "date 0" to KOL "date 0" and back.
This value corresponds to 30-Dec-1899, 0:00:00. So,
to convert VCL date to KOL date, just subtract this
value from VCL date. And to convert back from KOL date
to VCL date, add this value to KOL date.}
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: WideString; OpenFlags: DWord): THandle;
{* }
{$ENDIF}
function FileCreate(const FileName: KOLString; OpenFlags: DWord): THandle;
{* Call this function to open existing or create new file. OpenFlags
parameter can be a combination of up to three flags (by one from
each group:
|<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: WideString ) : 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): WideString;
{* 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: WideString ): Boolean;
{* Saves a string to a file without any changes. If file does not exists, it is
created. If it exists, it is overriden. If operation failed, FALSE is returned. }
function WStrLoadFromFile( const Filename: KOLString ): WideString;
{* Reads entire file and returns its content as a string. If operation failed,
an empty strinng is returned.
|<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 );
{* 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: WideString): Boolean;
{* }
{$ENDIF}
function CheckDirectoryContent( const Name: KOLString; SubDirsOnly: Boolean; const Mask: AnsiString ): 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: WideString ) : WideString;
{* Returns only path part from exact path to file. }
{$ENDIF}
function IsNetworkPath( const Path: KOLString ): Boolean;
{* Returns TRUE, if Path is starting from '\\'. }
function ExtractFileName( const Path: KOLString ) : KOLString;
{* Extracts file name from exact path to file. }
function ExtractFileNameWOext( const Path: KOLString ) : KOLString;
{* Extracts file name from path to file or from filename. }
function ExtractFileExt( const Path: KOLString ) : KOLString;
{* Extracts extention from file name (returns it with dot '.' first) }
function ReplaceExt( const Path, NewExt: KOLString ): KOLString;
{* Returns Path to a file with extension replaced to a new extension.
Pass a new extension started with '.', e.g. '.txt'. }
function ForceDirectories(Dir: KOLString): Boolean;
{* by Edward Aretino. Creates given directory if not present. All needed
subdirectories are created if necessary. }
function CreateDir(const Dir: KOLString): Boolean;
{* by Edward Aretino. Creates given directory. }
function ChangeFileExt(FileName: KOLString; const Extension: KOLString): KOLString;
{* by Edward Aretino. Changes file extention. }
function ReplaceFileExt( const Path, NewExt: KOLString ): KOLString;
{* Returns a path with extension replaced to a given one. }
{$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
function ExtractShortPathName( const Path: KOLString ): KOLString;
{* }
{$IFDEF GDI}
function FilePathShortened( const Path: KOLString; MaxLen: Integer ): KOLString;
{* Returns shortened file path to fit MaxLen characters. }
function FilePathShortenPixels( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
{* Returns shortened file path to fit MaxPixels for a given DC. If you pass
Canvas.Handle of any control or bitmap object, ensure that font is valid
for it (or call TCanvas.RequiredState( FontValid ) method before. If DC passed
= 0, call is equivalent to call FilePathShortened, and MaxPixels means in such
case maximum number of characters. }
function MinimizeName( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
{* Exactly the same as MinimizeName in FileCtrl.pas (VCL). }
{$ENDIF GDI}
function GetSystemDir: KOLString;
{* Returns path to windows system directory. }
function GetWindowsDir : KOLString;
{* Returns path to Windows directory. }
{$ENDIF WIN} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
function GetWorkDir : KOLString;
{* Returns path to application's working directory. }
function GetTempDir : KOLString;
{* Returns path to default temp folder (directory to place temporary files). }
function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString;
{* Returns path to just created temporary file. }
function GetFileListStr(FPath{e.g.'c:\tmp\'}, FMask{e.g.'*.*'}: KOLString): KOLString;
{* List of files in string, separating each path from others with a character stored
in FileOpSeparator variables (#13 by default).
E.g.: 'c:\tmp\unit1.dcu'#13'c:\tmp\unit1.~pa' (for use with DeleteFile2Recycle())}
function DeleteFiles( const DirPath: KOLString ): Boolean;
{* Deletes files by file mask (given with wildcards '*' and '?'). }
{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
var FileOpSeparator: KOLChar = {$IFDEF OLD_COMPAT}';'{$ELSE}#13{$ENDIF};
function DoFileOp( const FromList, ToList: KOLString; FileOp: UINT; Flags: Word;
Title: PKOLChar): Boolean;
{* By Unknown Mystic. FileOp can be: FO_MOVE, FO_COPY, FO_DELETE, FO_RENAME.
Flags can be a combination of values: FOF_MULTIDESTFILES, FOF_CONFIRMMOUSE,
FOF_SILENT, FOF_RENAMEONCOLLISION, FOF_NOCONFIRMATION, FOF_WANTMAPPINGHANDLE,
FOF_ALLOWUNDO, FOF_FILESONLY, FOF_SIMPLEPROGRESS, FOF_NOCONFIRMMKDIR,
FOF_NOERRORUI. Title used only with FOF_SIMPLEPROGRESS. }
function DeleteFile2Recycle( const Filename : KOLString ) : Boolean;
{* Deletes file to recycle bin. This operation can be very slow, when
called for a single file. To delete group of files at once (fast),
pass a list of paths to files to be deleted, separating each path
from others with a character stored in FileOpSeparator variable (by default #13,
but in case when OLD_COMPAT symbol added - ';'). E.g.: 'unit1.dcu'#13'unit1.~pa'
|<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 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 );
{* 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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
Note: Pass FILE_ATTRIBUTE_... constants or-combination as Attr
parameter. }
procedure Sort( Rules : array of TSortDirRules );
{* Sorts directory entries. If empty rules array passed, default rules
array DefSortDirRules is used. }
function FileList( const Separator {e.g.: ';', or #13}: KOLString;
Dirs, FullPaths: Boolean ): KOLString;
{* Returns a string containing all names separated with Separator.
If Dirs=FALSE, only files are returned. }
property OnItem: TOnDirItem read fOnItem write fOnItem;
{* This event is called on reading each item while scanning directory.
To use it, first create PDirList object with empty path to scan, then
assign OnItem event and call ScanDirectory with correct path. }
end;
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;
FPopupFlags: DWORD;
//fAutoPopup: Boolean;
FSavedState: DWORD;
FData: Pointer;
FOwnerDraw: Boolean;
{$ENDIF GDI}
FParentMenu: PMenu;
FMenuItems: PList;
FRadioGroup: Integer;
FIsCheckItem: Boolean;
FIsSeparator: Boolean;
FVisible: Boolean;
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 );
FClearBitmaps: Boolean;
FNotPopup: Boolean;
FAccelerator: TMenuAccelerator;
FHelpContext: Integer;
FOnMeasureItem: TOnMeasureItem;
FOnDrawItem: TOnDrawItem;
{$IFDEF USE_MENU_CURCTL}
fCurCtl: PControl;
{$ENDIF USE_MENU_CURCTL}
function GetItems( Id: HMenu ): PMenu;
function GetCount: Integer;
function GetTopParent: PMenu;
function GetState( const Index: Integer ): Boolean;
procedure SetState( const Index: Integer; Value: Boolean );
procedure SetVisible( Value: Boolean );
procedure SetData( Value: Pointer );
procedure SetMenuItemCaption( const Value: KOLString );
function FillMenuItems(AHandle: HMenu; StartIdx: Integer;
const Template: array of PKOLChar): Integer;
procedure SetMenuBreak( Value: TMenuBreak );
function GetControl: PControl;
function GetInfo( var MII: TMenuItemInfo ): Boolean;
function SetInfo( var MII: TMenuItemInfo ): Boolean;
function SetTypeInfo( var MII: TMenuItemInfo ): Boolean;
procedure SetBitmap( Value: HBitmap );
procedure SetBmpChecked( Value: HBitmap );
procedure SetBmpItem( Value: HBitmap );
procedure ClearBitmaps;
procedure SetAccelerator( const Value: TMenuAccelerator );
{$IFDEF GDI}
procedure SetHelpContext( Value: Integer );
{$ENDIF GDI}
procedure SetSubmenu( Value: HMenu );
procedure SetOnMeasureItem( const Value: TOnMeasureItem );
procedure SetOnDrawItem( const Value: TOnDrawItem );
procedure SetOwnerDraw( Value: Boolean );
protected
function GetItemChecked( Item : Integer ) : Boolean;
procedure SetItemChecked( Item : Integer; Value : Boolean );
function GetItemBitmap(Idx: Integer): HBitmap;
procedure SetItemBitmap(Idx: Integer; const Value: HBitmap);
function GetItemText(Idx: Integer): KOLString;
procedure SetItemText(Idx: Integer; const Value: KOLString);
function GetItemEnabled(Idx: Integer): Boolean;
procedure SetItemEnabled(Idx: Integer; const Value: Boolean);
function GetItemVisible(Idx: Integer): Boolean;
procedure SetItemVisible(Idx: Integer; const Value: Boolean);
function GetItemAccelerator(Idx: Integer): TMenuAccelerator;
procedure SetItemAccelerator(Idx: Integer; const Value: TMenuAccelerator);
function GetItemSubMenu( Idx: Integer ): HMenu;
{$ENDIF GDI}
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 SetVisible;
{* Visibility of menu item. }
property Data: Pointer read FData write SetData;
{* Data pointer, associated with the menu item. }
property Bitmap: HBitmap read FBitmap write SetBitmap;
{* Bitmap used for unchecked state of the menu item. }
property BitmapChecked: HBitmap read FBmpChecked write SetBmpChecked;
{* Bitmap used for checked state of the menu item. }
property BitmapItem: HBitmap read FBmpItem write SetBmpItem;
{* Bitmap used for item itself. In addition, following special values
are possible:
HBMMENU_CALLBACK, HBMMENU_MBAR_CLOSE, HBMMENU_MBAR_CLOSE_D,
HBMMENU_MBAR_MINIMIZE, HBMMENU_MBAR_MINIMIZE_D, HBMMENU_MBAR_RESTORE,
HBMMENU_POPUP_CLOSE, HBMMENU_POPUP_MAXIMIZE, HBMMENU_POPUP_MINIMIZE,
HBMMENU_POPUP_RESTORE, HBMMENU_SYSTEM. }
property Accelerator: TMenuAccelerator read FAccelerator write SetAccelerator;
{* Accelerator for menu item. }
{$IFDEF GDI}
property HelpContext: Integer read FHelpContext write SetHelpContext;
{* Help context for entire menu (help context can not be assigned to
individual menu items). }
{$ENDIF GDI}
procedure AssignEvents( StartIdx: Integer; const Events: array of TOnMenuItem );
{* It is possible to assign its own event handler to every menu item
using this call. This procedure also is called automatically in
a constructor NewMenuEx. }
function Popup( X, Y : Integer ): Integer; {!ecm}
{* Only for popup menu - to popup it at the given position on screen.
Return: If you specify TPM_RETURNCMD in the uFlags parameter, the return
value is the menu-item identifier of the item that the user selected.
If the user cancels the menu without making a selection, or if an error
occurs, then the return value is zero.
If you do not specify TPM_RETURNCMD in the uFlags parameter, the return
value is nonzero if the function succeeds and zero if it fails. }
function PopupEx( X, Y: Integer ): Integer; {!ecm}
{* This version of popup command is very useful, when popup menu is activated
when its parent window is not visible (e.g., for a kind of applications,
which always are invisible, and can be activated only using tray icon).
PopupEx method provides correct tracking of menu disappearing when mouse
is clicked anywhere else on screen, fixing strange menu behavior in some
Windows versions (NT).
|<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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
Following formatting characters can be used in menu template strings:
|&L=<br><b>%1</b>
<L &amp; (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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
}
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>&nbsp;&nbsp;&nbsp;
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>&nbsp;&nbsp;&nbsp;
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. }
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 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#12 + //0, BS_VCENTER>>8
#4#8 + //BS_TOP>>8, BS_BOTTOM>>8
#203 + //3
#201;
{$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;
bVertAlignCenter: BS_VCENTER shr 8;
bVertAlignTop: BS_TOP shr 8;
bVertAlignBottom: BS_BOTTOM shr 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#2 + // SS_LEFTNOWORDWRAP, SS_CENTERIMAGE>>8
#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;
bVertAlignCenter: SS_CENTERIMAGE shr 8;
bVertAlignTop: 0;
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 +
#$BA#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;
bVertAlignCenter: 0;
bVertAlignTop: 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;
bVertAlignCenter: 0;
bVertAlignTop: 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;
bVertAlignCenter: 0;
bVertAlignTop: 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 +
#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: 0;
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;
bVertAlignCenter: 0;
bVertAlignTop: 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
#229 +
#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: 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: 0;
aTextAlignRight: 0;
aTextAlignCenter: 0;
bTextAlignMask: 0;
bVertAlignCenter: 0;
bVertAlignTop: 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
#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;
bVertAlignCenter: 0;
bVertAlignTop: 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;
bVertAlignCenter: 0;
bVertAlignTop: 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). }
{$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}
const comctl32_const: PKOLChar = 'comctl32';
InitCommonControlsEx_const: PKOLChar = 'InitCommonControlsEx';
procedure DoInitCommonControls( dwICC: DWORD );
asm
PUSH EAX // dwICC
CALL InitCommonControls
MOV EAX, [ComCtl32_Module]
TEST EAX, EAX
JNZ @@1
PUSH [comctl32_const]
CALL LoadLibrary
MOV [ComCtl32_Module], EAX
@@1:PUSH [InitCommonControlsEx_const]
PUSH EAX
CALL GetProcAddress
XCHG ECX, EAX
{$IFDEF SAFE_CODE}
POP EDX
JECXZ @@fin
PUSH EDX
{$ENDIF}
PUSH 8 // dwSize
PUSH ESP // @ ICC
CALL ECX // Proc( @ ICC )
POP ECX
POP ECX
@@fin:
end;
{$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]
@@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;
function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward;
procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD ); forward;
function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward;
procedure ApplyImageLists2Control( Sender: PControl ); forward;
procedure ApplyImageLists2ListView( Sender: PControl ); forward;
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;
////////////////////////////////////////////////////////////////////////////////
var MapFile: PStrList;
LineNumbersFrom: Integer;
MaxCrackStackLen: Integer;
HandleSuspicious: Boolean;
BelowBasePtr: PDWORD;
CrackedStack: AnsiString;
function DoCrackSingleFrame( RetAddr: DWORD; BasePtr: DWORD ): Boolean;
var i, j, R: Integer;
A, Prev_A, N, Prev_N: DWORD;
s, CurUnit: AnsiString;
Add_string: AnsiString;
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] in ['0'..'9','A'..'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] in ['0'..'9','A'..'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 (j > Length( s )) then Exit;
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] in [ '0'..'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] in [ '0'..'9', 'A'..'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] in [ '0'..'9', 'A'..'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 ): AnsiString;
begin
TRY
MaxCrackStackLen := Max_length;
HandleSuspicious := HandleSuspiciousAddresses;
CrackedStack := '';
DoCrackStack;
EXCEPT
END;
Result := CrackedStack;
end;
procedure PrepareMapFile;
var i, j: Integer;
s: AnsiString;
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 := NewStrList;
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 := NewStrList;
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 ASM_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 ASM_VERSION}
procedure MsgOK( const S: KOLString );
begin
MsgBox( S, MB_OK );
end;
{$IFDEF ASM_UNICODE}
function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD;
asm
push edx // Flags
mov ecx, [Applet]
{$IFDEF SNAPMOUSE2DFLTBTN}
{$IFDEF SAFE_CODE}
jecxz @@0
{$ENDIF}
pushad
xchg eax, ecx
mov edx, offset[WndProcSnapMouse2DfltBtn]
call TControl.AttachProc
popad
@@0:
{$ENDIF}
mov edx, 0
{$IFDEF SAFE_CODE}
jecxz @@1
{$ENDIF}
mov edx, [ecx].TControl.fHandle
mov ecx, [ecx].TControl.fCaption
@@1: push ecx // Title
push eax // S
push edx // Wnd
call MessageBox
{$IFDEF SNAPMOUSE2DFLTBTN}
mov ecx, [Applet]
{$IFDEF SAFE_CODE}
jecxz @@2
{$ENDIF}
pushad
xchg eax, ecx
mov edx, offset[WndProcSnapMouse2DfltBtn]
call TControl.DetachProc
popad
@@2:
{$ENDIF}
end;
{$ELSE PASCAL}
function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD;
var Title: PKOLChar;
Wnd: HWnd;
begin
{$IFDEF SNAPMOUSE2DFLTBTN}
{$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 ASM_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);
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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function RectsEqual( const R1, R2: TRect ): Boolean;
begin
Result := CompareMem( @R1, @R2, Sizeof( TRect ) );
end;
{$ENDIF ASM_VERSION}
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 ASM_VERSION} //Pascal
function PointInRect( const P: TPoint; const R: TRect ): Boolean;
begin
Result := (P.x >= R.Left) and (P.x < R.Right)
and (P.y >= R.Top) and (P.y < R.Bottom);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} // Pascal
function OffsetPoint( const T: TPoint; dX, dY: Integer ): TPoint;
begin
Result := MakePoint( T.X + dX, T.Y + dY );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} // Pascal
function OffsetSmallPoint( const T: TSmallPoint; dX, dY: SmallInt ): TSmallPoint;
begin
Result.x := T.x + dX;
Result.y := T.y + dY;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} // Pascal
function Point2SmallPoint( const T: TPoint ): TSmallPoint;
begin
Result.x := T.X;
Result.y := T.Y;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function SmallPoint2Point( const T: TSmallPoint ): TPoint;
begin
Result := MakePoint( T.x, T.y );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function MakePoint( X, Y: Integer ): TPoint;
begin
Result.x := X;
Result.y := Y;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} // Pascal
function MakeSmallPoint( X, Y: Integer ): TSmallPoint;
begin
Result.x := X;
Result.y := Y;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer;
var I : Integer;
Mask : DWORD;
begin
Result := 0;
Mask := FlgSet^;
for I := 0 to High( FlgArray ) do
begin
if (FlgArray[ I ] < 0) and not LongBool( Mask and 1 ) then
Result := Result or not FlgArray[ I ]
else
if (FlgArray[ I ] >= 0) and LongBool( Mask and 1 ) then
Result := Result or FlgArray[ I ];
Mask := Mask shr 1;
end;
end;
{$ENDIF ASM_VERSION}
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_fOnChange = 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;
idummy4_TRUE, //idx_FOnTVEndEdit = 50;
idummy4_TRUE, //idx_FOnTVExpanded = 51;
idummy4_0, //idx_FOnTVExpanding = 52;
idummy4_TRUE, //idx_FOnTVSelChanging = 53;
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;
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 ASM_VERSION} //Pascal
constructor TObj.Create;
begin
Init;
end;
{$ENDIF ASM_VERSION}
{$IFDEF OLD_REFCOUNT}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TObj.DoDestroy;
begin
{$IFDEF OLD_REFCOUNT}
if fRefCount > 0 then
begin
if not LongBool( fRefCount and 1) then
Dec( fRefCount, 2 );
RefDec;
end
else
Self.Destroy;
if fRefCount <> 0 then
begin
if not LongBool( fRefCount and 1) then
Dec( fRefCount );
end
else
Self.Destroy;
{$ELSE}
if fRefCount > 0 then
RefDec
else
Self.Destroy;
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
{$ENDIF OLD_REFCOUNT}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TObj.RefDec: Integer;
begin
Result := 0; // stop Delphi alerting the Warning
if @ Self = nil then Exit;
Dec( fRefCount, 2 );
{$IFDEF OLD_REFCOUNT}
if (fRefCount < 0) and LongBool(fRefCount and 1) then
Destroy;
{$ELSE}
if fRefCount < 0 then
Destroy;
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
procedure TObj.RefInc;
begin
Inc( fRefCount, 2 );
end;
function TObj.VmtAddr: Pointer;
asm
MOV EAX, [EAX - 4]
end;
function TObj.InstanceSize: Integer;
asm
MOV EAX, [EAX]
MOV EAX,[EAX-4]
end;
{$IFDEF OLD_FREE}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION}
procedure TObj.Free;
begin
//if @ Self <> nil then
RefDec;
end;
{$ENDIF ASM_VERSION}
{$ENDIF OLD_FREE}
{$UNDEF ASM_LOCAL}
{$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF}
{$IFDEF CRASH_DEBUG} {$UNDEF ASM_LOCAL} {$ENDIF}
{$IFDEF ASM_DEBUG} {$DEFINE ASM_LOCAL} {$ENDIF}
{$IFDEF ASM_LOCAL}
{$ELSE ASM_VERSION} //Pascal
destructor TObj.Destroy;
begin
Final;
{$IFDEF DEBUG_ENDSESSION}
if EndSession_Initiated then
LogFileOutput( GetStartDir + 'es_debug.txt',
'FINALLED: ' + Int2Hex( DWORD( @ Self ), 8 )
{$IFDEF USE_NAMES}
+ ' (name:' + FName + ')'
{$ENDIF}
);
{$ENDIF}
{$IFDEF USE_NAMES}
fName := '';
if fNamedObjList <> nil then
Free_And_Nil(fNamedObjList);
{$ENDIF}
//Dispose( @Self );
{$IFDEF CRASH_DEBUG}
FillChar( Pointer( Integer(@Self) + 4 )^, Sizeof( Self ) - 4, #$DD );
{$ENDIF}
FreeMem( @ Self );
end;
{$ENDIF ASM_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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TObj.Add2AutoFree(Obj: PObj);
begin
if fAutoFree = nil then
fAutoFree := NewList;
fAutoFree.Insert( 0, Obj );
fAutoFree.Insert( 0, Pointer( @TObj.RefDec ) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION} {$ELSE ASM_VERSION} //Pascal
procedure TObj.Add2AutoFreeEx( Proc: TObjectMethod );
{$IFDEF F_P}
var Ptr1, Ptr2: Pointer;
{$ENDIF F_P}
begin
if fAutoFree = nil then
fAutoFree := NewList;
{$IFDEF F_P}
asm
MOV EAX, [Proc]
MOV [Ptr1], EAX
MOV EAX, [Proc+4]
MOV [Ptr2], EAX
end [ 'EAX' ];
fAutoFree.Insert( 0, Ptr2 );
fAutoFree.Insert( 0, Ptr1 );
{$ELSE DELPHI}
fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Data ) );
fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Code ) );
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION}
procedure TObj.RemoveFromAutoFree(Obj: PObj);
var i: Integer;
begin
if fAutoFree <> nil then
begin
i := fAutoFree.IndexOf( Obj );
if i >= 0 then
begin
fAutoFree.DeleteRange( i and not 1, 2 );
if fAutoFree.Count = 0 then
Free_And_Nil( fAutoFree );
end;
end;
end;
{$ENDIF ASM_VERSION}
procedure TObj.RemoveFromAutoFreeEx(Proc: TObjectMethod);
var i: Integer;
begin
if fAutoFree <> nil then
begin
for i := 0 to fAutoFree.Count-2 do
if (fAutoFree.Items[ i ] = TMethod( Proc ).Data) and
(fAutoFree.Items[ i+1 ] = TMethod( Proc ).Code) then
begin
fAutoFree.Delete( i );
fAutoFree.Delete( i );
break;
end;
end;
end;
{$IFDEF USE_NAMES}
procedure TObj.SetName( NewOwnerObj: PObj; 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}
//Result.fAddBy := 4;
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 ASM_VERSION} //Pascal
destructor TList.Destroy;
begin
Clear;
inherited;
end;
{$ENDIF ASM_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 ASM_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 ASM_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 ASM_VERSION} //Pascal
//var NewItems: PPointerList;
procedure TList.SetCapacity( Value: Integer );
begin
{$IFDEF TLIST_FAST}
if fUseBlocks and (fBlockList <> nil) then
begin
if Value > 256 then // Capacitity
Value := 256; // - 256 , ,
// .. 256
// , .
fCapacity := Value;
end
else
{$ENDIF}
begin
if Value < Count then
Value := Count;
if Value = fCapacity then Exit;
ReallocMem( fItems, Value * Sizeof( Pointer ) );
fCapacity := Value;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TList.Clear;
{$IFDEF TLIST_FAST}
var i: Integer;
{$ENDIF}
begin
if fItems <> nil then
FreeMem( fItems );
fItems := nil;
fCount := 0;
fCapacity := 0;
{$IFDEF TLIST_FAST}
if fBlockList <> nil then
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 ASM_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 ASM_VERSION} //Pascal
procedure TList.Add( Value: Pointer );
{$IFDEF TLIST_FAST}
var LastBlockCount: Integer;
LastBlockStart: Pointer;
{$ENDIF}
begin
{$IFDEF TLIST_FAST}
if fUseBlocks and ((fCount >= 256) or ( 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 ASM_VERSION}
{$IFDEF _D4orHigher}
procedure TList.AddItems(const AItems: array of Pointer);
var i: Integer;
begin
Capacity := Count + Length( AItems );
for i := 0 to High( AItems ) do
Add( AItems[ i ] );
end;
{$ENDIF}
procedure TList.Delete( 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 ASM_VERSION} //Pascal
procedure TList.DeleteRange(Idx, Len: Integer);
{$IFDEF TLIST_FAST}
var i, DelFromBlock: Integer;
CountBefore, CountCurrent: Integer;
BlockStart: Pointer;
{$ENDIF}
begin
if Len <= 0 then Exit;
if Idx >= Count then Exit;
Assert( (Idx >= 0), 'TList.DeleteRange: index out of bounds' );
if DWORD( Idx + Len ) > DWORD( Count ) then
Len := Count - Idx;
{$IFDEF TLIST_FAST}
if fUseBlocks and ( 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
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 ASM_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 not ASM_VERSION}
procedure TList.Put( Idx: Integer; Value: Pointer );
{$IFDEF TLIST_FAST}
var i: Integer;
BlockStart: Pointer;
CountBefore, CountCurrent: Integer;
{$ENDIF}
begin
if Idx < 0 then Exit;
if Idx >= Count then Exit;
{$IFDEF TLIST_FAST}
if fUseBlocks and ( 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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE not ASM_VERSION}
function TList.Get( Idx: Integer ): Pointer;
{$IFDEF TLIST_FAST}
var i: Integer;
BlockStart: Pointer;
CountBefore, CountCurrent: Integer;
{$ENDIF}
begin
Result := nil;
if Idx < 0 then Exit;
if Idx >= fCount then Exit;
{$IFDEF TLIST_FAST}
if fUseBlocks and ( 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} TRUE do
begin
BlockStart := fBlockList.fItems[ i * 2 ];
CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then
begin
fLastKnownBlockIdx := i;
fLastKnownCountBefore := CountBefore;
Result := Pointer( PDWORD( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^ );
Exit;
end;
inc( CountBefore, CountCurrent );
inc( i );
end;
end
else
{$ENDIF}
Result := fItems[ Idx ];
end;
{$ENDIF ASM_VERSION}
{$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 ASM_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
asm
nop
end;
END;
{$ENDIF}
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
procedure TList.Insert(Idx: Integer; Value: Pointer);
{$IFDEF TLIST_FAST}
var i: Integer;
CountBefore, CountCurrent: Integer;
BlockStart, NewBlock: Pointer;
{$ENDIF}
begin
Assert( (Idx >= 0) and (Idx <= FCount+1), 'List index out of bounds' );
{$IFDEF TLIST_FAST}
if fUseBlocks and (( 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
GetMem( NewBlock, 256 * Sizeof( Pointer ) );
fBlockList.Add( NewBlock );
fBlockList.Add( nil );
end;
CountBefore := 0;
i := 0;
if (fLastKnownBlockIdx > 0) and
(Idx >= fLastKnownCountBefore) then
begin
i := fLastKnownBlockIdx;
CountBefore := fLastKnownCountBefore;
end;
while TRUE {i < fBlockList.fCount div 2} do
begin
CountCurrent := Integer( fBlockList.Items[ i * 2 + 1 ] );
if (Idx >= CountBefore) and
((Idx < CountBefore + CountCurrent) or
(Idx = CountBefore + CountCurrent) and
(CountCurrent < 256)) then // insert in block i
begin
BlockStart := fBlockList.fItems[ i * 2 ];
if BlockStart = nil then
begin
GetMem( BlockStart, 256 * Sizeof( Pointer ) );
fBlockList.fItems[ i * 2 ] := BlockStart;
end;
Idx := Idx - CountBefore;
if CountCurrent < 256 then
begin
if Idx < CountCurrent then
Move( Pointer( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^,
Pointer( Integer( BlockStart ) + (Idx+1) * Sizeof( Pointer ) )^,
(CountCurrent - Idx) * Sizeof( Pointer ) );
PDWORD( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^ :=
DWORD( Value );
fBlockList.fItems[ i * 2 + 1 ] := Pointer( CountCurrent + 1 );
end
else // new block is created since current block is full 256 items
begin
GetMem( NewBlock, 256 * Sizeof( Pointer ) );
fBlockList.Insert( (i+1)*2, Pointer( 256-Idx ) );
fBlockList.Insert( (i+1)*2, NewBlock );
move( Pointer( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^,
NewBlock^, (256 - Idx) * Sizeof( Pointer ) );
PDWORD( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^ :=
DWORD( Value );
fBlockList.fItems[ i * 2 + 1 ] := Pointer( Idx + 1 );
end;
fLastKnownBlockIdx := i;
fLastKnownCountBefore := CountBefore;
inc( fCount );
Exit;
end;
inc( CountBefore, CountCurrent );
inc( i );
if i >= fBlockList.fCount div 2 then
begin
fBlockList.Add( nil );
fBlockList.Add( nil );
end;
end;
end
else
{$ENDIF}
begin
Add( nil );
if fCount > Idx then
Move( FItems[ Idx ], FItems[ Idx + 1 ], (fCount - Idx - 1) * Sizeof( Pointer ) );
FItems[ Idx ] := Value;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION} {$DEFINE MoveItem_ASM} {$ENDIF}
{$IFDEF TLIST_FAST} {$UNDEF MoveItem_ASM} {$ENDIF}
{$IFDEF MoveItem_ASM}
{$ELSE ASM_VERSION} //Pascal
procedure TList.MoveItem(OldIdx, NewIdx: Integer);
var Item: Pointer;
begin
if OldIdx = NewIdx then Exit;
if NewIdx >= Count then Exit;
Item := Items[ OldIdx ];
Delete( OldIdx );
Insert( NewIdx, Item );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TList.Last: Pointer;
begin
if Count = 0 then
Result := nil
else
Result := Items[ Count-1 ];
end;
{$ENDIF ASM_VERSION}
{$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 ASM_VERSION} //Pascal
procedure TList.Swap(Idx1, Idx2: Integer);
var Tmp: DWORD;
AItem1, AItem2: PDWORD;
begin
{$IFDEF TLIST_FAST}
AItem1 := ItemAddress( Idx1 );
AItem2 := ItemAddress( Idx2 );
{$ELSE}
AItem1 := Pointer( Integer( fItems ) + Idx1 * Sizeof( Pointer ) );
AItem2 := Pointer( Integer( fItems ) + Idx2 * Sizeof( Pointer ) );
{$ENDIF}
Tmp := AItem1^;
AItem1^ := AItem2^;
AItem2^ := Tmp;
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
: Integer; stdcall;
var M: TMsg;
self_: PControl;
begin
{if (Msg >= $BD33) and (Msg <= $BD33) then
begin
Result := WndFunc_asm( W, Msg, wParam, lParam );
Exit;
end;}
{$IFDEF INPACKAGE}
Log( '->WndFunc ' + Int2Hex( Msg, 4 ) + ' (' + Int2Str( Msg ) + ')' );
TRY
{$ENDIF INPACKAGE}
M.hwnd := W;
M.message := Msg;
M.wParam := wParam;
M.lParam := lParam;
{$IFDEF DEBUG_ENDSESSION}
if EndSession_Initiated then
begin
LogFileOutput( GetStartDir + 'es_debug.txt',
'HWND:' + Int2Str( W ) + ' MSG:$' + Int2Hex( Msg, 4 ) +
' WParam: ' + Int2Str( wParam ) + '($' + Int2Hex( wParam, 8 ) + ')' +
' LParam: ' + Int2Str( lParam ) + '($' + Int2Hex( lParam, 8 ) + ')' );
end;
{$ENDIF}
self_ := nil;
if W <> 0 then
begin
if CreatingWindow <> nil then
begin
{$IFDEF INPACKAGE}
Log( '//// CreatingWindow <> nil' );
{$ENDIF INPACKAGE}
{$IFDEF DEBUG_CREATEWINDOW}
LogFileOutput( GetStartDir + 'Session.log',
'WndFunc: Creating window = ' + Int2Hex( Integer( CreatingWindow ), 4 ) +
' hwnd=' + Int2Str( M.hwnd ) +
' message=' + Int2Hex( M.message, 4 ) +
' wParam=' + Int2Str( M.wParam ) + '=$' + Int2Hex( M.wParam, 4 ) +
' lParam=' + Int2Str( M.lParam ) + '=$' + Int2Hex( M.lParam, 4 )
);
{$ENDIF DEBUG_CREATEWINDOW}
self_ := CreatingWindow;
CreatingWindow.fHandle := W;
{$IFDEF USE_PROP}
{$IFDEF INPACKAGE}
Log( '//// SetProp' );
{$ENDIF INPACKAGE}
SetProp( W, ID_SELF, THandle( CreatingWindow ) );
{$ELSE}
SetWindowLong( W, GWL_USERDATA, Integer( CreatingWindow ) );
{$ENDIF}
CreatingWindow := nil;
end
else
{$IFDEF USE_PROP}
self_ := Pointer( GetProp( W, ID_SELF ) );
{$ELSE}
self_ := Pointer( GetWindowLong( W, GWL_USERDATA ) );
{$ENDIF}
end;
if self_ <> nil then
begin
{$IFDEF INPACKAGE}
Log( '//// self_ <> nil, calling self_.WndProc' );
{$ENDIF INPACKAGE}
inc( self_.fNestedMsgHandling );
{$IFDEF DEBUG_KEYDOWN}
if M.message = WM_KEYDOWN then
asm
nop
end;
{$ENDIF}
Result := self_.WndProc( M );
dec( self_.fNestedMsgHandling );
if (self_.fRefCount = 0) and (self_.fNestedMsgHandling <= 0)
and {$IFDEF USE_FLAGS} (G2_BeginDestroying in self_.fFlagsG2)
{$ELSE} self_.fBeginDestroying {$ENDIF}
and (self_ <> Applet) then
self_.Free;
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}
end;
{$ENDIF ASM_VERSION}
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_noVERSION}
procedure TerminateExecution( var AppletWnd: PControl );
asm
PUSH EBX
PUSH ESI
MOV BX, $0100
XCHG BX, word ptr [AppletRunning]
XOR ECX, ECX
XCHG ECX, [Applet]
JECXZ @@exit
PUSH EAX
XCHG EAX, ECX
MOV ESI, EAX
CALL TObj.RefInc
TEST BH, BH
JE @@closed
MOV EAX, ESI
CALL TControl.ProcessMessages
PUSH 0
PUSH 0
PUSH WM_CLOSE
PUSH ESI
CALL TControl.Perform
@@closed:
POP EAX
XOR ECX, ECX
MOV dword ptr [EAX], ECX
MOV EAX, ESI
CALL TObj.Free
XCHG EAX, ESI
CALL TObj.RefDec
@@exit:
POP ESI
POP EBX
end;
{$ELSE ASM_VERSION}
procedure TerminateExecution( var AppletWnd: PControl );
var App: PControl;
Appalreadyterminated: Boolean;
begin
Appalreadyterminated := AppletTerminated;
AppletTerminated := TRUE;
AppletRunning := FALSE;
App := Applet;
Applet := nil;
if (App <> nil) {and (App.RefCount >= 0)} then
begin
App.RefInc;
if not Appalreadyterminated then
begin
App.ProcessMessages;
App.Perform( WM_CLOSE, 0, 0 );
end;
AppletWnd := nil;
App.Free;
App.RefDec;
end;
end;
{$ENDIF ASM_VERSION}
//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
asm
nop
end;
END;
{$ELSE}
Result := Ctl.CreateWindow;
{$ENDIF}
end;
//22{$ENDIF}
{$ENDIF GDI}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure Run( var AppletWnd: PControl );
{$IFDEF PSEUDO_THREADS}
var n: Integer;
i: Integer;
T: PThread;
u: DWORD;
M: TMsg;
{$ENDIF}
begin
AppletRunning := True;
Applet := AppletWnd;
AppletWnd.CreateWindow; //virtual!!!
while not AppletTerminated do
begin
{$IFDEF 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}
AppletWnd.ProcessMessages;
{$IFDEF USE_OnIdle}
ProcessIdle( AppletWnd );
{$ENDIF}
end;
if AppletWnd <> nil then
TerminateExecution( AppletWnd );
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE Run( var AppletWnd: PControl );
BEGIN
AppletRunning := True;
Applet := AppletWnd;
AppletWnd.VisualizyWindow; // for GTK, show all windows having Visible = TRUE, recursively
gtk_main( );
IF AppletWnd <> nil THEN
//TerminateExecution( AppletWnd );
Free_And_Nil( AppletWnd );
END;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
{$IFDEF GDI}
procedure AppletMinimize;
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 ASM_VERSION}
function NormalGetCtlBrushHandle( Sender: PControl ): HBrush;
begin
{$IFDEF GDI}
if (Sender.fParent <> nil) then
Sender.Brush.fParentGDITool := Sender.fParent.Brush;
Result := Sender.Brush.Handle;
{$ELSE} Result := 0;
{$ENDIF GDI}
end;
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 ASM_VERSION} //Pascal
function NewBrush: PGraphicTool;
begin
{$IFDEF GDI}
Global_GetCtlBrushHandle := NormalGetCtlBrushHandle;
{$ENDIF GDI}
Result := _NewGraphicTool;
with Result^ do
begin
fNewProc := @ NewBrush;
fType := gttBrush;
{$IFDEF GDI}
fMakeHandleProc := @ MakeBrushHandle;
{$ENDIF GDI}
Result.fData.Color := clBtnFace;
Result.fData.Brush.Style := bsSolid;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function NewPen: PGraphicTool;
begin
Result := _NewGraphicTool;
with Result^ do
begin
fNewProc := @ NewPen;
fType := gttPen;
{$IFDEF GDI}
fMakeHandleProc := @ MakePenHandle;
{$ENDIF GDI}
fData.Pen.Mode := pmCopy;
end;
end;
{$ENDIF ASM_VERSION}
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 ASM_VERSION} //Pascal
function NewFont: PGraphicTool;
begin
ApplyFont2Wnd_Proc := @ DoApplyFont2Wnd;
Result := _NewGraphicTool;
with Result^ do
begin
fNewProc := @ NewFont;
fType := gttFont;
{$IFDEF GDI}
fMakeHandleProc := @ MakeFontHandle;
fData.Color := DefFontColor;
Move( DefFont, fData.Font, Sizeof( TGDIFont ) );
{$ENDIF GDI}
{$IFDEF GTK}
fData.Font.Weight := 400;
{$ENDIF GTK}
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION}
function Color2RGB( Color: TColor ): TColor;
begin
if Color < 0 then
Result := GetSysColor(Color and $7F)
else
Result := Color;
end;
{$ENDIF ASM_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
XCHG EAX, [ESP]
CALL Color2Rgb
POP EDX
AND EAX, 0FEFEFEh
AND EDX, 0FEFEFEh
SHR EAX, 1
SHR EDX, 1
ADD EAX, EDX
end;
{$ENDIF F_P/DELPHI}
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function Color2RGBQuad( Color: TColor ): TRGBQuad;
var C: Integer;
begin
C := Color2RGB( Color );
C := ((C shr 16) and $FF)
or ((C shl 16) and $FF0000)
or (C and $FF00);
Result := TRGBQuad( C );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION}
function Color2Color16( Color: TColor ): WORD;
begin
Color := Color2RGB( Color );
Result := (Color shr 19) and $1F or
(Color shr 5) and $7E0 or
(Color shl 8) and $F800;
end;
{$ENDIF ASM_VERSION}
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 ASM_VERSION}
function TGraphicTool.Assign(Value: PGraphicTool): PGraphicTool;
var _Self: PGraphicTool;
begin
Result := nil;
if Value = nil then
begin
{$IFDEF OLD_REFCOUNT}
if @Self <> nil then
DoDestroy;
{$ELSE}
Free;
{$ENDIF}
Exit;
end;
_Self := @Self;
if _Self = nil then
_Self := Value.fNewProc();
Result := _Self;
if _Self = Value then Exit; // to avoid infinite loop when assigning to itself
{$IFDEF GDI}
if _Self.fHandle <> 0 then
if Value.fHandle = _Self.fHandle then Exit;
{$ENDIF GDI}
_Self.Changed; // to destroy handle if allocated and release it from the canvas (if any uses it)
Assert( Value.fType = _Self.fType, 'Attempt to assign to different GDI tool type' );
Move( Value.fData, _Self.fData, Sizeof( fData ) );
_Self.Changed; // to inform owner control, that its tool (font, brush) changed
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
procedure TGraphicTool.AssignHandle(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 ASM_VERSION} //Pascal
procedure TGraphicTool.Changed;
{$IFDEF GDI} var H: THandle; {$ENDIF GDI}
begin
{$IFDEF GDI}
H := 0;
if fHandle <> 0 then
begin
H := fHandle;
fHandle := 0;
end;
////////////////////////////////
if Assigned( fOnChange ) then
fOnChange( @Self );
////////////////////////////////
if H <> 0 then
begin
DeleteObject( H );
{$IFDEF DEBUG_GDIOBJECTS}
case fType of
gttBrush: Dec( BrushCount );
gttFont: Dec( FontCount );
gttPen: Dec( PenCount );
end;
{$ENDIF}
end;
{$ENDIF GDI}
{$IFDEF GTK}
IF Assigned( fPangoFontDesc ) THEN
BEGIN
pango_font_description_free( fPangoFontDesc );
fPangoFontDesc := nil;
END;
/////////////////////////////////
IF Assigned( fOnChange ) THEN
/////////////////////////////////
fOnChange( @Self );
{$ENDIF GTK}
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
destructor TGraphicTool.Destroy;
begin
{$IFDEF GDI}
case fType of
gttBrush: if fData.Brush.Bitmap <> 0 then
DeleteObject( fData.Brush.Bitmap );
gttPen: if fData.Pen.BrushBitmap <> 0 then
DeleteObject( fData.Pen.BrushBitmap )
end;
if fHandle <> 0 then
begin
DeleteObject( fHandle );
{$IFDEF DEBUG_GDIOBJECTS}
case fType of
gttPen: Dec( PenCount );
gttBrush: Dec( BrushCount );
gttFont: Dec( FontCount );
end;
{$ENDIF}
//fHandle := 0; Why to do this? It is now destroying!
end;
{$ENDIF GDI}
inherited;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
function TGraphicTool.HandleAllocated: 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 ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_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 ASM_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;
procedure TGraphicTool.SetFontName(const Value: KOLString);
begin
if 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;
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TextAreaEx( Sender: PCanvas; var Sz : TSize; var Pt : TPoint );
var Orient : Integer;
Pts : array[ 1..4 ] of TPoint;
MinX, MinY, I : Integer;
A : Double;
begin
if not Sender.Font.IsFontTrueType then Exit;
Orient := Sender.Font.FontOrientation;
Pt.x := 0; Pt.y := 0;
if Orient = 0 then
Exit;
A := Orient / 1800.0 * PI;
Pts[ 1 ] := Pt;
Pts[ 2 ].x := Round( Sz.cx * cos( A ) );
Pts[ 2 ].y := - Round( Sz.cx * sin( A ) );
Pts[ 4 ].x := - Round( Sz.cy * cos( A + PI / 2 ) );
Pts[ 4 ].y := Round( Sz.cy * sin( A + PI / 2 ) );
Pts[ 3 ].x := Pts[ 2 ].x + Pts[ 4 ].x;
Pts[ 3 ].y := Pts[ 2 ].y + Pts[ 4 ].y;
MinX := 0; MinY := 0;
for I := 2 to 4 do
begin
if Pts[ I ].x < MinX then
MinX := Pts[ I ].x;
if Pts[ I ].y < MinY then
MinY := Pts[ I ].y;
end;
Sz.cx := 0;
Sz.cy := 0;
for I := 1 to 4 do
begin
Pts[ I ].x := Pts[ I ].x - MinX;
Pts[ I ].y := Pts[ I ].y - MinY;
if Pts[ I ].x > Sz.cx then
Sz.cx := Pts[ I ].x;
if Pts[ I ].y > Sz.cy then
Sz.cy := Pts[ I ].y;
end;
Pt := Pts[ 1 ];
end;
{$ENDIF ASM_VERSION}
function TGraphicTool.GetFontOrientation: Integer;
begin
Result := fData.Font.Orientation; // for BCB only
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_VERSION} //Pascal
function TGraphicTool.GetFontStyle: TFontStyle;
type PFontStyle = ^TFontStyle;
begin
Result := [ ];
if fData.Font.Weight >= 700 then Result := [ fsBold ];
if fData.Font.Italic then include( Result, fsItalic );
if fData.Font.Underline then include( Result, fsUnderline );
if fData.Font.StrikeOut then include( Result, fsStrikeOut );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TGraphicTool.SetFontStyle(const Value: TFontStyle);
begin
if FontStyle = Value then Exit;
if fsBold in Value then
begin
if fData.Font.Weight < 700 then
fData.Font.Weight := 700;
end
else
begin
if fData.Font.Weight >= 700 then
fData.Font.Weight := 0;
end;
fData.Font.Italic := fsItalic in Value;
fData.Font.Underline := fsUnderline in Value;
fData.Font.StrikeOut := fsStrikeOut in Value;
Changed;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
function TGraphicTool.GetPenMode: 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 ASM_VERSION} //Pascal
function TGraphicTool.GetHandle: THandle;
begin
Result := fHandle;
if Result <> 0 then
begin
if Color2RGB( fData.Color ) <> fColorRGB then
begin
DeleteObject( ReleaseHandle );
Result := 0;
end;
end;
if Result = 0 then
begin
if ( 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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$UNDEF ASM_LOCAL}
{$IFNDEF UNICODE_CTRLS}
{$IFDEF ASM_VERSION}
{$IFNDEF AUTO_REPLACE_CLEARTYPE}
{$DEFINE ASM_LOCAL}
{$ENDIF AUTO_REPLACE_CLEARTYPE}
{$ENDIF ASM_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 ASM_VERSION} //Pascal
function MakeFontHandle( Self_: PGraphicTool ): THandle;
{$IFDEF AUTO_REPLACE_CLEARTYPE}
var LF: TLogFont;
{$ENDIF}
begin
with Self_^ do
begin
if fHandle = 0 then
begin
{$IFDEF AUTO_REPLACE_CLEARTYPE}
Move( fData.Font, LF, Sizeof( LF ) );
if WinVer < wvXP then
begin
if LF.lfQuality > ANTIALIASED_QUALITY then
LF.lfQuality := ANTIALIASED_QUALITY;
end;
fHandle := CreateFontIndirect( LF );
{$ELSE}
fHandle := CreateFontIndirect( PLogFont( @ fData.Font )^ );
{$ENDIF}
{$IFDEF DEBUG_GDIOBJECTS}
Inc( FontCount );
{$ENDIF}
end;
Result := fHandle;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function MakePenHandle( Self_: PGraphicTool ): THandle;
var
LogPen: TLogPen;
begin
with Self_^ do
begin
//GlobalGraphics_OnObjectCreating( @Self );
if fHandle = 0 then
with LogPen do
begin
lopnStyle := Byte( fData.Pen.Style );
lopnWidth.X := fData.Pen.Width;
lopnColor := Color2RGB( fData.Color );
fHandle := CreatePenIndirect( LogPen );
{$IFDEF DEBUG_GDIOBJECTS}
Inc( PenCount );
{$ENDIF}
end;
//GlobalGraphics_OnObjectCreated( @Self );
Result := fHandle;
end;
end;
{$ENDIF ASM_VERSION}
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 ASM_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 begin
lbStyle := BS_HATCHED;
case fData.Pen.BrushStyle of
bsHorizontal: lbHatch := HS_HORIZONTAL;
bsVertical: lbHatch := HS_VERTICAL;
bsFDiagonal: lbHatch := HS_FDIAGONAL;
bsBDiagonal: lbHatch := HS_BDIAGONAL;
bsCross: lbHatch := HS_CROSS;
bsDiagCross: lbHatch := HS_DIAGCROSS;
end;
end;
end;
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 ASM_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 ASM_VERSION} //Pascal
function TCanvas.Assign(SrcCanvas: PCanvas): Boolean;
begin
fFont := fFont.Assign( SrcCanvas.fFont );
fBrush := fBrush.Assign( SrcCanvas.fBrush );
fPen := fPen.Assign( SrcCanvas.fPen );
AssignChangeEvents;
Result := (fFont <> nil) or (fBrush <> nil) or (fPen <> nil);
if (SrcCanvas.PenPos.x <> PenPos.x) or (SrcCanvas.PenPos.y <> PenPos.y) then
begin
Result := True;
PenPos := SrcCanvas.PenPos;
end;
if SrcCanvas.ModeCopy <> ModeCopy then
begin
Result := True;
ModeCopy := SrcCanvas.ModeCopy;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.CreateBrush;
begin
//////////////////////////
if assigned( fBrush ) then
//////////////////////////
begin
SelectObject( GetHandle, fBrush.Handle );
AssignChangeEvents;
if fBrush.fData.Brush.Style = bsSolid then
begin
SetBkColor( fHandle, Color2RGB( fBrush.fData.Color ) );
SetBkMode( fHandle, OPAQUE );
end
else
begin
{ Win95 doesn't draw brush hatches if bkcolor = brush color }
{ Since bkmode is transparent, nothing should use bkcolor anyway }
SetBkColor( fHandle, not Color2RGB( fBrush.fData.Color ) );
SetBkMode( fHandle, TRANSPARENT );
end;
end
else
/////////////////////////////////
if Assigned( fOwnerControl ) then
/////////////////////////////////
begin
SetBkColor( GetHandle, Color2RGB( PControl( fOwnerControl ).fColor ) );
SetBkMode( fHandle, OPAQUE );
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_VERSION} //Pascal
procedure TCanvas.DeselectHandles;
begin
if (fHandle <> 0) and
LongBool(fState and (PenValid or BrushValid or FontValid)) then
with Stock do
begin
if StockPen = 0 then
begin
StockPen := GetStockObject(BLACK_PEN);
StockBrush := GetStockObject(HOLLOW_BRUSH);
StockFont := GetStockObject(SYSTEM_FONT);
end;
SelectObject( fHandle, StockPen );
SelectObject( fHandle, StockBrush );
SelectObject( fHandle, StockFont );
fState := fState and not( PenValid or BrushValid or FontValid );
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE TCanvas.DeselectHandles;
BEGIN
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 ASM_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 ASM_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 ASM_VERSION} //Pascal
procedure TCanvas.SetHandle(Value: HDC);
{$IFDEF F_P}
var Ptr1: Pointer;
{$ENDIF F_P}
begin
if fHandle = Value then Exit;
if fHandle <> 0 then
begin
DeselectHandles;
{$IFDEF GDI}
if not( (fOwnerControl <> nil) and
(PControl(fOwnerControl).fPaintDC = fHandle) ) then
begin
{$IFDEF F_P}
Ptr1 := Self;
asm
MOV EAX, [Ptr1]
MOV EAX, [EAX].TCanvas.fOnGetHandle
MOV [Ptr1], EAX
end [ 'EAX' ];
if Ptr1 = @ TControl.DC2Canvas then
{$ELSE DELPHI}
//////////////////// SLAG
if TMethod(fOnGetHandle).Code =
@TControl.Dc2Canvas then
{$ENDIF F_P/DELPHI}
ReleaseDC(PControl(fOwnerControl).Handle, fHandle )
else
DeleteDC( fHandle );
////////////////////
end;
{$ENDIF GDI}
fHandle := 0;
fIsPaintDC := False;
fState := fState and not HandleValid;
end;
if Value <> 0 then
begin
fState := fState or HandleValid;
fHandle := Value;
SetPenPos( fPenPos );
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.SetPenPos(const Value: TPoint);
begin
fPenPos := Value;
{$IFDEF GDI}
MoveTo( Value.x, Value.y );
{$ENDIF GDI}
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Changing;
begin
//////////////////////////////
if Assigned( fOnChange ) then
//////////////////////////////
fOnChange( @Self );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.CopyRect(const DstRect: TRect; SrcCanvas: PCanvas;
const SrcRect: TRect);
begin
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
SrcCanvas.RequiredState( HandleValid or BrushValid );
StretchBlt( fHandle, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
DstRect.Bottom - DstRect.Top, SrcCanvas.Handle, SrcRect.Left, SrcRect.Top,
SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, ModeCopy);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
begin
RequiredState( HandleValid or BrushValid or FontValid or ChangingCanvas );
Windows.DrawFocusRect(FHandle, Rect);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer);
begin
RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
Windows.Ellipse(FHandle, X1, Y1, X2, Y2);
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
var Br: HBrush;
begin
RequiredState( HandleValid or BrushValid or ChangingCanvas );
if ( 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
begin
Windows.FillRect(fHandle, Rect, HBrush(COLOR_WINDOW + 1) );
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
BEGIN
if (fBrush <> nil) and (fBrush.BrushStyle = bsClear) then Exit;
////RequiredState( {HandleValid or} BrushValid or ChangingCanvas );
ForeBack( Brush.Color, Brush.Color );
gdk_draw_rectangle( fDrawable, fHandle, 1, Rect.Left, Rect.Top,
Rect.Right-Rect.Left, Rect.Bottom-Rect.Top );
END;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.LineTo(X, Y: Integer);
begin
RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
Windows.LineTo( fHandle, X, Y );
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE TCanvas.LineTo(X, Y: Integer);
BEGIN
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 ASM_VERSION} //Pascal
procedure TCanvas.MoveTo(X, Y: Integer);
begin
RequiredState( HandleValid );
Windows.MoveToEx( fHandle, X, Y, nil );
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE TCanvas.MoveTo(X, Y: Integer);
BEGIN
fPenPos := MakePoint( X, Y );
END;
{$ENDIF GTK}
{$ENDIF _X_}
procedure TCanvas.ObjectChanged(Sender: PGraphicTool);
begin
DeselectHandles;
end;
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Polygon(const Points: array of TPoint);
type
PPoints = ^TPoints;
TPoints = array[0..0] of TPoint;
begin
RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
{$IFDEF F_P} Windows_Polygon
{$ELSE DELPHI} Windows.Polygon
{$ENDIF}( fHandle, PPoints(@Points)^, High(Points) + 1);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Polyline(const Points: array of TPoint);
type
PPoints = ^TPoints;
TPoints = array[0..0] of TPoint;
begin
RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
{$IFDEF F_P}Windows_Polyline
{$ELSE DELPHI}Windows.Polyline
{$ENDIF}( fHandle, PPoints(@Points)^, High(Points) + 1);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
begin
RequiredState( HandleValid or BrushValid or PenValid or ChangingCanvas );
Windows.Rectangle( fHandle, X1, Y1, X2, Y2);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
begin
RequiredState( HandleValid or BrushValid or PenValid or ChangingCanvas );
Windows.RoundRect( fHandle, X1, Y1, X2, Y2, X3, Y3);
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.TextArea(const Text: KOLString; var Sz: TSize;
var P0: TPoint);
begin
Sz := TextExtent( Text );
P0.x := 0; P0.y := 0;
TOnTextArea( GlobalCanvas_OnTextArea )( @Self, Sz, P0 );
end;
{$ENDIF ASM_VERSION}
{$IFDEF _D3orHigher}
procedure TCanvas.WTextArea(const Text: WideString; 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 ASM_UNICODE}
function TCanvas.TextExtent(const Text: KOLString): TSize;
asm
PUSH EBX
PUSH ESI
MOV EBX, EAX
PUSH ECX // prepare @Result
MOV EAX, EDX
CALL System.@LStrLen
PUSH EAX // prepare Length(Text)
CALL EDX2PChar
PUSH EDX // prepare PChar(Text)
PUSH HandleValid or FontValid
PUSH EBX
CALL RequiredState
XCHG ESI, EAX
TEST ESI, ESI // ESI = fHandle before
JNZ @@1
PUSH ESI
CALL CreateCompatibleDC
MOV EDX, EBX
XCHG EAX, EDX // EAX := @Self; EDX := DC
CALL SetHandle
//****************************************************** // Added By M.Gerasimov
CMP [EBX].TCanvas.fIsPaintDC, 1
JZ @@2
XOR ESI,ESI
@@2:
//******************************************************
@@1:
PUSH HandleValid or FontValid
PUSH EBX
CALL RequiredState
PUSH EAX // prepare DC
CALL Windows.GetTextExtentPoint32A // KOL_ANSI
TEST ESI, ESI
JNZ @@exit
XOR EDX, EDX
XCHG EAX, EBX
CALL SetHandle
@@exit:
POP ESI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function TCanvas.TextExtent(const Text: KOLString): TSize;
var DC : HDC;
ClearHandle : Boolean;
begin
ClearHandle := False;
RequiredState( HandleValid or FontValid );
DC := fHandle;
if DC = 0 then
begin
DC := CreateCompatibleDC( 0 );
ClearHandle := True;
SetHandle( DC );
If Not fIsPaintDC then
ClearHandle := True; //************ // Added By Gerasimov
end;
RequiredState( HandleValid or FontValid );
GetTextExtentPoint32( fHandle, PKOLChar(Text), Length(Text), Result);
if ClearHandle then
SetHandle( 0 );
{ DC must be freed here automatically (never leaks):
if Canvas created on base of existing DC, no memDC created,
if Canvas has fHandle:HDC = 0, it is not fIsPaintDC always. }
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
FUNCTION TCanvas.TextExtent(const Text: KOLString): TSize;
VAR layout: PPangoLayout;
context: PPangoContext;
BEGIN
//RequiredState( HandleValid or FontValid );
IF fOwnerControl <> nil THEN
BEGIN
context := nil;
layout := gtk_widget_create_pango_layout(
PControl( fOwnerControl ).fEventboxHandle, nil );
END ELSE
BEGIN //todo: seems not working in such way... What to do for memory bitmap?
context := pango_context_new;
//layout := gtk_widget_create_pango_layout( fHandle, PChar( Text ) );
layout := pango_layout_new( context );
END;
pango_layout_set_font_description( layout, Font.FontHandle );
pango_layout_set_text( layout, 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}
procedure TCanvas.TextOut(X, Y: Integer; const Text: KOLString); stdcall;
asm
PUSH EBX
MOV EBX, [EBP+8]
MOV EAX, [Text]
PUSH EAX
CALL System.@LStrLen
XCHG EAX, [ESP] // prepare Length(Text)
//CALL System.@LStrToPChar // string does not need to be null-terminated !
PUSH EAX // prepare PChar(Text)
PUSH [Y] // prepare Y
PUSH [X] // prepare X
PUSH HandleValid or FontValid or BrushValid or ChangingCanvas
PUSH EBX
CALL RequiredState
PUSH EAX // prepare fHandle
CALL Windows.TextOutA // KOL_ANSI
POP EBX
end;
{$ELSE ASM_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 ASM_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 ASM_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 ASM_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}
procedure TCanvas.DrawText(Text: AnsiString; var Rect:TRect; Flags:DWord);
begin
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
Windows.DrawTextA(Handle, PAnsiChar(Text), Length(Text), Rect, Flags); // KOL_ANSI
end;
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 ASM_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 ASM_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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TCanvas.GetPen: PGraphicTool;
begin
if ( fPen = nil ) then
begin
fPen := NewPen;
AssignChangeEvents;
end;
Result := fPen;
end;
{$ENDIF ASM_VERSION}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TCanvas.GetHandle: HDC;
begin
/////////////////////////////////
if Assigned( fOnGetHandle ) then
/////////////////////////////////
begin
Result := fOnGetHandle( @Self );
SetHandle( Result );
end
else
Result := fHandle;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
FUNCTION TCanvas.GetHandle: HDC;
BEGIN
////////////////////////////////
IF Assigned( fOnGetHandle ) THEN
////////////////////////////////
fHandle := fOnGetHandle( @Self );
Result := fHandle;
END;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TCanvas.AssignChangeEvents;
begin
if ( fBrush <> nil ) then
fBrush.fOnChange := ObjectChanged;
if ( fPen <> nil ) then
fPen.fOnChange := ObjectChanged;
if ( fFont <> nil ) then
fFont.fOnChange := ObjectChanged;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
{$IFNDEF _FPC}
{$IFNDEF _D2}
procedure TCanvas.WDrawText(WText: WideString; var Rect: TRect;
Flags: DWord);
begin
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
Windows.DrawTextW(Handle,PWideChar(WText),Length(WText),Rect,Flags);
end;
procedure TCanvas.WExtTextOut(X, Y: Integer; Options: DWORD;
const Rect: TRect; const WText: WideString;
const Spacing: array of Integer);
begin
RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
Windows.ExtTextOutW(FHandle, X, Y, Options, @Rect, PWideChar(WText), Length(WText), @Spacing[ 0 ]);
end;
procedure TCanvas.WTextOut(X, Y: Integer; const WText: WideString);
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: WideString);
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.ExtTextOutW( fHandle, X, Y, Options,
@Rect, PWideChar(WText),
Length(WText), nil);
end;
function TCanvas.WTextExtent(const WText: WideString): TSize;
var DC : HDC;
ClearHandle : Boolean;
begin
ClearHandle := False;
RequiredState( HandleValid or FontValid );
DC := fHandle;
if DC = 0 then
begin
DC := CreateCompatibleDC( 0 );
ClearHandle := True;
SetHandle( DC );
end;
RequiredState( HandleValid or FontValid );
Windows.GetTextExtentPoint32W( fHandle, PWideChar(WText), Length(WText), Result);
if ClearHandle then
SetHandle( 0 );
end;
function TCanvas.WTextHeight(const WText: WideString): Integer;
begin
Result := WTextExtent( WText ).cy;
end;
function TCanvas.WTextWidth(const WText: WideString): 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 ASM_VERSION} //Pascal
function Mul64i( const X: I64; Mul: Integer ): I64;
var Minus: Boolean;
begin
Minus := FALSE;
if Mul < 0 then
begin
Minus := TRUE;
Mul := -Mul;
end;
Result := Mul64EDX( X, Mul );
if Minus then
Result := Neg64( Result );
end;
{$ENDIF ASM_VERSION}
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 ASM_VERSION} //Pascal
function Div64i( const X: I64; D: Integer ): I64;
var Minus: Boolean;
begin
Minus := FALSE;
if D < 0 then
begin
D := -D;
Minus := TRUE;
end;
Result := X;
if Sgn64( Result ) < 0 then
begin
Result := Neg64( Result );
Minus := not Minus;
end;
Result := Div64EDX( Result, D );
if Minus then
Result := Neg64( Result );
end;
{$ENDIF ASM_VERSION}
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 ): AnsiString;
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 not( S[ I ] in [ '0'..'9' ] ) then
break;
Result := Mul64i( Result, 10 );
IncInt64( Result, Integer( S[ I ] ) - Integer( '0' ) );
Inc( I );
end;
if M then
Result := Neg64( Result );
end;
function Int64_2Double( 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
'.': if not Pt then Pt := TRUE else break;
'0'..'9': if not Pt then
Result := Result * 10.0 + Integer( S[ I ] ) - Integer( '0' )
else
begin
D := D * 0.1;
Result := Result + (Integer( S[ I ] ) - Integer( '0' )) * D;
end;
'e', 'E': begin
Ex := Str2Int( CopyEnd( S, I + 1 ) );
Result := Result * IntPower( 10.0, Ex );
break;
end;
end;
Inc( I );
end;
if M then
Result := -Result;
end;
function Str2Extended( const S: 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
'.': if not Pt then Pt := TRUE else break;
'0'..'9': if not Pt then
Result := Result * 10.0 + Integer( S[ I ] ) - Integer( '0' )
else
begin
D := D * 0.1;
Result := Result + (Integer( S[ I ] ) - Integer( '0' )) * D;
end;
'e', 'E': begin
Ex := Str2Int( CopyEnd( S, I + 1 ) );
Result := Result * IntPower( 10.0, Ex );
break;
end;
end;
Inc( I );
end;
if M then
Result := -Result;
end;
function TruncD( 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
//D := D + 1/IntPower( 10, n-1 );
//goto start;
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 ): AnsiString;
var E, E1, E2: Double;
S: AnsiString;
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}
function Int2Hex( Value : DWord; Digits : Integer ) : KOLString;
asm // EAX = Value
// EDX = Digits
// ECX = @Result
PUSH 0
ADD ESP, -0Ch
PUSH EDI
PUSH ECX
LEA EDI, [ESP+8+0Fh] // EBX := @Buf[ 15 ]
{$IFDEF SMALLEST_CODE}
{$ELSE}
AND EDX, $F
{$ENDIF}
@@loop: DEC EDI
DEC EDX
PUSH EAX
{$IFDEF PARANOIA} DB $24, $0F {$ELSE} AND AL, 0Fh {$ENDIF}
{$IFDEF oldcode}
{$IFDEF PARANOIA} DB $3C, 9 {$ELSE} CMP AL, 9 {$ENDIF}
JA @@10
{$IFDEF PARANOIA} DB $04, 30h-41h+0Ah {$ELSE} ADD AL,30h-41h+0Ah {$ENDIF}
@@10:
{$IFDEF PARANOIA} DB $04, 41h-0Ah {$ELSE} ADD AL,41h-0Ah {$ENDIF}
{$ELSE newcode}
AAM
DB $D5, $11 //AAD
ADD AL, $30
{$ENDIF newcode}
//MOV byte ptr [EDI], AL
STOSB
DEC EDI
POP EAX
SHR EAX, 4
JNZ @@loop
TEST EDX, EDX
JG @@loop
POP EAX // EAX = @Result
MOV EDX, EDI // EDX = @resulting string
{$IFDEF _D2009orHigher}
//PUSH ECX // TODO: remove ecx protection
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
{$IFDEF _D2009orHigher}
//POP ECX // ECX popup twice to eax?
{$ENDIF}
POP EDI
ADD ESP, 10h
{== by KSer - to test it only.
function Int2Hex( Value : DWord; Digits : Integer ) : shortString;
asm
MOV [ECX], DL
XADD EDX, ECX
@@loop1:
PUSH EAX
db $24, $0F // and al,$0F
AAM
DB $D5, $11 // AAD
db $04, $30 // add al,$30
MOV [EDX], AL
POP EAX
SHR EAX, 4
DEC EDX
LOOP @@loop1
}
end;
{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_UNICODE}
function Hex2Int( const Value : AnsiString) : Integer;
asm
CALL EAX2PChar
PUSH ESI
XCHG ESI, EAX
XOR EDX, EDX
TEST ESI, ESI
JE @@exit
LODSB
{$IFDEF PARANOIA} DB $3C, '$' {$ELSE} CMP AL, '$' {$ENDIF}
JNE @@1
@@0: LODSB
@@1: TEST AL, AL
JE @@exit
{$IFDEF PARANOIA} DB $2C, '0' {$ELSE} SUB AL, '0' {$ENDIF}
{$IFDEF PARANOIA} DB $3C, 9 {$ELSE} CMP AL, '9' - '0' {$ENDIF}
JBE @@3
{$IFDEF PARANOIA} DB $2C, $11 {$ELSE} SUB AL, 'A' - '0' {$ENDIF}
{$IFDEF PARANOIA} DB $3C, 5 {$ELSE} CMP AL, 'F' - 'A' {$ENDIF}
JBE @@2
{$IFDEF PARANOIA} DB $2C, 32 {$ELSE} SUB AL, 32 {$ENDIF}
{$IFDEF PARANOIA} DB $3C, 5 {$ELSE} CMP AL, 'F' - 'A' {$ENDIF}
JA @@exit
@@2:
{$IFDEF PARANOIA} DB $04, 0Ah {$ELSE} ADD AL, 0Ah {$ENDIF}
@@3:
SHL EDX, 4
ADD DL, AL
JMP @@0
@@exit: XCHG EAX, EDX
POP ESI
end;
{$ELSE ASM_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 ASM_VERSION}
function Octal2Int( const Value: AnsiString ) : Integer;
var I: Integer;
begin
Result := 0;
for I := 1 to Length( Value ) do
begin
if Value[ I ] in [ '0'..'7' ] then
Result := Result * 8 + Ord( Value[ I ] ) - Ord( '0' )
else break;
end;
end;
function Binary2Int( const Value: AnsiString ) : Integer;
var I: Integer;
begin
Result := 0;
for I := 1 to Length( Value ) do
begin
if Value[ I ] in [ '0'..'1' ] then
Result := Result * 2 + Ord( Value[ I ] ) - Ord( '0' )
else break;
end;
end;
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
Assert( (radix >= 2) and (radix <= 36), 'Radix base must be between 2 and 36' );
Assert( min_digits <= 64, 'Maximum possible digits number is 64' );
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
Assert( (radix >= 2) and (radix <= 36), 'Radix base must be between 2 and 36' );
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 ASM_VERSION}
function cHex2Int( const Value : AnsiString) : Integer;
begin
if StrEq( Copy( Value, 1, 2 ), '0x' ) then
Result := Hex2Int( CopyEnd( Value, 3 ) )
else Result := Hex2Int( Value );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function Int2Str( Value : Integer ) : KOLString;
asm
XOR ECX, ECX
PUSH ECX
ADD ESP, -0Ch
PUSH EBX
LEA EBX, [ESP + 15 + 4]
PUSH EDX
CMP EAX, ECX
PUSHFD
JGE @@1
NEG EAX
@@1:
MOV CL, 10
@@2:
DEC EBX
XOR EDX, EDX
DIV ECX
ADD DL, 30h
MOV [EBX], DL
TEST EAX, EAX
JNZ @@2
POPFD
JGE @@3
DEC EBX
MOV byte ptr [EBX], '-'
@@3:
POP EAX
MOV EDX, EBX
{$IFDEF _D2009orHigher}
XOR ECX, ECX // TODO: safe to destory twice?
{$ENDIF}
CALL System.@LStrFromPChar
POP EBX
ADD ESP, 10h
end;
{$ELSE ASM_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 ASM_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 ): AnsiString;
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 := '' + RomeDigs[ FromIdx ] + RomeDigs[ FromIdx + 1 ];
5, 6, 7, 8: Result := RomeDigs[ FromIdx + 1 ] + StrRepeat( RomeDigs[ FromIdx ],
N - 5 );
9: Result := '' + RomeDigs[ FromIdx ] + RomeDigs[ FromIdx + 2 ]
else Result := '';
END;
end;
var I, J: Integer;
begin
Result := '';
if Value < 1 then Exit;
if Value > 8999 then Exit;
// maximum possible is TMMMCMXCIX, i.e. 8999
J := 1;
for I := 1 to 3 do
begin
Result := RomeNum( Value mod 10, J ) + Result;
Value := Value div 10;
if Value = 0 then Exit;
Inc( J, 2 );
end;
end;
{$IFDEF ASM_UNICODE}
function Int2Ths( I : Integer ) : AnsiString;
asm
PUSH EBP
MOV EBP, ESP
PUSH EAX
PUSH EDX
CALL Int2Str
POP EDX
POP EAX
TEST EAX, EAX
JGE @@0
NEG EAX
@@0:
CMP EAX, 1000
JL @@Exit
PUSH EDX
MOV EAX, [EDX]
PUSH EAX
CALL System.@LStrLen // EAX = Length(Result)
POP EDX
PUSH EDX // EDX = @Result[ 1 ]
XOR ECX, ECX
@@1:
ROL ECX, 8
DEC EAX
MOV CL, [EDX+EAX]
JZ @@fin
CMP ECX, 300000h
JL @@1
PUSH ECX
XOR ECX, ECX
MOV CL, [ThsSeparator]
JMP @@1
@@fin: CMP CL, '-'
JNE @@fin1
CMP CH, [ThsSeparator]
JNE @@fin1
MOV CH, 0 // this corrects -,ddd,...
@@fin1: CMP ECX, 01000000h
JGE @@fin2
INC EAX
ROL ECX, 8
JMP @@fin1
@@fin2: PUSH ECX
LEA EDX, [ESP+EAX]
MOV EAX, [EBP-4]
{$IFDEF _D2009orHigher}
XOR ECX, ECX // TODO: safe to change ecx?
{$ENDIF}
CALL System.@LStrFromPChar
@@Exit:
MOV ESP, EBP
POP EBP
end;
{$ELSE ASM_VERSION}
function Int2Ths( I : Integer ): KOLString;
var S : AnsiString;
begin
S := Int2Str( I );
Result := '';
while S <> '' do
begin
if Result <> '' then
Result := ThsSeparator + Result;
Result := CopyTail( S, 3 ) + Result;
S := Copy( S, 1, Length( S ) - 3 );
end;
if Copy( Result, 1, 2 ) = '-' + ThsSeparator then
Result := '-' + CopyEnd( Result, 3 );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function Int2Digs( Value, Digits : Integer ) : KOLString;
asm
PUSH EBP
MOV EBP, ESP
PUSH EDX // [EBP-4] = Digits
PUSH ECX
MOV EDX, ECX
CALL Int2Str
POP ECX
PUSH ECX // [EBP-8] = @Result
MOV EAX, [ECX]
PUSH EAX
CALL System.@LStrLen
POP EDX // EDX = @Result[1]
MOV ECX, EAX // ECX = Length( Result )
ADD EAX, EAX
SUB ESP, EAX
MOV EAX, ESP
PUSHAD
CALL StrCopy
POPAD
MOV EDX, EAX
ADD ESP, -100
CMP byte ptr [EDX], '-'
PUSHFD
JNE @@1
INC EDX
@@1:
MOV EAX, [EBP-4] // EAX = Digits
CMP ECX, EAX
JGE @@2
DEC EDX
MOV byte ptr [EDX], '0'
INC ECX
JMP @@1
@@2:
POPFD
JNE @@3
DEC EDX
MOV byte ptr [EDX], '-'
@@3:
MOV EAX, [EBP-8]
{$IFDEF _D2009orHigher}
XOR ECX, ECX // TODO: eax or ecx affect result?
{$ENDIF}
CALL System.@LStrFromPChar
MOV ESP, EBP
POP EBP
end;
{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function Num2Bytes( Value : Double ) : AnsiString;
const Suffix = 'KMGT';
var V, I : Integer;
begin
Result := '';
I := 0;
while (Value >= 1024) and (I < 4) do
begin
Inc( I );
Value := Value / 1024.0;
end;
Result := Int2Str( Trunc( Value ) );
V := Trunc( (Value - Trunc( Value )) * 100 );
if V <> 0 then
begin
if (V mod 10) = 0 then
V := V div 10;
Result := Result + ',' + Int2Str( V );
end;
if I > 0 then
Result := Result + Suffix[ I ];
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function S2Int( S: PAnsiChar ): Integer;
var M : Integer;
begin
Result := 0;
if S = '' then Exit;
M := 1;
if S^ = '-' then
begin
M := -1;
Inc( S );
end
else
if S^ = '+' then
Inc( S );
while S^ in [ '0'..'9' ] do
begin
Result := Result * 10 + Integer( S^ ) - Integer( '0' );
Inc( S );
end;
if M < 0 then
Result := -Result;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function Str2Int(const Value : AnsiString) : Integer;
begin
Result := S2Int( PAnsiChar( Value ) );
end;
{$ENDIF ASM_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}
function TrimLeft(const S: Ansistring): Ansistring;
asm
XCHG EAX, EDX
CALL EDX2PChar
DEC EDX
@@1: INC EDX
MOVZX ECX, byte ptr [EDX]
JECXZ @@fin
CMP CL, ' '
JBE @@1
@@fin:
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
end;
{$ELSE ASM_VERSION} //Pascal
function TrimLeft(const S: KOLString): KOLString;
var
I, L: Integer;
begin
L := Length(S);
I := 1;
while (I <= L) and (S[I] <= ' ') do Inc(I);
Result := Copy(S, I, Maxint);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function TrimRight(const S: Ansistring): Ansistring;
asm
PUSH EDX
PUSH EAX
PUSH EAX
CALL System.@LStrLen
XCHG EAX, [ESP]
CALL EAX2PChar
POP ECX
INC ECX
@@1: DEC ECX
MOV DL, [EAX+ECX]
JL @@fin
CMP DL, ' '
JBE @@1
@@fin:
INC ECX
POP EAX
XOR EDX, EDX
INC EDX
CALL System.@LStrCopy
end;
{$ELSE ASM_VERSION} //Pascal
function TrimRight(const S: KOLString): KOLString;
var
I: Integer;
begin
I := Length(S);
while (I > 0) and (S[I] <= ' ') do Dec(I);
Result := Copy(S, 1, I);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function Trim( const S : KOLString): KOLString;
begin
Result := TrimLeft( TrimRight( S ) );
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
function LowerCase(const S: Ansistring): Ansistring;
var I : Integer;
begin
Result := S;
for I := 1 to Length( S ) do
if Result[ I ] in [ 'A'..'Z' ] then
Inc( Result[ I ], 32 );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function UpperCase(const S: Ansistring): Ansistring;
var I : Integer;
begin
Result := S;
for I := 1 to Length( S ) do
if Result[ I ] in [ 'a'..'z' ] then
Dec( Result[ I ], 32 );
end;
{$ENDIF ASM_VERSION}
{$IFDEF F_P}
function DummyStrFun( const S: AnsiString ): AnsiString;
begin
Result := S;
end;
{$ENDIF F_P}
{$IFDEF ASM_UNICODE}
function CopyEnd( const S : AnsiString; Idx : Integer ) : AnsiString;
asm
PUSH ECX
PUSH EAX
PUSH EDX
CALL System.@LStrLen
POP EDX
TEST EDX, EDX
JG @@1
XOR EDX, EDX
INC EDX
@@1:
SUB EAX, EDX
MOV ECX, EAX
POP EAX
JGE @@ret_end
POP EAX
JL System.@LStrClr
@@ret_end:
INC ECX
CALL System.@LStrCopy
end;
{$ELSE ASM_VERSION} //Pascal
function CopyEnd( const S : KOLString; Idx : Integer ) : KOLString;
begin
Result := Copy( S, Idx, MaxInt );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function CopyTail( const S : AnsiString; Len : Integer ) : AnsiString;
asm
PUSH ECX
PUSH EAX
PUSH EDX
CALL System.@LStrLen
POP ECX
CMP ECX, EAX
{$IFDEF USE_CMOV}
CMOVG ECX, EAX
{$ELSE}
JLE @@1
MOV ECX, EAX
@@1: {$ENDIF}
MOV EDX, EAX
SUB EDX, ECX
INC EDX
POP EAX
CALL System.@LStrCopy
end;
{$ELSE ASM_VERSION} //Pascal
function CopyTail( const S : KOLString; Len : Integer ) : KOLString;
var L : Integer;
begin
L := Length( S );
if L < Len then
Len := L;
Result := '';
if Len = 0 then Exit;
Result := Copy( S, L - Len + 1, Len );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
procedure DeleteTail( var S : AnsiString; Len : Integer );
asm
PUSH EAX
PUSH EDX
MOV EAX, [EAX]
CALL System.@LStrLen
POP ECX
CMP ECX, EAX
{$IFDEF USE_CMOV}
CMOVG ECX, EAX
{$ELSE}
JLE @@1
MOV ECX, EAX
@@1: {$ENDIF}
MOV EDX, EAX
SUB EDX, ECX
INC EDX
POP EAX
CALL System.@LStrDelete
end;
{$ELSE ASM_VERSION} //Pascal
procedure DeleteTail( var S : KOLString; Len : Integer );
var L : Integer;
begin
L := Length( S );
if Len > L then
Len := L;
Delete( S, L - Len + 1, Len );
end;
{$ENDIF ASM_VERSION}
{$IFNDEF TEST_INDEXOFCHARS_COMPAT}
{$IFDEF ASM_UNICODE}
function IndexOfChar( const S : KOLString; Chr : KOLChar ) : Integer;
asm
CALL EAX2PChar
PUSH EAX
//PUSH EDX
MOV ECX, [EAX-4]
CALL StrScanLen
//POP ECX
POP EDX
//TEST EAX, EAX
//JE @@exit__1
JZ @@1
//CMP [EAX-1], CL
//JE @@1
LEA EDX, [EAX+1]
@@1: SUB EAX, EDX
//RET
//@@exit__1:
//DEC EAX
end;
{$ELSE ASM_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 ASM_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 : WideString; 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}
function IndexOfCharsMin( const S, Chars : AnsiString ) : Integer;
asm PUSH ESI
PUSH EBX
PUSH EAX
CALL EDX2PChar
MOV ESI, EDX
OR EBX, -1
MOV ECX, [EDX-4]
JECXZ @@EXIT
@@1: LODSB
XCHG EDX, EAX
POP EAX
PUSH EAX
PUSH ECX
CALL IndexOfChar
POP ECX
TEST EAX, EAX
JLE @@NEXT
TEST EBX, EBX
JLE @@ASGN
CMP EAX, EBX
JGE @@NEXT
@@ASGN:
XCHG EAX, EBX
@@NEXT: LOOP @@1
@@EXIT: XCHG EAX, EBX
POP ECX
POP EBX
POP ESI
end;
{$ELSE ASM_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 ASM_VERSION}
{$IFDEF _D3orHigher}
function WIndexOfCharsMin( const S, Chars : WideString ) : 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 : WideString ) : Integer;
var I, J : Integer;
begin
Result := -1;
for I := 1 to Length( Chars ) do
begin
J := pos( Chars[ I ], S );
if J > 0 then
begin
if (Result < 0) or (J < Result) then
Result := J;
end;
end;
end;
{$ENDIF _D2}
{$ENDIF _FPC}
{$IFDEF ASM_UNICODE}
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 System.@LStrToPChar
CALL EAX2PChar
MOV BL, [EAX]
XCHG EAX, [ESP]
//CALL System.@LStrToPChar
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 ASM_VERSION} //Pascal
function IndexOfStr( const S, Sub : KOLString ) : Integer;
var I : Integer;
begin
Result := Length( S );
if Sub = '' then Exit;
Result := 0;
if S = '' then Exit;
if Length( Sub ) > Length( S ) then Exit;
Result := 1;
while Result + Length( Sub ) - 1 <= Length( S ) do
begin
I := IndexOfChar( CopyEnd( S, Result ), Sub[ 1 ] );
if I <= 0 then break;
Result := Result + I - 1;
if Result <= 0 then Exit;
if Copy( S, Result, Length( Sub ) ) = Sub then Exit;
Inc( Result );
end;
Result := -1;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE} //???
function Parse( var S : AnsiString; const Separators : AnsiString ) : AnsiString;
asm
PUSH EBX
PUSH ESI
PUSH EDI
MOV EDI, ECX
XCHG ESI, EAX
MOV EAX, [ESI]
CALL IndexOfCharsMin
XCHG EBX, EAX
TEST EBX, EBX
JG @@1
MOV EAX, [ESI]
CALL System.@LStrLen
XCHG EBX, EAX
INC EBX
@@1:
XOR EDX, EDX
INC EDX
PUSH EDX
PUSH EDI
MOV ECX, EBX
DEC ECX
MOV EAX, [ESI]
CALL System.@LStrCopy
XCHG EAX, ESI
MOV ECX, EBX
POP EDX
CALL System.@LStrDelete
POP EDI
POP ESI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function Parse( var S : KOLString; const Separators : KOLString ) : KOLString;
var Pos : Integer;
begin
Pos := IndexOfCharsMin( S, Separators );
if Pos <= 0 then
Pos := Length( S )+1;
Result := Copy( S, 1, Pos-1 );
Delete( S, 1, Pos );
end;
{$ENDIF ASM_VERSION}
{$IFDEF _D3orHigher}
function ParseW( var S : WideString; const Separators : WideString ) : WideString;
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 : WideString; const Separators : WideString ) : WideString;
var Pos : Integer;
begin
Pos := IndexOfWideCharsMin( S, Separators );
if Pos <= 0 then
Pos := Length( S ) + 1;
Result := S;
S := Copy( Result, Pos + 1, MaxInt );
Result := Copy( Result, 1, Pos - 1 );
end;
{$ENDIF _D2}
{$ENDIF _FPC}
function ParsePascalString( var S : AnsiString; const Separators : AnsiString ) : AnsiString;
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 : AnsiString;
Ou, Val : Integer;
begin
Pos := 1;
Spc := IndexOfChar( Separators, ' ' ) >= 0;
SkipSpaces;
if Length( S ) < Pos then
begin
Result := S;
S := '';
exit;
end;
Buf := PAnsiChar( S );
Ou := 1;
if S[ Pos ] in [ '''', '#' ] then
begin
// skip here string constant expression
while Pos <= Length( S ) do
begin
if S[ Pos ] = '''' then
begin
Inc( Pos );
while Pos <= Length( S ) do
begin
if S[ Pos ] = '''' then
if (Pos = Length( S )) or (S[ Pos+1 ] <> '''') then
begin
Inc( Pos );
break;
end
else Inc( Pos );
Buf[ Ou ] := S[ Pos ];
Inc( Ou );
Inc( Pos );
end;
end
else
if S[ Pos ] = '#' then
begin
Inc( Pos ); Hex := False; Val := 0;
if (Pos < Length( S )) and (S[ Pos ] = '$') then
begin
Inc( Pos ); Hex := True;
end;
Dec( Pos );
while Pos < Length( S ) do
begin
Inc( Pos );
if (S[ Pos ] in [ '0'..'9' ]) or
Hex and (S[ Pos ] in [ 'a'..'f', 'A'..'F' ]) then
begin
if Hex then
Val := Val * 16
else
Val := Val * 10;
if S[ Pos ] <= '9' then
Val := Val + Integer( S[ Pos ] ) - Integer( '0' )
else
if S[ Pos ] <= 'F' then
Val := Val + 10 + Integer( S[ Pos ] ) - Integer( 'A' )
else
Val := Val + 10 + Integer( S[ Pos ] ) - Integer( 'a' );
continue;
end;
Inc( Pos ); break;
end;
Buf[ Ou ] := AnsiChar( 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 : AnsiString ) : AnsiString;
var I, Strt : Integer;
function String2DoubleQuotas( const S : AnsiString ) : AnsiString;
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 ASM_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 ASM_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: WideString): WideString;
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: WideString): WideString;
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: WideString): WideString;
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: WideString): WideString;
var Len: Integer;
begin
Result := S;
Len := Length(S);
if Len > 0 then CharLowerBuffW(Pointer(Result), Len);
end;
{$ENDIF WIN}
{$IFDEF WIN}
function WStrComp(const S1, S2: WideString): Integer;
var i: Integer;
begin
for i := 1 to min( Length( S1 ), Length( S2 ) ) do
begin
Result := Ord( S1[ i ] ) - Ord( S2[ i ] );
if Result <> 0 then Exit;
end;
Result := Length( S1 ) - Length( S2 );
end;
{$IFDEF ASM_VERSION}
function _WStrComp(S1, S2: PWideChar): Integer;
asm
PUSH ESI
XCHG ESI, EAX
XOR EAX, EAX
@@1:
LODSW
MOV ECX, EAX
SUB AX, word ptr [EDX]
JNZ @@exit
JECXZ @@exit
INC EDX
INC EDX
JMP @@1
@@exit:
MOVSX EAX, AX
POP ESI
end;
{$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 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;
//X: array[ AnsiChar ] of Integer;
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}
function _AnsiCompareStrA_Fast2(S1, S2: PAnsiChar): Integer;
asm
CALL EAX2PChar
CALL EDX2PChar
PUSH ESI
XCHG ESI, EAX
XOR EAX, EAX
@@1:
LODSB
MOV CX, [EAX*2 + SortAnsiOrder]
MOV AL, [EDX]
SUB CX, [EAX*2 + SortAnsiOrder]
JNZ @@retCL
INC EDX
TEST AL, AL
JNZ @@1
@@retCL:
MOVSX EAX, CX
POP ESI
end;
{$ELSE ASM_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 ASM_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)],
R.A[AnsiChar(e2)]
);
end;
{$IFDEF ASM_VERSION}
function _AnsiCompareStrNoCaseA_Fast2(S1, S2: PAnsiChar): Integer;
asm
CALL EAX2PChar
CALL EDX2PChar
PUSH ESI
XCHG ESI, EAX
XOR EAX, EAX
@@1:
LODSB
MOV CX, [EAX*2 + SortAnsiOrderNoCase]
MOV AL, [EDX]
SUB CX, [EAX*2 + SortAnsiOrderNoCase]
JNZ @@retCL
INC EDX
TEST AL, AL
JNZ @@1
@@retCL:
MOVSX EAX, CX
POP ESI
end;
{$ELSE ASM_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 ASM_VERSION}
function _AnsiCompareStrNoCaseA_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 );
//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)], R.A[c] ) = 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(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 ASM_VERSION} //Pascal
function StrPCopy(Dest: PAnsiChar; const Source: Ansistring): PAnsiChar;
begin
Result := StrLCopy(Dest, PAnsiChar(Source), Length(Source));
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function StrEq( const S1, S2 : AnsiString ) : Boolean;
begin
Result := (Length( S1 ) = Length( S2 )) and
(LowerCase( S1 ) = LowerCase( S2 ));
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function AnsiEq( const S1, S2 : KOLString ) : Boolean;
begin
Result := AnsiCompareStrNoCase( S1, S2 ) = 0;
end;
{$ENDIF ASM_VERSION}
{$IFNDEF _D2}
{$IFNDEF _FPC}
function WAnsiEq( const S1, S2 : WideString ) : Boolean;
begin
Result := WAnsiLowerCase( S1 )=WAnsiLowerCase( S2 );
end;
{$ENDIF _FPC}
{$ENDIF _D2}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function StrIn(const S: AnsiString; const A: array of String): Boolean;
var I : Integer;
begin
for I := Low( A ) to High( A ) do
if StrEq( S, A[ I ] ) then
begin
Result := True;
Exit;
end;
Result := False;
end;
{$ENDIF ASM_VERSION}
{$IFNDEF _D2}
{$IFNDEF _FPC}
function WStrIn( const S : WideString; const A : array of WideString ) : Boolean;
var I : Integer;
begin
for I := Low( A ) to High( A ) do
if WAnsiEq( S, A[ I ] ) then
begin
Result := True;
Exit;
end;
Result := False;
end;
{$ENDIF _FPC}
{$ENDIF _D2}
function CharIn( C: KOLChar; const A: TSetofChar ): Boolean;
begin
Result := (DWord( C ) <= 255) and (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}
function _StrSatisfy( S, Mask : PKOLChar ) : Boolean;
asm
TEST EAX, EAX
JZ @@exit
XCHG ECX, EAX
// EDX <- Mask
// ECX <- S
XOR EAX, EAX
MOV AL, '*'
@@rest_satisfy:
PUSH ECX
PUSH EDX
@@nx_char:
MOV AH, [EDX]
OR AH, [ECX]
JZ @@fin //@@ret_true
MOV AH, 0
CMP word ptr [EDX], AX //'*'
JE @@fin //@@ret_true
CMP byte ptr [ECX], AH
JNE @@10
DEC EDX
@@1:
INC EDX
CMP byte ptr [EDX], AL //'*'
JE @@1
CMP byte ptr [EDX], AH
SETZ AL
JMP @@fin
@@10: CMP byte ptr [EDX], AH
JE @@ret_false
CMP byte ptr [EDX], '?'
JNE @@11
@@go_nx_char:
INC ECX
INC EDX
JMP @@nx_char
@@11:
CMP byte ptr [EDX], AL //'*'
JNE @@20
INC EDX
@@12: CMP byte ptr [ECX], AH
JE @@ret_false
CALL @@rest_satisfy
TEST AL, AL
JNE @@fin
MOV AL, '*'
INC ECX
JMP @@12
@@20: MOV AH, [EDX]
XOR AH, [ECX]
JE @@go_nx_char
@@ret_false:
XOR EAX, EAX
@@fin:
POP EDX
POP ECX
@@exit:
end;
{$ELSE ASM_VERSION} //Pascal
function _StrSatisfy( S, Mask : PKOLChar ) : Boolean;
label next_char;
begin
next_char:
Result := True;
if (S^ = #0) and (Mask^ = #0) then exit;
if (Mask^ = '*') and (Mask[1] = #0) then exit;
if S^ = #0 then
begin
while Mask^ = '*' do
Inc( Mask );
Result := Mask^ = #0;
exit;
end;
Result := False;
if Mask^ = #0 then exit;
if Mask^ = '?' then
begin
Inc( S ); Inc( Mask ); goto next_char;
end;
if Mask^ = '*' then
begin
Inc( Mask );
while S^ <> #0 do
begin
Result := _StrSatisfy( S, Mask );
if Result then exit;
Inc( S );
end;
exit; // (Result = False)
end;
Result := S^ = Mask^;
Inc( S ); Inc( Mask );
if Result then goto next_char;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function StrSatisfy( const S, Mask: AnsiString ): Boolean;
asm
PUSH ESI
XCHG ESI, EAX
PUSH 0
XCHG EAX, EDX
CALL EAX2PChar
MOV EDX, ESP
CMP byte ptr [EAX], 0
JZ @@0
CALL AnsiLowerCase
@@0:
XCHG EAX, ESI
PUSH 0
CALL EAX2PChar
MOV EDX, ESP
CMP byte ptr [EAX], 0
JZ @@1
CALL AnsiLowerCase
@@1:
POP EAX
POP EDX
PUSH EDX
PUSH EAX
CALL _StrSatisfy
XCHG ESI, EAX
CALL RemoveStr
CALL RemoveStr
XCHG EAX, ESI
POP ESI
end;
{$ELSE ASM_VERSION} //Pascal
function StrSatisfy( const S, Mask: KOLString ): Boolean;
begin
Result := _StrSatisfy( PKOLChar( {$IFDEF UNICODE_CTRLS} WAnsiLowerCase
{$ELSE} AnsiLowerCase {$ENDIF} ( S ) ),
PKOLChar( {$IFDEF UNICODE_CTRLS} WAnsiLowerCase
{$ELSE} AnsiLowerCase {$ENDIF} ( Mask ) ) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function _2StrSatisfy( S, Mask: PAnsiChar ): Boolean;
asm // //
PUSH EBX
PUSH ECX
XCHG EBX, EAX
PUSH 0
MOV EAX, ESP
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
PUSH 0
MOV EAX, ESP
MOV EDX, EBX
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
POP EAX
POP EDX
PUSH EDX
PUSH EAX
CALL StrSatisfy
XCHG EBX, EAX
CALL RemoveStr
CALL RemoveStr
XCHG EAX, EBX
POP ECX
POP EBX
end;
{$ELSE ASM_VERSION} // Pascal
function _2StrSatisfy( S, Mask: PKOLChar ): Boolean;
begin
Result := StrSatisfy( S, Mask );
end;
{$ENDIF ASM_VERSION}
function StrReplace( var S: AnsiString; const From, ReplTo: AnsiString ): 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: WideString; NewLength: Integer );
begin
while Length( W ) < NewLength do
W := W + ' ' + W;
if Length( W ) > NewLength then
Delete( W, NewLength + 1, Length( W ) - NewLength );
end;
function CopyW( const W: WideString; From, Count: Integer ): WideString;
begin
Result := '';
if Count <= 0 then Exit;
SetLengthW( Result, Count );
Move( W[ From ], Result[ 1 ], Count * Sizeof( WideChar ) );
end;
function posW( 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}
{$IFNDEF _FPC}
{$IFNDEF _D2}
function WStrReplace( var S: WideString; const From, ReplTo: WideString ): Boolean;
var I: Integer;
begin
I := pos( From, S );
if I > 0 then
begin
S := Copy( S, 1, I - 1 ) + ReplTo + Copy( S, I + Length( From ), MaxInt );
Result := TRUE;
end
else Result := FALSE;
end;
function WStrRepeat( const S: WideString; Count: Integer ): WideString;
var I, L: Integer;
begin
L := Length( S );
SetLength( Result, L * Count );
for I := 0 to Count-1 do
Move( S[ 1 ], Result[ 1 + I * L ], L * Sizeof( WideChar ) );
end;
{$ENDIF _D2}
{$ENDIF _FPC}
function StrRepeat( const S: AnsiString; Count: Integer ): AnsiString;
var I, L: Integer;
begin
L := Length( S );
SetLength( Result, L * Count );
for I := 0 to Count-1 do
Move( S[ 1 ], Result[ 1 + I * L ], L );
end;
{$IFDEF ASM_noVERSION}
{$ELSE ASM_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] := #13;
S[J-1] := #10;
dec( J );
end
else
S[J] := S[I];
dec(J);
end;
end;
end;
end;
{$ENDIF ASM_VERSION}
var Koi8_to_Ansi: array[ Char ] of AnsiChar;
procedure Koi8ToAnsi( s: PAnsiChar );
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
);
var c: AnsiChar;
begin
if Koi8_to_Ansi[ #0 ] = #0 then
begin
for c := #1 to #255 do
begin
Koi8_to_Ansi[ c ] := c;
if (c >= #$C0) and (c <= #$FF) then
Koi8_to_Ansi[ c ] := KOI8_Rus[ c ];
end;
Koi8_to_Ansi[ #0 ] := #1;
end;
while s^ <> #0 do
begin
s^ := Koi8_to_Ansi[ s^ ];
inc( s );
end;
end;
function StrComp(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: MOV AL, BYTE PTR [EDI]
INC EDI
MOV BL, BYTE PTR [EAX+Upper]
LODSB
SUB BL, BYTE PTR [EAX+Upper]
JNZ @@fin
AND AL, BL
JNZ @@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 ASM_VERSION} //Pascal
function __DelimiterLast( Str, Delimiters: PKOLChar ): PKOLChar;
var
P, F : PKOLChar;
begin
P := Str;
Result := P + {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}( Str );
while Delimiters^ <> #0 do
begin
F := {$IFDEF UNICODE_CTRLS} WStrRScan {$ELSE} StrRScan {$ENDIF}
( P, Delimiters^ );
if F <> nil then
if (Result^ = #0) or (Integer(F) > Integer(Result)) then
Result := F;
Inc( Delimiters );
end;
end;
{$ENDIF ASM_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}
function SkipSpaces( P: PKOLChar ): PKOLChar;
begin
while True do
begin
while (P[0] <> #0) and (P[0] <= ' ') do Inc(P);
if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;
end;
Result := P;
end;
function SkipParam(P: PKOLChar): PKOLChar;
begin
P := SkipSpaces( P );
while P[0] > ' ' do
if P[0] = '"' then
begin
Inc(P);
while (P[0] <> #0) and (P[0] <> '"') do
Inc(P);
if P[0] <> #0 then Inc(P);
end
else
Inc(P);
Result := P;
end;
{$IFDEF WIN}
function ParamStr( 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
P := SkipSpaces( P );
P1 := P;
P := SkipParam(P);
if Idx = 0 then Break;
Dec(Idx);
until (Idx < 0) or (P = P1);
Result := Copy( P1, 1, P - P1 );
if Length( Result ) >= 2 then
if (Result[ 1 ] = '"') and (Result[ Length( Result ) ] = '"') then
Result := Copy( Result, 2, Length( Result ) - 2 );
end;
end;
function ParamCount: Integer;
var
S: Ansistring;
begin
Result := 0;
while True do
begin
S := ParamStr(Result + 1);
if S = '' then Break;
Inc(Result);
end;
end;
{$ENDIF WIN}
{$IFDEF ASM_UNICODE}
function __DelimiterLast( Str: PAnsiChar; Delimiters: PAnsiChar ): PAnsiChar;
asm
PUSH ESI
CALL EAX2PChar
MOV ESI, EDX
MOV EDX, EAX
@@tolast:
CMP byte ptr [EAX], 0
JZ @@next1
INC EAX
JMP @@tolast
@@next1:
PUSH EAX
@@next:
LODSB
TEST AL, AL
JZ @@exit
PUSH EDX
XCHG EDX, EAX
CALL StrRScan
POP EDX
TEST EAX, EAX
JZ @@next
POP ECX
CMP byte ptr [ECX], 0
JZ @@next1
CMP EAX, ECX
JG @@next1
PUSH ECX
JLE @@next
@@exit: POP EAX
POP ESI
end;
function DelimiterLast( const Str, Delimiters: AnsiString ): Integer;
asm
CALL EAX2PChar
CALL EDX2PChar
PUSH EAX
CALL __DelimiterLast
POP EDX
SUB EAX, EDX
INC EAX
end;
{$ELSE ASM_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 ASM_VERSION}
// Thanks to Marco Bobba - Marisa Bo for this code
{$IFDEF ASM_UNICODE}
function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean;
asm
{$IFDEF F_P}
MOV EAX, [Str]
MOV EDX, [Pattern]
{$ENDIF F_P}
XOR ECX, ECX
@@1:
MOV CL, [EDX] // pattern[ i ]
INC EDX
MOV CH, [EAX] // str[ i ]
INC EAX
JECXZ @@2 // str = pattern; CL = #0, CH = #0
CMP CL, CH
JE @@1
@@2:
TEST CL, CL
SETZ AL
end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
{$ELSE}
function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean;
begin
Result := FALSE;
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}
function Format( const fmt: KOLString; params: array of const ): AnsiString;
asm
PUSH ESI
PUSH EDI
PUSH EBX
MOV EBX, ESP
{$IFDEF UNICODE_CTRLS}
ADD ESP, -2048
{$ELSE}
ADD ESP, -1024
{$ENDIF}
MOV ESI, ESP
INC ECX
JZ @@2
@@1:
MOV EDI, [EDX + ECX*8 - 8]
PUSH EDI
LOOP @@1
@@2:
PUSH ESP
PUSH EAX
PUSH ESI
CALL wvsprintf
MOV EDX, ESI
MOV EAX, @Result
{$IFDEF _D2009orHigher}
PUSH ECX
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
{$IFDEF _D2009orHigher}
POP ECX
{$ENDIF}
MOV ESP, EBX
POP EBX
POP EDI
POP ESI
end;
{$ELSE ASM_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 ASM_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);
// _LStrFromPCharLen(Dest, nil, DestLen);
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 ASM_VERSION}
{$IFDEF WIN}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function FileCreate(const FileName: KOLString; OpenFlags: DWord): THandle;
var Attr: DWORD;
begin
Attr := (OpenFlags shr 16) and $1FFF;
if Attr = 0 then Attr := FILE_ATTRIBUTE_NORMAL;
Result := CreateFile( PKOLChar(FileName), OpenFlags and $F0000000,
OpenFlags and $F, nil, (OpenFlags shr 8) and $F,
Attr, 0 );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
{$IFDEF _D3orHigher}
function WFileCreate(const FileName: WideString; OpenFlags: DWord): THandle;
var Attr: DWORD;
begin
Attr := (OpenFlags shr 16) and $1FFF;
if Attr = 0 then Attr := FILE_ATTRIBUTE_NORMAL;
Result := CreateFileW( PWideChar(FileName), OpenFlags and $F0000000,
OpenFlags and $F, nil, (OpenFlags shr 8) and $F,
Attr, 0 );
end;
{$ENDIF _D3orHigher}
{$IFDEF WIN}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function FileClose(Handle: THandle): Boolean;
begin
Result := CloseHandle(Handle);
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
{$UNDEF ASM_LOCAL}
{$IFDEF ASM_UNICODE}
{$DEFINE ASM_LOCAL}
{$ENDIF}
{$IFDEF FILE_EXISTS_EX}
{$UNDEF ASM_LOCAL}
{$ENDIF}
{$IFDEF WIN}
{$IFDEF ASM_LOCAL}
function FileExists( const FileName : KOLString ) : Boolean;
const size_TWin32FindData = sizeof( {$IFDEF UNICODE_CTRLS} TWin32FindDataW {$ELSE} TWin32FindDataA {$ENDIF} );
asm
CALL EAX2PChar
PUSH EAX
CALL GetFileAttributes
INC EAX
JZ @@exit
DEC EAX
{$IFDEF PARANOIA} DB $24, FILE_ATTRIBUTE_DIRECTORY {$ELSE} AND AL, FILE_ATTRIBUTE_DIRECTORY {$ENDIF}
SETZ AL
@@exit:
end;
{$ELSE ASM_VERSION} //Pascal
function FileExists( const FileName : KOLString ) : Boolean;
{$IFDEF FILE_EXISTS_EX}
var FD: TFindFileData;
//F: DWORD;
LFT: TFileTime;
Hi, Lo: Word;
{$ELSE}
var Code: Integer;
{$ENDIF}
begin
{$IFDEF FILE_EXISTS_EX}
Result := FALSE;
if not Find_First( Filename, FD ) then Exit;
if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 then Exit;
FileTimeToLocalFileTime( FD.ftLastWriteTime, LFT );
if FileTimeToDosDateTime( LFT, Hi, Lo ) then Result := TRUE;
Find_Close( FD );
{$ELSE}
Code := GetFileAttributes(PKOLChar(FileName));
Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0);
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
{$IFDEF _D3orHigher}
function WFileExists( const FileName: WideString ) : Boolean;
{$IFDEF notimplemented_FILE_EXISTS_EX}
var FD: TFindFileData;
//F: DWORD;
LFT: TFileTime;
Hi, Lo: Word;
{$ELSE}
var Code: Integer;
{$ENDIF}
begin
{$IFDEF notimplemented_FILE_EXISTS_EX}
Result := FALSE;
if not WFind_First( Filename, FD ) then Exit;
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 ASM_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 ASM_VERSION}
{$ENDIF WIN}
{$IFDEF WIN}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function FileRead(Handle: THandle; var Buffer; Count: DWord): DWord;
begin
if not ReadFile(Handle, Buffer, Count, Result, nil) then
Result := 0;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFNDEF _D2}
function File2WStr(Handle: THandle): WideString;
var Pos, Size: DWORD;
begin
Result := '';
if Handle = 0 then Exit;
Pos := FileSeek( Handle, 0, spCurrent );
Size := GetFileSize( Handle, nil );
SetString( Result, nil, (Size - Pos + 1) 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 ASM_VERSION} //Pascal
function FileWrite(Handle: THandle; const Buffer; Count: DWord): DWord;
begin
if not WriteFile(Handle, Buffer, Count, Result, nil) then
Result := 0;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function FileEOF( Handle: THandle ) : Boolean;
var Siz, Pos : DWord;
begin
Siz := GetFileSize( Handle, nil );
Pos := FileSeek( Handle, 0, spCurrent );
Result := Pos >= Siz;
end;
{$ENDIF ASM_VERSION}
{$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 ASM_VERSION} //Pascal
function FileFullPath( const FileName: KOLString ) : KOLString;
var SFI: TShFileInfo;
Src, S: KOLString;
begin
Result := '';
Src := FileName;
while Src <> '' do
begin
S := Parse( Src, '\' );
if Result <> '' then
Result := Result + '\';
if (Result = '') and (Length( S ) = 2) and (S[ 2 ] = ':') then
Result := S
else
begin
{$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
( PKOLChar( Result + S ), 0, SFI, Sizeof( SFI ), SHGFI_DISPLAYNAME );
if SFI.szDisplayName[ 0 ] <> #0 then
S := SFI.szDisplayName;
Result := Result + S;
end;
end;
if ExtractFileExt( Result ) = '' then
// case when flag 'Hide extensions for registered file types' is set on
// in the Explorer:
Result := Result + ExtractFileExt( FileName );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
{$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 StrEq( 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 ): WideString;
var F: THandle;
begin
{$IFDEF WIN}
if StrEq( 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: WideString ): 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 );
if F = INVALID_HANDLE_VALUE then Exit;
Result := FileWrite( F, Mem^, Len );
FileClose( 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 );
if F = INVALID_HANDLE_VALUE then Exit;
Result := FileRead( F, Mem^, MaxLen );
FileClose( F );
end;
{$IFDEF WIN}
function Find_First( const FilePathName: KOLString; var F: TFindFileData ): Boolean;
begin
{$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}
procedure FileTime( const Path: KOLString;
CreateTime, LastAccessTime, LastModifyTime: PFileTime );
var FD : TFindFileData;
begin
if not Find_First( Path, FD ) then exit;
if CreateTime <> nil then
CreateTime^ := FD.ftCreationTime;
if LastAccessTime <> nil then
LastAccessTime^ := FD.ftLastAccessTime;
if LastModifyTime <> nil then
LastModifyTime^ := FD.ftLastWriteTime;
Find_Close( FD );
end;
function GetUniqueFilename( 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 ASM_VERSION} //Pascal
function CompareSystemTime(const D1, D2 : TSystemTime) : Integer;
var R: Integer;
procedure CompareFields(const F1, F2 : Integer);
begin
if R <> 0 then Exit;
if F1 = F2 then Exit;
if F1 < F2 then
R := -1
else
R := 1;
end;
begin
R := 0;
CompareFields( D1.wYear, D2.wYear );
CompareFields( D1.wMonth, D2.wMonth );
CompareFields( D1.wDay, D2.wDay );
CompareFields( D1.wHour, D2.wHour );
CompareFields( D1.wMinute, D2.wMinute );
CompareFields( D1.wSecond, D2.wSecond );
CompareFields( D1.wMilliseconds, D2.wMilliseconds );
Result := R;
end;
{$ENDIF ASM_VERSION}
function FileTimeCompare( const FT1, FT2 : TFileTime ) : Integer;
begin
Result := CompareFileTime( FT1, FT2 );
end;
{$ENDIF WIN}
{$IFDEF WIN}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
function DiskPresent( const DrivePath: KOLString ): Boolean;
var e: DWORD;
restore: Boolean;
begin
e := 0;
Restore := FALSE;
if (Copy( DrivePath, 1, 2 ) = '\\') then
else
CASE GetDriveType( PKOLChar( DrivePath ) ) OF
DRIVE_REMOVABLE, DRIVE_CDROM, DRIVE_RAMDISK:
begin
e := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS );
Restore := TRUE;
end;
END;
Result := DirectoryExists( DrivePath );
if Restore then
SetErrorMode( e );
end;
{$IFDEF _D3orHigher}
function WDirectoryExists(const Name: WideString): Boolean;
var
Code: Integer;
begin
Code := GetFileAttributesW(PWideChar(Name));
Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;
{$ENDIF _D3orHigher}
{$ENDIF WIN}
function CheckDirectoryContent( const Name: KOLString; SubDirsOnly: Boolean; const Mask: AnsiString ): Boolean;
var FD: TFindFileData;
begin
if not DirectoryExists( Name ) then
Result := TRUE
else
begin
if not Find_First( IncludeTrailingPathDelimiter( Name ) + Mask, FD ) then
Result := TRUE
else
begin
Result := TRUE;
repeat
if not {$IFDEF UNICODE_CTRLS}WStrIn{$ELSE}StrIn{$ENDIF}( FD.cFileName, ['.','..'] ) then
begin
if SubDirsOnly and LongBool(FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY)
or not SubDirsOnly then
begin
Result := FALSE;
break;
end;
end;
until not Find_Next( FD );
Find_Close( FD );
end;
end;
end;
function DirectoryEmpty(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}
function GetStartDir : AnsiString;
asm
PUSH EBX
MOV EBX, EAX
XOR EAX, EAX
MOV AH, 2
SUB ESP, EAX
MOV EDX, ESP
PUSH EAX
PUSH EDX
PUSH 0
CALL GetModuleFileName // in KOL_ANSI
LEA EDX, [ESP + EAX]
@@1: DEC EDX
CMP byte ptr [EDX], '\'
JNZ @@1
INC EDX
MOV byte ptr [EDX], 0
MOV EAX, EBX
MOV EDX, ESP
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar // AnsiSafe!
ADD ESP, 200h
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
{$IFDEF WIN}
{$UNDEF LINUX_USE_HOME_STARTFDIR}
{$ENDIF}
function GetStartDir : KOLString;
{$IFNDEF LINUX_USE_HOME_STARTFDIR}
var Buffer:array[0..MAX_PATH] of KOLChar;
I : Integer;
{$ENDIF}
begin
{$IFDEF LINUX_USE_HOME_STARTFDIR}
Result := getenv( 'HOME' );
{$ELSE}
I := GetModuleFileName( 0, Buffer, MAX_PATH );
for I := I downto 0 do
if Buffer[ I ] = {$IFDEF LIN} '/' {$ELSE} '\' {$ENDIF} then
begin
Buffer[ I + 1 ] := #0;
break;
end;
Result := Buffer;
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
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: Ansistring): PStrList;
var
Srch: TFindFileData;
succ: Boolean;
begin
result := nil;
succ := Find_First(dir, Srch);
while succ do begin
if (not (Srch.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0))then begin
if Result = nil then begin
Result := NewStrList;
end;
Result.Add(AnsiString(Srch.cFileName)); // TODO: because AStrList
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}
function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
asm
push edx
push ecx
xchg ecx, eax
xchg edx, ecx
call System.@LStrAsg
pop eax
pop edx
mov ecx, [eax]
jecxz @@1
add ecx, [ecx-4]
dec ecx
cmp byte ptr [ecx], dl
jz @@exit
@@1:
push eax
push 0
mov eax, esp
{$IFDEF _D2009orHigher}
//push ecx
xor ecx, ecx
{$ENDIF}
call System.@LStrFromChar
{$IFDEF _D2009orHigher}
//pop ecx
{$ENDIF}
mov edx, [esp]
mov eax, [esp+4]
call System.@LStrCat
call RemoveStr
pop eax
@@exit:
end;
{$ELSE PASCAL}
function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
begin
Result := S;
if (Result = '') or (Result[ Length( Result ) ] <> C) then
Result := Result + C;
end;
{$ENDIF ASM_VERSION}
//---------------------------------------------------------
// Following functions/procedures are created by Edward Aretino:
// IncludeTrailingPathDelimiter, ExcludeTrailingPathDelimiter,
// ForceDirectories, CreateDir, ChangeFileExt
//---------------------------------------------------------
function IncludeTrailingPathDelimiter(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 ASM_VERSION}
{$IFDEF _D3orHigher}
function WExtractFilePath( const Path: WideString ) : WideString;
var P, P0: PWideChar;
begin
P0 := PWideChar( Path );
P := W__DelimiterLast( P0, ':\/' );
if P^ = #0 then
Result := ''
else
Result := Copy( Path, 1, P - P0 + 1 );
end;
{$ENDIF}
{$IFDEF ASM_VERSION}{$IFNDEF _D2}
{$DEFINE ASM_LStrFromPCharLen}
{$ENDIF}
{$ENDIF ASM_VERSION}
function IsNetworkPath( const Path: KOLString ): Boolean;
begin
Result := (Length( Path ) >= 2) and (Path[1] = '\') and (Path[2] = '\');
end;
{$IFDEF ASM_UNICODE}
const
DirDelimiters: PAnsiChar = ':\/';
function ExtractFileName( const Path : AnsiString ) : AnsiString;
asm
PUSH EDX
PUSH EAX
MOV EDX, [DirDelimiters]
CALL __DelimiterLast
POP EDX
CMP byte ptr [EAX], 0
JZ @@1
XCHG EDX, EAX
INC EDX
@@1: POP EAX
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar // Safe!
end;
{$ELSE ASM_VERSION} //Pascal
function ExtractFileName( const Path : KOLString ) : KOLString;
var P: PKOLChar;
begin
P := __DelimiterLast( PKOLChar( Path ), ':\/' );
if P^ = #0 then
Result := Path
else
Result := P + 1;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function ExtractFileNameWOext( const Path : KOLString ) : KOLString;
asm
push ebx
push edx
push eax
call ExtractFileName
pop edx // Path -
mov eax, [esp] // eax = Result = ExtractFileName(Path)
mov eax, [eax]
push 0
mov edx, esp
call ExtractFileExt
mov eax, [esp]
call System.@LStrLen
xchg ebx, eax // ebx = Length(ExtractFileExt(Result))
call RemoveStr // ExtractFileExt -
mov eax, [esp]
mov eax, [eax]
call System.@LStrLen // eax = Length(Result)
sub eax, ebx
xchg ecx, eax
xor edx, edx
inc edx
mov eax, [esp]
mov eax, [eax]
call System.@LStrCopy
pop ebx
end;
{$ELSE PASCAL}
function ExtractFileNameWOext( const Path : KOLString ) : KOLString;
begin
Result := ExtractFileName( Path );
Result := Copy( Result, 1, Length( Result ) - Length( ExtractFileExt( Result ) ) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
const
ExtDelimeters: PAnsiChar = '.';
function ExtractFileExt( const Path : KOLString ) : KOLString;
asm
PUSH EDX
MOV EDX, [ExtDelimeters]
CALL EAX2PChar
CALL __DelimiterLast
@@1: XCHG EDX, EAX
POP EAX
{$IFDEF _D2009orHigher}
PUSH ECX
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
{$IFDEF _D2009orHigher}
POP ECX // this routine hasn't touch ECX
{$ENDIF}
end;
{$ELSE ASM_VERSION} //Pascal
function ExtractFileExt( const Path : KOLString ) : KOLString;
var P: PKOLChar;
begin
P := __DelimiterLast( PKOLChar( Path ), '.' );
Result := P;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function ReplaceExt( const Path, NewExt: KOLString ): KOLString;
asm
push ecx // result
push edx // NewExt
push eax // Path
push 0
mov edx, esp
call ExtractFilePath
pop eax
xchg [esp], eax // eax=Path, Path in stack replaced with ExtractFilePath(Path)
push 0
mov edx, esp
call ExtractFileNameWOext
// now stack conatins: result,NewExt,ExtractFilePath(Path),ExtractFileNameWOext(Path)<-ESP
mov eax, [esp+12]
mov edx, esp
push dword ptr [edx+4] // ExtractFilePath(Path)
push dword ptr [edx] // ExtractFileNameWOext(Path)
push dword ptr [edx+8] // NewExt
mov edx, 3
call System.@LStrCatN
call RemoveStr
call RemoveStr
pop ecx
pop ecx
end;
{$ELSE PASCAL}
function ReplaceExt( const Path, NewExt: KOLString ): KOLString;
begin
Result := ExtractFilePath( Path ) + ExtractFileNameWOext( Path ) +
NewExt;
end;
{$ENDIF}
function ForceDirectories(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}
function GetSystemDir: KOLString;
var Buf: array[ 0..MAX_PATH ] of KOLChar;
begin
GetSystemDirectory( @ Buf[ 0 ], MAX_PATH + 1 );
Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
end;
function GetWindowsDir : KOLString;
var Buf : array[ 0..MAX_PATH ] of KOLChar;
begin
GetWindowsDirectory( @Buf[ 0 ], MAX_PATH + 1 );
Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
end;
{$ENDIF WIN} //^^^^^^^^^^^
{$IFDEF WIN}
function GetWorkDir : KOLString;
var Buf: array[ 0..MAX_PATH ] of KOLChar;
begin
GetCurrentDirectory( MAX_PATH + 1, @ Buf[ 0 ] );
Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
end;
{$ENDIF WIN}
{$IFDEF ASM_UNICODE}
function GetTempDir : KOLString;
asm
push eax
sub esp, 264
push esp
push 261
call GetTempPath
mov edx, esp
mov eax, [esp+264]
{$IFDEF _D2009orHigher}
xor ecx, ecx
{$ENDIF}
call System.@LStrFromPChar
add esp, 264
pop edx
mov eax, [edx]
call IncludeTrailingPathDelimiter
end;
{$ELSE PASCAL}
function GetTempDir : KOLString;
{$IFDEF WIN} var Buf : Array[ 0..MAX_PATH ] of KOLChar; {$ENDIF WIN}
begin
{$IFDEF LIN} Result := '/tmp/'; {$ELSE WIN}
GetTempPath( MAX_PATH + 1, @Buf[ 0 ] );
Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
{$ENDIF WIN}
end;
{$ENDIF}
{$IFDEF WIN}
{$IFDEF ASM_UNICODE}
function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString;
asm
push ecx
call EAX2PCHAR
call EDX2PCHAR
sub esp, 264
push esp
push 0
push edx
push eax
call GetTempFileName
mov eax, [esp+264]
mov edx, esp
{$IFDEF _D2009orHigher}
xor ecx, ecx // ecx is argument
{$ENDIF}
call System.@LStrFromPChar
add esp, 268
end;
{$ELSE PASCAL}
function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString;
var Buf: array[ 0..MAX_PATH ] of KOLChar;
begin
GetTempFileName( PKOLChar( DirPath ), PKOLChar( Prefix ), 0, Buf );
Result := Buf;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN}
function GetFileListStr(FPath{e.g.'c:\tmp\'}, FMask{e.g.'*.*'}: KOLString): KOLString;
{* List of files in string, separating each path from others with FileOpSeparator.
E.g.: 'c:\tmp\unit1.dcu'#13'c:\tmp\unit1.~pa' (for use with DeleteFile2Recycle())}
var
Srch: TFindFileData;
succ: Boolean;
dir:KOLString;
begin
result := '';
if (FPath<>'') then FPath := IncludeTrailingPathDelimiter( FPath );
if (FMask<>'') and (FMask[1]={$IFDEF LIN} '/' {$ELSE} '\' {$ENDIF}) then
FMask := CopyEnd(FMask,2);
dir:=FPath+FMask;
succ := Find_First(dir, Srch);
while succ do begin
if (not (Srch.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0))then begin
if Result<>''then Result:=Result+FileOpSeparator;
Result:=Result+FPath+Srch.cFileName;
end;
succ := Find_Next(Srch);
end;
Find_Close(Srch);
end;
function DeleteFiles( 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
begin
Ex := V.dwMajorVersion >= 4;
end
else
if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then
begin
Ex := V.dwMajorVersion > 4;
if not Ex then
if V.dwMajorVersion = 4 then
begin
Ex := V.dwMinorVersion > 0;
if not Ex then
Ex := LoWord( V.dwBuildNumber ) >= $1111;
end;
end;
if Ex then
begin
Kern32 := GetModuleHandle( 'kernel32' );
GetDFSEx := GetProcAddress( Kern32, 'GetDiskFreeSpaceExA' );
end;
////////////////////////////
if Assigned( GetDFSEx ) then
////////////////////////////
GetDFSEx( PKOLChar( Path ), @ FBA, @ TNB, @Result )
else
begin
GetDiskFreeSpace( PKOLChar( Path ), SpC, BpS, NFC, TNC );
Result := Mul64i( MakeInt64( SpC * BpS, 0 ), NFC );
end;
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;
begin
L := Length( FromList );
Buf := AllocMem( L+2 );
Move( FromList[ 1 ], Buf^, L );
for L := L downto 0 do
if Buf[ L ] = FileOpSeparator then Buf[ L ] := #0;
//FillChar( FOS, Sizeof( FOS ), #0 );
ZeroMemory( @FOS, Sizeof( FOS ) );
if Applet <> nil then
FOS.Wnd := Applet.Handle;
FOS.wFunc := FileOp;
FOS.lpszProgressTitle := Title;
FOS.pFrom := Buf;
FOS.pTo := PKOLChar( ToList + #0 );
FOS.fFlags := Flags;
FOS.fAnyOperationsAborted := True;
Result := {$IFDEF UNICODE_CTRLS}SHFileOperationW{$ELSE}SHFileOperationA{$ENDIF}( FOS ) = 0;
if Result then
Result := not FOS.fAnyOperationsAborted;
FreeMem( Buf );
end;
{$ENDIF WIN_GDI}
{$IFDEF WIN}
function DirIconSysIdxOffline( 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 ASM_VERSION} //Pascal
procedure TDirList.Clear;
begin
Free_And_Nil( FListPositions );
Free_And_Nil( fStoreFiles );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
destructor TDirList.Destroy;
begin
Clear;
FPath := '';
inherited;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function FindFilter( const Filter: AnsiString): AnsiString;
asm
XCHG EAX, EDX
PUSH EAX
CALL System.@LStrAsg
POP EAX
CMP dword ptr [EAX], 0
JNE @@exit
LEA EDX, @@mask_all
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
JE System.@LStrFromPChar
@@mask_all: DB '*.*',0
@@exit:
end;
{$ELSE ASM_VERSION} //Pascal
function FindFilter(const Filter: KOLString): KOLString;
begin
Result := Filter;
if Result = '' then Result := '*.*';
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
function TDirList.GetCount: Integer;
begin
Result := 0;
if FListPositions = nil then Exit;
Result := FListPositions.Count;
end;
{$ENDIF ASM_VERSION}
{$IFDEF noASM_UNICODE}
function TDirList.GetNames(Idx: Integer): Ansistring;
asm
MOV EAX, [EAX].fList
{$IFDEF TLIST_FAST}
PUSH ECX
CALL TList.Get
LEA EDX, [EAX + offset TWin32FindData.cFileName] //
POP EAX
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
{$ELSE}
MOV EAX, [EAX].TList.fItems
MOV EDX, [EAX + EDX*4]
ADD EDX, offset TWin32FindData.cFileName //
MOV EAX, ECX
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
{$ENDIF}
end;
{$ELSE ASM_VERSION} //Pascal
function TDirList.GetNames(Idx: Integer): KOLString;
var FData: PFindFileData;
begin
//Result := PKOLChar(@PFindFileData(fList.Items[ Idx ]).cFileName[0]);
FData := Get( Idx );
Result := FData.cFileName;
end;
{$ENDIF ASM_VERSION}
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 ASM_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;
begin
Result := (((FileAttr and FindAttr) = FindAttr) or
LongBool(FindAttr and FILE_ATTRIBUTE_NORMAL));
if not Result then Exit;
if (FileName <> {$IFDEF UNICODE_CTRLS} WideString( '.' )
{$ELSE} {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}
{$ENDIF UNICODE_CTRLS} ) and
(FileName <> '..') then
if LongBool( FindAttr and FILE_ATTRIBUTE_NORMAL ) and
(FindAttr <> FILE_ATTRIBUTE_NORMAL) then
if LongBool( FindAttr and FILE_ATTRIBUTE_DIRECTORY ) and
LongBool( FileAttr and FILE_ATTRIBUTE_DIRECTORY ) then Exit;
HasOnlyNegFilters := TRUE;
for I := 0 to fFilters.Count - 1 do
begin
F := PKOLChar(fFilters.fList.Items[ I ]);
if F = '' then continue;
if (F = {$IFDEF UNICODE_CTRLS} WideString( '.' ) {$ELSE}
{$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}
{$ENDIF UNICODE_CTRLS} ) or (F = '..') then
begin
if FileName = F then
Exit;
end
else
if (Filename = {$IFDEF UNICODE_CTRLS} WideString( '.' ) {$ELSE}
{$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}
{$ENDIF UNICODE_CTRLS} ) or (FileName = '..') then
continue;
if F[ 0 ] = '^' then
begin
if StrSatisfy( FileName, PKOLChar(@F[ 1 ]) ) then
begin
Result := False;
Exit;
end;
end
else
begin
HasOnlyNegFilters := FALSE;
if StrSatisfy( FileName, F ) then
begin
Result := True;
Exit;
end;
end;
end;
Result := HasOnlyNegFilters and
(FileName <> {$IFDEF UNICODE_CTRLS} WideString( '.' ) {$ELSE}
{$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}
{$ENDIF UNICODE_CTRLS} ) and (FileName <> '..');
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_nononoVERSION}
procedure TDirList.ScanDirectory(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 ASM_VERSION} //Pascal
procedure TDirList.ScanDirectory(const DirPath, Filter: KOLString;
Attr: DWord);
var FindData : TFindFileData;
//E : PFindFileData;
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( 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 ASM_VERSION}
{$IFDEF ASM_UNICODE}
procedure TDirList.ScanDirectoryEx(const DirPath, Filters: AnsiString;
Attr: DWord);
asm
PUSH EBX
MOV EBX, EAX
PUSHAD
LEA EAX, [EBX].fFilters
CALL Free_And_Nil
CALL NewStrList
MOV [EBX].fFilters, EAX
POPAD
PUSHAD
PUSH 0
MOV EAX, ESP
MOV EDX, ECX
CALL System.@LStrLAsg
@@1: MOV ECX, [ESP]
JECXZ @@2
MOV EAX, ESP
MOV EDX, offset[@@semicolon]
PUSH 0
MOV ECX, ESP
CALL Parse
MOV EAX, [ESP]
MOV EDX, ESP
CALL Trim
POP EDX
PUSH EDX
TEST EDX, EDX
JZ @@filt_added
MOV EAX, [EBX].fFilters
CALL TStrList.Add
@@filt_added:
CALL RemoveStr
JMP @@1
// ';' string literal
{$IFDEF _D2009orHigher}
DW 0, 1
{$ENDIF}
DD -1, 1
@@semicolon:
DB ';',0
@@2: POP ECX
POPAD
XOR ECX, ECX
PUSH [Attr]
CALL ScanDirectory
POP EBX
@@exit:
end;
{$ELSE ASM_VERSION} //Pascal
procedure TDirList.ScanDirectoryEx(const DirPath, Filters: KOLString;
Attr: DWord);
var F, FF: KOLString;
begin
FF := Filters;
Free_And_Nil( fFilters );
fFilters := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
repeat
F := Trim( Parse( FF, ';' ) );
if F <> '' then
fFilters.Add( F );
until FF = '';
ScanDirectory( DirPath, '', Attr );
end;
{$ENDIF ASM_VERSION}
type
PSortDirData = ^TSortDirData;
TSortDirData = packed Record
CountRules: Integer;
FoldersFirst, CaseSensitive : Boolean;
Rules : array[ 0..9 ] 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: WideString;
{$ENDIF}
IsDir1, IsDir2 : Boolean;
Date1, Date2 : PFileTime;
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;
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 );
{$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( WideString( S1 ), '.' ) - 1 ]
{$ELSE} __DelimiterLast( S1, '.' ) {$ENDIF};
S2 := {$IFDEF UNICODE_CTRLS} @ S2[ DelimiterLast( WideString( S2 ), '.' ) - 1 ]
{$ELSE} __DelimiterLast( S2, '.' ) {$ENDIF};
if not Data.CaseSensitive then
Result := {$IFDEF UNICODE_CTRLS}
WStrComp( WAnsiUpperCase( S1 ), WAnsiUpperCase( S2 ) )
{$ELSE} _AnsiCompareStrNoCase( S1, S2 ) {$ENDIF}
else
Result := {$IFDEF UNICODE_CTRLS} WStrComp( S1, S2 )
{$ELSE} _AnsiCompareStr( S1, S2 ) {$ENDIF};
end;
sdrBySize, sdrBySizeDescending:
begin
if Item1.nFileSizeHigh < Item2.nFileSizeHigh then
Result := -1
else
if Item1.nFileSizeHigh > Item2.nFileSizeHigh then
Result := 1
else
if Item1.nFileSizeLow < Item2.nFileSizeLow then
Result := -1
else
if Item1.nFileSizeLow > Item2.nFileSizeLow then
Result := 1;
if Data.Rules[ I ] = sdrBySizeDescending then
Result := -Result;
end;
sdrByDateCreate:
begin
Date1 := @Item1.ftCreationTime;
Date2 := @Item2.ftCreationTime;
Result := CompareFileTime( Date1^, Date2^ );
end;
sdrByDateChanged:
begin
Date1 := @Item1.ftLastWriteTime;
Date2 := @Item2.ftLastWriteTime;
Result := CompareFileTime( Date1^, Date2^ );
end;
sdrByDateAccessed:
begin
Date1 := @Item1.ftLastAccessTime;
Date2 := @Item2.ftLastAccessTime;
Result := CompareFileTime( Date1^, Date2^ );
end;
sdrNone: break;
end; {case}
if Result <> 0 then break;
end;
end;
{$IFDEF ASM_VERSION}
procedure SwapDirItems( Data : PSortDirData; const e1, e2 : DWORD );
asm
MOV EAX, [EAX].TSortDirData.Dir
MOV EAX, [EAX].TDirList.FListPositions
{$IFDEF xxSPEED_FASTER} //|||||||||||||||||||||||||||||||||||||||||||||
MOV EAX, [EAX].TList.fItems
LEA EDX, [EAX+EDX*4]
LEA ECX, [EAX+ECX*4]
MOV EAX, [EDX]
XCHG EAX, [ECX]
MOV [EDX], EAX
{$ELSE}
CALL TList.Swap
{$ENDIF}
end;
{$ELSE ASM_VERSION}
procedure SwapDirItems( Data : PSortDirData; const e1, e2 : DWORD );
begin
Data.Dir.FListPositions.Swap( e1, e2 );
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
procedure TDirList.Sort(Rules: array of TSortDirRules);
var SortDirData : TSortDirData;
I, J : Integer;
function RulePresent( Rule : TSortDirRules ) : Boolean;
var K : Integer;
begin
Result := True;
for K := J - 1 downto 0 do
if Rule = SortDirData.Rules[ K ] then exit;
Result := False;
end;
procedure AddRule( Rule : TSortDirRules );
begin
if Rule in [sdrFoldersFirst, sdrCaseSensitive] then
begin
if Rule = sdrFoldersFirst then
SortDirData.FoldersFirst := TRUE;
if Rule = sdrCaseSensitive then
SortDirData.CaseSensitive := 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;
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;
inc( J );
while J < High( SortDirData.Rules ) do
begin
SortDirData.Rules[ J ] := sdrNone;
Inc( J );
end;
SortDirData.Dir := @Self;
{$IFDEF UNICODE_CTRLS}
{$IFDEF SPEED_FASTER}
_AnsiCompareStrNoCaseA( '', '' );
{$ENDIF}
{$ENDIF}
SortData( Pointer( @SortDirData ), FListPositions.fCount, @CompareDirItems, @SwapDirItems );
end;
{$ENDIF ASM_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;
{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
////////////////////////////////////////////////////////////////////////
// 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;
function RegKeyGetStr( Key: HKey; const ValueName: KOLString ): KOLString;
var dwType, dwSize: DWORD;
Buffer: PKOLChar;
function Query: Boolean;
begin
Result := RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType,
Pointer( Buffer ), @dwSize ) = ERROR_SUCCESS;
end;
begin
Result := '';
if Key = 0 then Exit;
dwSize := 0;
Buffer := nil;
if not Query or (dwType <> REG_SZ) then Exit;
GetMem( Buffer, dwSize * Sizeof( KOLChar ) );
if Query then
Result := Buffer;
FreeMem( Buffer );
end;
function RegKeyGetStrEx( 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);
// bug in size detection! sometimes we get
// an additional 2 bytes at the end...
GetMem(Buffer2,Sz * Sizeof( KOLChar )); //
ExpandEnvironmentStrings(Buffer, Buffer2, Sz); //
Result:=Buffer2; //
FreeMem(Buffer2); //
end
else
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);
//FillChar(KeyName[1],Size*Sizeof(KOLChar),#0);
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;
var I : Integer;
_Day : Integer;
DayTable: PDayTable;
begin
Result := False;
DateTime := 0.0;
DayTable := @MonthDays[IsLeapYear(SystemTime.wYear)];
with SystemTime do
if {(wYear >= 0) !always true! and} (wYear <= 9999) and
{(wMonth >= 1) and !otherwise can not convert time only!}
(wMonth <= 12) and
{(wDay >= 1) and !otherwise can not convert time only!}
(wDay <= DayTable^[wMonth]) and //
(wHour < 24) and (wMinute < 60) and (wSecond < 60) and (wMilliSeconds < 1000) then //
begin
_Day := wDay;
for I := 1 to wMonth - 1 do
Inc(_Day, DayTable^[I]);
I := wYear - 1;
//--------------- by Vadim Petrov ------++
if I<0 then i := 0; //
//--------------------------------------++
DateTime := I * 365 + I div 4 - I div 100 + I div 400 + _Day
+ (wHour * 3600000 + wMinute * 60000 + wSecond * 1000 + wMilliSeconds) / MSecsPerDay;
Result := True;
end;
end;
function DayOfWeek(Date: TDateTime): Integer;
begin
Result := (Trunc( Date ) + 6) mod 7 + 1;
end;
function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
const
D1 = 365;
D4 = D1 * 4 + 1;
D100 = D4 * 25 - 1;
D400 = D100 * 4 + 1;
var Days : Integer;
Y, M, D, I: Word;
MSec : Integer;
DayTable: PDayTable;
MinCount, MSecCount: Word;
begin
Days := Trunc( DateTime );
MSec := Round((DateTime - Days) * MSecsPerDay);
Result := False;
with SystemTime do
if Days > 0 then
begin
Dec(Days);
Y := 1;
while Days >= D400 do
begin
Dec(Days, D400);
Inc(Y, 400);
end;
DivMod(Days, D100, I, D);
if I = 4 then
begin
Dec(I);
Inc(D, D100);
end;
Inc(Y, I * 100);
DivMod(D, D4, I, D);
Inc(Y, I * 4);
DivMod(D, D1, I, D);
if I = 4 then
begin
Dec(I);
Inc(D, D1);
end;
Inc(Y, I);
DayTable := @MonthDays[IsLeapYear(Y)];
M := 1;
while True do
begin
I := DayTable^[M];
if D < I then Break;
Dec(D, I);
Inc(M);
end;
wYear := Y;
wMonth := M;
wDay := D + 1;
wDayOfWeek := KOL.DayOfWeek( DateTime );
DivMod(MSec, 60000, MinCount, MSecCount);
DivMod(MinCount, 60, wHour, wMinute);
DivMod(MSecCount, 1000, wSecond, wMilliSeconds);
Result := True;
end;
end;
function DateTime_DiffSysLoc: TDateTime;
var ST, LT: TSystemTime;
FT, FT1: TFileTime;
D1, D2: TDateTime;
begin
GetSystemTime( ST );
SystemTimeToFileTime( ST, FT );
FileTimeToLocalFileTime( FT, FT1 );
FileTimeToSystemTime( FT1, LT );
SystemTime2DateTime( ST, D1 );
SystemTime2DateTime( LT, D2 );
Result := D2 - D1;
end;
function DateTime_System2Local( 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 + 1;
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 );
{$IFDEF UNICODE_CTRLS}
if (S^ >= '0') and (S^ <= '9') then
{$ELSE}
if S^ in ['0'..'9'] then
{$ENDIF}
begin
Result := Result * 10 + Ord(S^) - Ord('0');
Inc( S );
end
else
break;
end;
end;
function GetYear( var S: PKOLChar; NChars: Integer ): Integer;
var STNow: TSystemTime;
OldDate: Boolean;
begin
Result := GetNum( S, NChars );
GetSystemTime( STNow );
OldDate := (Result >= 50) 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;
C, MonthStr: KOLString;
begin
GetSystemTime( SD );
for M := 1 to 12 do
begin
SD.wMonth := M;
C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/dd/yyyy/' ) );
MonthStr := Parse( C, '/' );
if AnsiCompareStrNoCase( MonthStr, Copy( S, 1, Length( MonthStr ) ) ) = 0 then
begin
Result := M;
Inc( S, Length( MonthStr ) );
Exit;
end;
end;
Result := 1;
end;
procedure SkipDayOfWeek( const fmt: KOLString; var S: PKOLChar );
var SD: TSystemTime;
Dt: TDateTime;
D: Integer;
C, DayWeekStr: KOLString;
begin
GetSystemTime( SD );
SystemTime2DateTime( SD, Dt );
Dt := Dt - SD.wDayOfWeek;
for D := 0 to 6 do
begin
DateTime2SystemTime( Dt, SD );
C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/MM/yyyy/' ) );
DayWeekStr := Parse( C, '/' );
if AnsiCompareStrNoCase( DayWeekStr, Copy( S, 1, Length( DayWeekStr ) ) ) = 0 then
begin
Inc( S, Length( DayWeekStr ) );
Exit;
end;
Dt := Dt + 1.0;
end;
end;
procedure GetTimeMark( const fmt: KOLString; var S: PKOLChar );
var SD: TSystemTime;
AM: Boolean;
C, TimeMarkStr: KOLString;
begin
GetSystemTime( SD );
SD.wHour := 0;
for AM := FALSE to TRUE do
begin
C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/HH/mm' ) );
TimeMarkStr := Parse( C, '/' );
if AnsiCompareStrNoCase( TimeMarkStr, Copy( S, 1, Length( TimeMarkStr ) ) ) = 0 then
begin
Inc( S, Length( TimeMarkStr ) );
hAM := AM;
Exit;
end;
SD.wHour := 13;
end;
Result := 1;
end;
function FmtIs1( S: PKOLChar ): Boolean;
begin
if StrIsStartingFrom( FmtStr, S ) then
begin
Inc( FmtStr, {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}( S ) );
Result := TRUE;
end
else
Result := FALSE;
end;
function FmtIs( S1, S2: PKOLChar ): Boolean;
begin
Result := FmtIs1( S1 ) or FmtIs1( S2 );
end;
var ST: TSystemTime;
begin
FmtStr := PKOLChar( sFmtStr);
S := PKOLChar( sS );
//FillChar( ST, Sizeof( ST ), #0 );
ZeroMemory( @ST, Sizeof( ST ) );
h12 := FALSE;
hAM := FALSE;
while (FmtStr^ <> #0) and (S^ <> #0) do
begin
{$IFDEF UNICODE_CTRLS}
if ((FmtStr^ >= 'a') and (FmtStr^ <= 'z') or
(FmtStr^ >= 'A') and (FmtStr^ <= 'Z')) and
(S^ >= '0') and (S^ <= '9') then
{$ELSE}
if (FmtStr^ in ['a'..'z','A'..'Z']) and (S^ in ['0'..'9']) then
{$ENDIF}
begin
if FmtIs1( 'yyyy' ) then ST.wYear := GetNum( S, 4 )
else if FmtIs1( 'yy' ) then ST.wYear := GetYear( S, 2 )
else if FmtIs1( 'y' ) then ST.wYear := GetYear( S, -1 )
else if FmtIs( 'dd', 'd' ) then ST.wDay := GetNum( S, 2 )
else if FmtIs( 'MM', 'M' ) then ST.wMonth := GetNum( S, 2 )
else if FmtIs( 'HH', 'H' ) then ST.wHour := GetNum( S, 2 )
else if FmtIs( 'hh', 'h' ) then begin ST.wHour := GetNum( S, 2 ); h12 := TRUE end
else if FmtIs( 'mm', 'm' ) then ST.wMinute := GetNum( S, 2 )
else if FmtIs( 'ss', 's' ) then ST.wSecond := GetNum( S, 2 )
else break; // + ECM
end
else
{$IFDEF UNICODE_CTRLS}
if (FmtStr^ = 'M') or (FmtStr^ = 'd') or (FmtStr^ = 'g') then
{$ELSE}
if (FmtStr^ in [ 'M', 'd', 'g' ]) then
{$ENDIF}
begin
if FmtIs1( 'MMMM' ) then ST.wMonth := GetMonth( 'MMMM', S )
else if FmtIs1( 'MMM' ) then ST.wMonth := GetMonth( 'MMM', S )
else if FmtIs1( 'dddd' ) then SkipDayOfWeek( 'dddd', S )
else if FmtIs1( 'ddd' ) then SkipDayOfWeek( 'ddd', S )
else if FmtIs1( 'tt' ) then GetTimeMark( 'tt', S )
else if FmtIs1( 't' ) then GetTimeMark( 't', S )
else break; // + ECM
end
else
begin
if FmtStr^ = S^ then
Inc( FmtStr );
Inc( S );
end;
end;
if h12 then
if hAM then
Inc( ST.wHour, 12 );
SystemTime2DateTime( ST, Result );
end;
var FmtBuf: PKOLChar;
DateSeparator : KOLChar = #0; // + ECM
function Str2DateTimeShort( 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 ASM_VERSION} //Pascal
function NewThreadEx( const Proc: TOnThreadExecute ): PThread;
begin
Result := NewThread;
Result.OnExecute := Proc;
Result.Resume;
end;
{$ENDIF ASM_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
//Global_Synchronized( Pointer( Msg.lParam ), Pointer( Msg.wParam ) );
Thread := PThread( Msg.lParam );
if Msg.wParam <> 0 then
Thread.FMethodEx( Thread, Pointer( Msg.wParam ) )
else
Thread.FMethod( );
Rslt := 0;
end;
end;
{$IFDEF PSEUDO_THREADS}
function timeBeginPeriod(uPeriod: UINT): UINT; 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 ASM_VERSION} //Pascal
destructor TThread.Destroy;
begin
RefInc;
if not FTerminated then
begin
Terminate;
WaitFor;
end;
if (FHandle <> 0) then
CloseHandle(FHandle);
{$IFDEF PSEUDO_THREADS}
if StackBottom <> nil then
FreeMem( StackBottom );
if MainThread = @ Self then
begin
TimeEndPeriod( 10 );
AllThreads.Free;
end
else
if MainThread <> nil then
begin
MainThread.AllThreads.Remove( @ Self );
if MainThread.AllThreads.Count <= 1 then
Free_And_Nil( MainThread );
end;
{$ENDIF}
inherited;
end;
{$ENDIF ASM_VERSION}
function TThread.Execute: 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}
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
Assert( Param <> nil, 'Parameter must not be NIL' );
{$IFDEF PSEUDO_THREADS}
Method( TMethod( Method ).Data, Param );
{$ELSE}
FMethodEx := Method;
SendMessage( Applet.fHandle, CM_EXECPROC, Integer( Param ), Integer( @Self ) );
{$ENDIF}
end;
procedure TThread.Terminate;
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 ASM_VERSION} //Pascal
function TStream.GetSize: TStrmSize;
begin
Result := fMethods.fGetSiz( @Self );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_STREAM}
procedure TStream.SetSize(const NewSize: TStrmSize);
asm
CALL [EAX].fMethods.fSetSiz
end;
{$ELSE ASM_VERSION} //Pascal
procedure TStream.SetSize(const NewSize: TStrmSize);
begin
fMethods.fSetSiz( @Self, NewSize );
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
function TStream.Read(var Buffer; const Count: TStrmSize): TStrmSize;
begin
Result := fMethods.fRead( @Self, Buffer, Count );
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
function TStream.Write(var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize;
begin
Result := fMethods.fWrite( @Self, Buffer, Count );
end;
{$ENDIF ASM_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: WideString;
var C: WideChar;
begin
Result := '';
REPEAT
C := #0;
Read( C, 2 );
if C <> #0 then
Result := Result +
{$IFDEF _D3}
WideString( C )
{$ELSE}
C
{$ENDIF};
UNTIL C = #0;
end;
{$ENDIF _D3orHigher}
function TStream.ReadStr: 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 in [ #13, #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: WideString): DWORD;
var C: WideChar;
begin
if S = '' then
begin
C := #0;
Result := Write( C, 2 );
end
else
Result := Write( S[ 1 ], (Length( S ) + 1) * 2 );
end;
{$ENDIF _D3orHigher}
function TStream.WriteStrEx(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 ASM_VERSION} //Pascal
function TStream.Seek({$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize;
begin
Result := fMethods.fSeek( @Self, MoveTo, MoveMethod );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
destructor TStream.Destroy;
begin
fMethods.fClose( @Self );
fData.fThread.Free;
inherited;
end;
{$ENDIF ASM_VERSION}
procedure TStream.SaveToFile(const Filename: KOLString; 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
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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_VERSION} //Pascal
function NewReadFileStream( const FileName: KOLString ): PStream;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fRead := ReadFileStreamProc;
Result.fData.fHandle := FileCreate( FileName,
ofOpenRead or ofShareDenyWrite or ofOpenExisting );
end;
{$ENDIF ASM_VERSION}
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: WideString ): 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 ASM_VERSION} //Pascal
function NewWriteFileStream( const FileName: KOLString ): PStream;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fWrite := WriteFileStreamEOF;
Result.fMethods.fSetSiz := SetSizeFileStream;
Result.fData.fHandle := FileCreate( FileName,
ofOpenWrite or ofCreateAlways or ofShareDenyWrite );
end;
{$ENDIF ASM_VERSION}
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: WideString ): PStream;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fWrite := WriteFileStreamEOF;
Result.fMethods.fSetSiz := SetSizeFileStream;
Result.fData.fHandle := WFileCreate( FileName,
ofOpenWrite or ofCreateAlways or ofShareDenyWrite );
end;
{$ENDIF _D3orHigher}
{$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 ASM_VERSION} //Pascal
function NewReadWriteFileStream( const FileName: KOLString ): PStream;
var Creation: DWORD;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fRead := ReadFileStreamProc;
Result.fMethods.fWrite := WriteFileStream;
Result.fMethods.fSetSiz := SetSizeFileStream;
Creation := ofCreateAlways;
if FileExists( FileName ) then Creation := ofOpenExisting;
Result.fData.fHandle := FileCreate( FileName,
ofOpenReadWrite or Creation or ofShareDenyWrite );
end;
{$ENDIF ASM_VERSION}
{$IFDEF _D3orHigher}
function NewReadWriteFileStreamW( const FileName: WideString ): PStream;
var Creation: DWORD;
begin
Result := _NewStream( BaseFileMethods );
Result.fMethods.fRead := ReadFileStreamProc;
Result.fMethods.fWrite := WriteFileStream;
Result.fMethods.fSetSiz := SetSizeFileStream;
Creation := ofCreateAlways;
if WFileExists( FileName ) then Creation := ofOpenExisting;
Result.fData.fHandle := WFileCreate( FileName,
ofOpenReadWrite or Creation or ofShareDenyWrite );
end;
{$ENDIF _D3orHigher}
function NewMemoryStream: 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 ASM_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 ASM_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 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 ASM_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 );
{ from Win32.hlp: "You do not need to call the FreeResource
function to free a resource loaded by using the LoadResource
function." }
end;
end;
end;
{$ENDIF ASM_VERSION}
///////////////////////////////////////////////////////////////////////////
// I N I - F I L E S
///////////////////////////////////////////////////////////////////////////
{ TIniFile }
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
destructor TIniFile.Destroy;
begin
fFileName := '';
fSection := '';
inherited;
end;
{$ENDIF ASM_VERSION}
{$IFNDEF _D5orHigher}
// Place here correct definition for WritePrivateProfileStruct
// and GetPrivateProfileStruct (a bug in Delphi2, Delphi3 and Delphi4)
//dufa
{function WritePrivateProfileStruct(lpszSection, lpszKey: PAnsiChar;
lpStruct: Pointer; uSizeStruct: UINT; szFile: PAnsiChar): BOOL; stdcall;
external kernel32 name 'WritePrivateProfileStructA';
function GetPrivateProfileStruct(lpszSection, lpszKey: PAnsiChar;
lpStruct: Pointer; uSizeStruct: UINT; szFile: PAnsiChar): BOOL; stdcall;
external kernel32 name 'GetPrivateProfileStructA';}
// + by Slava A. Gavrik:
////////////////////////////////////////////////////////////////////////////
//dufa
{function WritePrivateProfileSection(lpAppName, lpString,
lpFileName: PAnsiChar): BOOL; stdcall;
external kernel32 name 'WritePrivateProfileSectionA';
function GetPrivateProfileSection(lpAppName: PAnsiChar; lpReturnedString: PAnsiChar;
nSize: DWORD; lpFileName: PAnsiChar): DWORD; stdcall;
external kernel32 name 'GetPrivateProfileSectionA';
function GetPrivateProfileSectionNames(lpszReturnBuffer: PAnsiChar; nSize:
DWORD;
lpFileName: PAnsiChar): DWORD; stdcall;
external kernel32 name 'GetPrivateProfileSectionNamesA';}
////////////////////////////////////////////////////////////////////////////
{$ENDIF}
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;
begin
if fMode = ifmRead then
Result := GetPrivateProfileInt( PKOLChar( fSection ), PKOLChar( Key ),
Integer( Value ), PKOLChar( fFileName ) ) <> 0
else
begin
WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ),
PKOLChar( KOLString( Int2Str( Integer( Value ) ) ) ),
PKOLChar( fFileName ) );
Result := Value;
end;
end;
function TIniFile.ValueData(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}
procedure _FillStrList; //
asm
///////////////////////////////
OR EAX,0
JE @@EXIT //ERROR
// LEA EAX,[EAX-IniBufferSize]
// JE @@EXIT
// ... :)
// ...
//////////////////////////////
@@LOOP:
LEA EAX,[ESI+4]
CALL StrLen
MOV [ESI],EAX
LEA EDX,[ESI+4]
INC EAX
ADD ESI,EAX
MOV EAX,EDI
CALL TStrList.ADD
CMP byte ptr [ESI+4],0
JNE @@LOOP
@@EXIT:
POP EAX
CALL System.@FreeMem
POP ECX
POP EBX
POP EDI
POP ESI
end;
procedure TIniFile.GetSectionNames(Names: PStrList);
asm
PUSH ESI
PUSH EDI
PUSH EBX
PUSH ECX
MOV EBX,EAX
MOV EAX, IniBufferStrSize
MOV EDI,EDX
CALL System.@GetMem
MOV ESI,EAX
PUSH EAX
PUSH [EBX].fFileName
MOV EAX,IniBufferSize
PUSH EAX
LEA EAX,[ESI+4]
PUSH EAX
CALL GetPrivateProfileSectionNames
JMP _FillStrList
end;
procedure TIniFile.SectionData(Names: PStrList);
asm
PUSH ESI
PUSH EDI
PUSH EBX
PUSH ECX
MOV EBX,EAX
MOV EAX, IniBufferStrSize
MOV EDI,EDX
CALL System.@GetMem
MOV ESI,EAX
PUSH EAX
OR [EBX].fMode,0
JNE @@DOWrite
PUSH [EBX].fFileName
MOV EAX,IniBufferSize
PUSH EAX
LEA EAX,[ESI+4]
PUSH EAX
PUSH [EBX].fSection
CALL GetPrivateProfileSection
JMP _FillStrList
@@DOWrite:
PUSH EBX
PUSH ESI
PUSH EDX
PUSH EBP
MOV EDX,0
MOV EBP,[EDI].TStrList.fCount
MOV EBX,IniBufferSize-2 // #0#0
{ECM+++>} OR EBP,EBP // otherwise GetPChars when StrList.Count = 0 crashed
@@LOOP:
JE @@ENDLOOP
OR EBX,EBX
JE @@ENDLOOP
PUSH EDX
MOV EAX,EDI
CALL TStrList.GetPChars
PUSH EAX
CALL StrLen
POP EAX
XOR ECX,-1
MOV EDX,ESI
SUB EBX,ECX
JA @@L1
ADD ECX,EBX
XOR EBX,EBX
@@L1:
ADD ESI,ECX
CALL MOVE
@@L2:
POP EDX
INC EDX
DEC EBP
JMP @@LOOP
@@ENDLOOP:
MOV WORD PTR [ESI],0
POP EBP
POP EDX
POP ESI
POP EBX
///////////////////////////////////
MOV EAX,EBX //
CALL ClearSection
//////////////////////////////////
PUSH [EBX].fFileName
PUSH ESI
PUSH [EBX].fSection
CALL WritePrivateProfileSection
POP EAX
CALL System.@FreeMem
POP ECX
POP EBX
POP EDI
POP ESI
end;
{$ELSE ASM_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 ASM_VERSION}
/////////////////////////////////////////////////////////////////////////
// M E N U
/////////////////////////////////////////////////////////////////////////
{ -- Menu implementation -- }
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator;
begin
Result.fVirt := fVirt;
Result.Key := Key;
end;
{$ENDIF ASM_VERSION}
function GetAcceleratorText( const Accelerator: TMenuAccelerator ): KOLString;
var
KeyName: array[0..255] of KOLChar;
procedure AddKeyName( Code: Integer );
begin
Code := MapVirtualKey(Code, 0);
if Code = 0 then exit;
if GetKeyNameText(Code shl 16, KeyName, 256) > 0 then begin
if Result <> '' then
Result := Result + '+';
Result := Result + KeyName;
end;
end;
begin
Result := '';
with Accelerator do begin
if fVirt and FCONTROL <> 0 then
AddKeyName(VK_CONTROL);
if fVirt and FSHIFT <> 0 then
AddKeyName(VK_SHIFT);
if fVirt and FALT <> 0 then
AddKeyName(VK_ALT);
if fVirt and $20 <> 0 then
AddKeyName(VK_LWIN);
if fVirt and $40 <> 0 then
AddKeyName(VK_RWIN);
AddKeyName(Key);
end;
end;
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 ] in [ '+', '-' ]) THEN
BEGIN
Item.fIsCheckItem := TRUE;
Item.fChecked := S[ 1 ] = '+';
s := CopyEnd( s, 2 );
IF (s <> '') and (s[ 1 ] = '!') THEN
BEGIN
IF PrevItem <> nil THEN
BEGIN
if PrevItem.fRadioGroup <> 0 THEN
Item.fRadioGroup := PrevItem.fRadioGroup;
END
ELSE inc( Item.fRadioGroup );
s := CopyEnd( s, 2 );
END;
END;
IF s = '-' THEN
Item.fIsSeparator := TRUE
ELSE
BEGIN
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
begin
asm
nop
end;
Exit;
end;
end;
if (FControl <> nil) and (FControl.fMenu = FHandle) and (FHandle <> 0) then
begin
//if FControl.fHandle <> 0 then
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 {AK}
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.SetVisible( 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;
//FillChar( MII, Sizeof( MII ), #0 );
ZeroMemory( @MII, Sizeof( MII ) );
MII.cbSize := MenuStructSize;
MII.fMask := MIIM_CHECKMARKS or MIIM_ID or MIIM_STATE or
MIIM_TYPE;
MII.fType := Breaks[ FMenuBreak ];
MII.fState := FSavedState;
MII.wID := FId;
MII.dwItemData := DWORD( FData );
if not FIsSeparator then
begin
MII.fType := MII.fType or MFT_STRING;
MII.dwTypeData := PKOLChar( FCaption );
MII.cch := Length( FCaption )*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 {or MF_CHECKED} );
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 );
//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;
{$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 KOLString( S1 ) = {$IFDEF F_P}'' +{$ENDIF} '(' then
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.fIsPaintDC := True; // If Canvas will be destroyed, 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}
function NewCommandActionsObj_Packed( fromPack: PAnsiChar ): PCommandActionsObj;
asm
PUSH ESI
PUSH EDI
PUSH EAX
CALL NewCommandActionsObj
POP ESI
CMP ESI, 120
MOV [EAX].TCommandActionsObj.fIndexInActions, ESI
JB @@exit
PUSH EAX
LEA EDI, [EAX].TCommandActionsObj.aClick
XOR EAX, EAX
LODSB
MOV dword ptr [EDI + 76], EAX // Result.fIndexInActions := fromPack[0]
XOR ECX, ECX
MOV CL, 38
@@loop:
CMP byte ptr[ESI], 200
JB @@copy_word
JA @@clear_words
INC ESI
@@copy_word:
MOVSW
LOOP @@loop
JMP @@fin
@@clear_words:
LODSB
SUB AL, 200
SUB CL, AL
PUSH ECX
MOVZX ECX, AL
XOR EAX, EAX
REP STOSW
POP ECX
INC ECX
LOOP @@loop
@@fin:
POP EAX
@@exit:
POP EDI
POP ESI
end;
{$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 ASM_VERSION}
{$ENDIF COMMANDACTIONS_OBJ}
function DumpWindowed( c: PControl ): PControl;
var P: PByte;
i, j: Integer;
s, ss: String;
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}
function _NewTControl( AParent: PControl ): PControl;
begin
New( Result, CreateParented( AParent ) );
end;
function _NewWindowed( AParent: PControl; ControlClassName: PKOLChar;
Ctl3D: Boolean; ACommandActions: TCommandActionsParam ): PControl;
const Sz_TCommandActions = Sizeof(TCommandActions);
asm
PUSH EBX
PUSH ESI
PUSH EDI
MOV EDI, ACommandActions
MOV [ACommandActions], ECX // Ctl3D -> ACommandActions
PUSH EDX // ControlClassName
MOV ESI, EAX // ESI = AParent
CALL _NewTControl
XCHG EBX, EAX // EBX = Result
POP [EBX].TControl.fControlClassName
//INC [EBX].TControl.fWindowed // set in TControl.Init
{$IFDEF COMMANDACTIONS_OBJ}
MOV EAX, EDI
CMP EAX, 120
JB @@IdxActions_Loaded
MOVZX EAX, byte ptr[EDI]
@@IdxActions_Loaded:
PUSH EAX
MOV ECX, dword ptr [AllActions_Objs + EAX*4]
JECXZ @@create_new_action
XCHG EAX, ECX
PUSH EAX
CALL TObj.RefInc
POP EAX
JMP @@action_assign
@@create_new_action:
{$IFDEF PACK_COMMANDACTIONS}
MOV EAX, EDI
CALL NewCommandActionsObj_Packed
{$ELSE not PACK_COMMANDACTIONS}
CALL NewCommandActionsObj
TEST EDI, EDI
JZ @@no_actions
PUSH EAX
LEA EDX, [EAX].TCommandActionsObj.aClear
XCHG EAX, EDI
XOR ECX, ECX
MOV CL, Sz_TCommandActions
CALL Move
POP EAX
JMP @@action_assign
@@no_actions:
{$ENDIF not PACK_COMMANDACTIONS}
MOV [EAX].TCommandActionsObj.aClear, offset[ClearText]
@@action_assign:
POP EDX
MOV dword ptr [AllActions_Objs + EDX*4], EAX
MOV [EBX].TControl.fCommandActions, EAX
XCHG EDX, EAX
MOV EAX, EBX
CALL TControl.Add2AutoFree
{$ELSE}
TEST EDI, EDI
JZ @@no_actions2
PUSH ESI
MOV ESI, EDI
LEA EDI, [EBX].TControl.fCommandActions
XOR ECX, ECX
MOV CL, Sz_TCommandActions
REP MOVSB
POP ESI
{
LEA EDX, [EBX].TControl.fCommandActions
XCHG EAX, EDI
XOR ECX, ECX
MOV CL, Sz_TCommandActions
CALL Move
}
JMP @@actions_created
@@no_actions2:
MOV [EBX].TControl.fCommandActions.TCommandActions.aClear, offset[ClearText]
{$ENDIF}
@@actions_created:
TEST ESI, ESI
JZ @@no_parent
LEA ESI, [ESI].TControl.fTextColor
LEA EDI, [EBX].TControl.fTextColor
MOVSD // fTextColor
MOVSD // fColor
{$IFDEF SMALLEST_CODE}
{$IFDEF SMALLEST_CODE_PARENTFONT}
LODSD
XCHG EDX, EAX
XOR EAX, EAX
CALL TGraphicTool.Assign
STOSD // fFont
{$ELSE}
LODSD
XOR EAX, EAX
STOSD // fFont = nil
{$ENDIF}
{$ELSE}
LODSD
XCHG EDX, EAX
XOR EAX, EAX
PUSH EDX
CALL TGraphicTool.Assign
STOSD // fFont
POP EDX
XCHG ECX, EAX
JECXZ @@no_font
MOV [ECX].TGraphicTool.fParentGDITool, EDX
MOV [ECX].TGraphicTool.fOnChange.TMethod.Code, offset[TControl.FontChanged]
MOV [ECX].TGraphicTool.fOnChange.TMethod.Data, EBX
MOV EAX, EBX
MOV EDX, ECX
CALL TControl.FontChanged
{$IFDEF USE_AUTOFREE4CONTROLS}
MOV EAX, EBX
MOV EDX, [EBX].TControl.fFont
CALL TControl.Add2AutoFree
{$ENDIF}
@@no_font:
{$ENDIF}
{$IFDEF SMALLEST_CODE}
LODSD
XOR EAX, EAX
STOSD
{$ELSE}
LODSD
XCHG EDX, EAX
XOR EAX, EAX
PUSH EDX
CALL TGraphicTool.Assign
STOSD // fBrush
POP EDX
XCHG ECX, EAX
JECXZ @@no_brush
MOV [ECX].TGraphicTool.fParentGDITool, EDX
MOV [ECX].TGraphicTool.fOnChange.TMethod.Code, offset[TControl.BrushChanged]
MOV [ECX].TGraphicTool.fOnChange.TMethod.Data, EBX
MOV EAX, EBX
MOV EDX, ECX
CALL TControl.BrushChanged
{$IFDEF USE_AUTOFREE4CONTROLS}
MOV EAX, EBX
MOV EDX, [EBX].TControl.fBrush
CALL TControl.Add2AutoFree
{$ENDIF}
@@no_brush:
{$ENDIF}
MOVSB // fMargin
LODSD // skip fClientXXXXX
ADD EDI, 4
LODSB // fCtl3D_child
TEST AL, 2
JZ @@passed3D
MOV EDX, [ACommandActions] // DL <- Ctl3D !!!
AND AL, not 1
AND DL, 1
OR EAX, EDX
@@passed3D:
STOSB // fCtl3D_child
@@no_parent:
XCHG EAX, EBX
POP EDI
POP ESI
POP EBX
{$IFDEF DUMP_WINDOWED}
CALL DumpWindowed
{$ENDIF}
end;
{$ELSE ASM_VERSION} //Pascal
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.fOnChange := Result.FontChanged;
Result.FontChanged( Result.fFont );
end;
{$ENDIF WIN_GDI}
{$ENDIF SMALLEST_CODE}
Result.fColor := AParent.fColor;
{$IFDEF WIN_GDI}
Result.fBrush := Result.fBrush.Assign( AParent.fBrush );
if Result.fBrush <> nil then
begin
{$IFDEF USE_AUTOFREE4CONTROLS}
Result.Add2AutoFree( Result.fBrush );
{$ENDIF USE_AUTOFREE4CONTROLS}
Result.fBrush.fParentGDITool := AParent.fBrush;
Result.fBrush.fOnChange := Result.BrushChanged;
Result.BrushChanged( Result.fBrush );
end;
{$ENDIF WIN_GDI}
end;
{$IFDEF DUMP_WINDOWED}
DumpWindowed( Result );
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
VAR GTK_initialized: Boolean;
argc: Integer = 0;
PROCEDURE FixedChildSetPos( Ctl, Chld: PControl; x, y: Integer );
BEGIN
gtk_fixed_move( GTK_FIXED( Ctl.fClient ), Chld.fEventboxHandle, x, y );
END;
PROCEDURE LayoutChildSetPos( Ctl, Chld: PControl; x, y: Integer );
BEGIN
gtk_layout_move( GTK_LAYOUT( Ctl.fClient ), Chld.fEventboxHandle, x, y );
END;
PROCEDURE FixedChildPut( Ctl, Chld: PControl; x, y: Integer );
BEGIN
gtk_fixed_put( GTK_FIXED( Ctl.fClient ), Chld.fEventboxHandle, x, y );
END;
PROCEDURE LayoutChildPut( Ctl, Chld: PControl; x, y: Integer );
BEGIN
gtk_layout_put( GTK_LAYOUT( Ctl.fClient ), Chld.fEventboxHandle, x, y );
END;
FUNCTION FixedClientArea( Ctl: PControl ): PGtkWidget;
BEGIN
IF Ctl.fClient = nil THEN
BEGIN
Ctl.fClient := gtk_fixed_new;
gtk_container_set_border_width(GTK_CONTAINER(Ctl.fHandle), 0);
gtk_container_add( GTK_CONTAINER( Ctl.fHandle ), Ctl.fClient );
gtk_container_set_border_width(GTK_CONTAINER(Ctl.fClient), 0);
gtk_widget_show( Ctl.fClient );
Ctl.fChildPut := FixedChildPut;
Ctl.fChildSetPos := FixedChildSetPos;
END;
Result := Ctl.fClient;
END;
FUNCTION ClientAreaLayout( Ctl: PControl ): PGtkWidget;
BEGIN
IF Ctl.fClient = nil THEN
BEGIN
Ctl.fClient := gtk_layout_new( {hadjustment} nil, {vadjustment} nil );
Ctl.fChildPut := LayoutChildPut;
Ctl.fChildSetPos := LayoutChildSetPos;
END;
Result := Ctl.fClient;
END;
FUNCTION _NewWindowed( AParent: PControl; ControlClassName: 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.fOnChange := Result.FontChanged;
Result.FontChanged( Result.fFont );
END;
{$ENDIF WIN_GDI}
{$ENDIF SMALLEST_CODE}
Result.fColor := AParent.fColor;
{$IFDEF WIN_GDI}
Result.fBrush := Result.fBrush.Assign( AParent.fBrush );
IF Result.fBrush <> nil THEN
BEGIN
{$IFDEF USE_AUTOFREE4CONTROLS}
Result.Add2AutoFree( Result.fBrush );
{$ENDIF USE_AUTOFREE4CONTROLS}
Result.fBrush.fParentGDITool := AParent.fBrush;
Result.fBrush.fOnChange := Result.BrushChanged;
Result.BrushChanged( Result.fBrush );
END;
{$ENDIF WIN_GDI}
END;
Result.fGetClientArea := FixedClientArea;
END;
{$ENDIF GTK}
{$ENDIF _X_}
//===================== Form ========================//
{$IFDEF USE_CONSTRUCTORS}
function NewForm( 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 ASM_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 ASM_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 ASM_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 ASM_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}
function _NewControl( AParent: PControl; ControlClassName: PKOLChar;
Style: DWORD; Ctl3D: Boolean;
Actions: TCommandActionsParam ): PControl;
const szActions = sizeof(TCommandActions);
asm
PUSH EBX
PUSH EAX // push AParent
PUSH ECX // push Style
MOVZX ECX, [Ctl3D]
PUSH [Actions]
CALL _NewWindowed
XCHG EBX, EAX
{$IFDEF USE_FLAGS}
OR [EBX].TControl.fFlagsG3, (1 shl G3_IsControl)
{$ELSE}
INC [EBX].TControl.fIsControl
{$ENDIF}
POP EDX // pop Style
OR EDX, WS_CLIPSIBLINGS or WS_CLIPCHILDREN
INC [EBX].TControl.fVerticalAlign
MOV byte ptr [EBX].TControl.fLookTabKeys, $0F
TEST [EBX].TControl.fCtl3D_child, 1
JZ @@noCtl3D
AND EDX, not WS_BORDER
OR byte ptr [EBX].TControl.fExStyle + 1, WS_EX_CLIENTEDGE shr 8
@@noCtl3D:
MOV [EBX].TControl.fStyle, EDX
{$IFDEF USE_FLAGS}
{$ELSE}
TEST EDX, WS_VISIBLE
SETNZ AL
MOV [EBX].TControl.fVisible, AL
TEST EDX, WS_TABSTOP
SETNZ AL
MOV [EBX].TControl.fTabstop, AL
{$ENDIF USE_FLAGS}
POP ECX // pop AParent
JECXZ @@noParent
PUSH ESI
PUSH EDI
PUSH ECX
LEA ESI, [ECX].TControl.fMargin
LEA EDI, [EBX].TControl.fBoundsRect
LODSB
MOVSX EAX, AL
{$IFNDEF SMALLEST_CODE}
PUSH EAX
MOVSX ECX, byte ptr [ESI+2]
ADD EAX, ECX // AParent.fClientLeft
{$ENDIF}
STOSD // fBoundsRect.Left
{$IFNDEF SMALLEST_CODE}
POP EAX
PUSH EAX
MOVSX ECX, byte ptr [ESI+0]
ADD EAX, ECX // AParent.fClientTop
{$ENDIF}
STOSD // fBoundsRect.Top
{$IFNDEF SMALLEST_CODE}
XCHG EDX, EAX
POP EAX
{$ENDIF}
ADD EAX, 64
STOSD // fBoundsRect.Right
{$IFNDEF SMALLEST_CODE}
XCHG EAX, EDX
ADD EAX, 64
{$ENDIF}
STOSD // fBoundsRect.Bottom}
POP ECX
MOV EAX, [ECX].TControl.fCursor
STOSD
POP EDI
POP ESI
XCHG EAX, ECX
CALL TControl.ParentForm
XCHG ECX, EAX
JECXZ @@noParentForm
INC [ECX].TControl.fTabOrder
MOV DX, WORD PTR [ECX].TControl.fTabOrder
MOV WORD PTR [EBX].TControl.fTabOrder, DX
TEST [EBX].TControl.fStyle, WS_TABSTOP
JZ @@CurrentControl_set
CMP [ECX].TControl.DF.fCurrentControl, 0
JZ @@CurrentControl_set
MOV [ECX].TControl.DF.fCurrentControl, EBX
@@CurrentControl_set:
@@noParentForm:
@@noParent:
MOVZX EDX, [CtlIdCount]
INC [CtlIdCount]
MOV [EBX].TControl.fMenu, EDX
MOV EDX, offset[WndProcCtrl]
MOV EAX, EBX
CALL TControl.AttachProc
XCHG EAX, EBX
POP EBX
end;
{$ELSE ASM_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 );
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
FUNCTION getLabelCaption( L: PControl ): KOLString;
BEGIN
L.fCaption := gtk_label_get_text( Pointer( L.fCaptionHandle ) );
Result := L.fCaption;
END;
PROCEDURE setLabelCaption( L: PControl; const Value: KOLString );
BEGIN
L.fCaption := Value;
gtk_label_set_text( Pointer( L.fCaptionHandle ), 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}
//22{$IFDEF ASM_VERSION}
const ButtonClass: array[ 0..6 ] of KOLChar = ( 'B','U','T','T','O','N',#0 );
//22{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := _NewControl( AParent, 'BUTTON',
WS_VISIBLE or WS_CHILD or BS_NOTIFY or
BS_PUSHLIKE or WS_TABSTOP, False,
{$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 ASM_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 = ( {vaCenter} 0.5, {vaTop} 0, {vaBottom} 1 );
PROCEDURE ButtonSetTextAlign( Self_: PControl );
BEGIN
gtk_button_set_alignment( GTK_BUTTON( Self_.fHandle ), HorAlignments[ Self_.fTextAlign ],
VerAlignments[ Self_.fVerticalAlign ] );
END;
FUNCTION NewButton( AParent: PControl; const Caption: KOLString ): PControl;
BEGIN
Result := _NewControl( AParent, 'BUTTON',
WS_VISIBLE or WS_CHILD or BS_NOTIFY or
BS_PUSHLIKE or WS_TABSTOP, False,
gtk_button_new{_with_label}( {PChar( String( Caption ) )} ), FALSE );
//Result.Height := 22;
gtk_container_set_border_width( GTK_CONTAINER( Result.fHandle ), 0 );
Result.fCaptionHandle := gtk_label_new( 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 ASM_VERSION} //Pascal
function WndProc_DrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
: Boolean;
var DI: PDrawItemStruct;
Control: PControl;
begin
Result := FALSE;
if Msg.message = WM_DRAWITEM then
begin
DI := Pointer( Msg.lParam );
{$IFDEF USE_PROP}
Control := Pointer( GetProp( DI.hwndItem, ID_SELF ) );
{$ELSE}
Control := Pointer( GetWindowLong( DI.hwndItem, GWL_USERDATA ) );
{$ENDIF}
if Control <> nil then
begin
Rslt := Control.Perform( CN_DRAWITEM, Msg.wParam, Msg.lParam );
Result := TRUE;
end;
end;
end;
{$ENDIF ASM_VERSION}
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}
//JECXZ @@noOnBitBtnDraw
MOV EAX, [EDI].TControl.fCanvas
PUSH EAX
TEST EAX, EAX
JZ @@noCanvas
MOV EDX, [ESI].TDrawItemStruct.hDC
CALL TCanvas.SetHandle
@@noCanvas:
MOV EAX, [EDI].TControl.fOnBitBtnDraw.TMethod.Data
MOV EDX, EDI
PUSH EBX
XCHG ECX, EBX
CALL EBX
POP EBX
POP ECX // Canvas
PUSH EAX
JECXZ @@noCanvas2
XCHG EAX, ECX
XOR EDX, EDX
CALL TCanvas.SetHandle
@@noCanvas2:
POP EAX
TEST AL, AL
JNZ @@exit_draw
@@noOnBitBtnDraw:
TEST byte ptr [EDI].TControl.fBitBtnOptions, 2 //1 shl Ord(bboNoBorder)
JNZ @@noborder
TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_FOCUS
JZ @@noDefaultBorder
PUSH {BLACK_BRUSH} DKGRAY_BRUSH
CALL GetStockObject
LEA EDX, [ESI].TDrawItemStruct.rcItem
OR ECX, -1
PUSH ECX
PUSH ECX
PUSH EDX
PUSH EAX
PUSH EDX
PUSH [ESI].TDrawItemStruct.hDC
CALL Windows.FrameRect
CALL InflateRect
XOR ECX, ECX
JMP @@noFlat
@@noDefaultBorder:
{$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.fOnChange.TMethod.Code
{$IFDEF NIL_EVENTS}
JECXZ @@not_fixed
{$ENDIF}
MOV EAX, [EBX].TControl.fOnChange.TMethod.Data
MOV EDX, EBX
JMP ECX
@@pushed:
CALL @@fixed_proc
MOV EAX, EBX
CALL TControl.DoClick
@@invalidate:
XCHG EAX, EBX
CALL TControl.Invalidate
@@noWM_TIMER:
XOR EAX, EAX
POP EBX
@@not_fixed:
end;
{$ELSE ASM_VERSION} //Pascal
function WndProcBitBtn( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var DIS: PDrawItemStruct;
IsDown, IsDefault, IsDisabled: Boolean;
Flags: Integer;
X, Y, W, H, ImgW, ImgH, OutW, OutH, I, G, Bk, Blend: Integer;
TxRect, FocusRect: TRect;
OldFont: HFont;
OldTextColor: TColor;
CapText, CapTxtOrig: KOLString;
TextSz: TSize;
DC: HDC;
OldBmp: HBitmap;
Handled: Boolean;
begin
Result := False;
if (Msg.message = WM_LBUTTONDBLCLK) then
begin
Rslt := Self_.Perform( WM_LBUTTONDOWN, Msg.wParam, Msg.lParam );
Result := True;
Exit;
end;
if (Msg.message = CN_DRAWITEM) then
begin
Result := True;
Rslt := 1;
DIS := Pointer( Msg.lParam );
IsDown := (DIS.itemState and ODS_SELECTED <> 0) or
{$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
//{$IFDEF NIL_EVENTS}
if Assigned( Self_.DF.FBitBtnGetCaption ) then
//{$ENDIF}
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.fOnChange ) then
{$ENDIF}
Self_.EV.fOnChange( 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.fOnChange ) then
{$ENDIF}
Self_.EV.fOnChange( Self_ );
end;
Self_.DoClick;
SetTimer( Self_.fHandle, 1, Self_.DF.fRepeatInterval, nil );
Self_.Invalidate;
end;
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
function NewBitBtn( AParent: PControl; const Caption: KOLString;
Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap;
GlyphCount: Integer ): PControl;
var
B: TBitmapInfo;
W, H: Integer;
f: DWORD;
begin
f := WS_VISIBLE or WS_CHILD or BS_OWNERDRAW or WS_TABSTOP or BS_NOTIFY;
Result := _NewControl( AParent, 'BUTTON', f, False,
{$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 ASM_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 ASM_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 ASM_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}
procedure ClickRadio( Sender:PObj );
asm
PUSH EBX
MOV EBX, [EAX].TControl.fParent
TEST EBX, EBX
JZ @@exit
PUSH [EAX].TControl.fMenu
MOV EAX, EBX
MOV EDX, offset[RADIO_LAST]
CALL TControl.Get_Prop_Int
PUSH EAX
MOV EAX, EBX
MOV EDX, offset[RADIO_1ST]
CALL TControl.Get_Prop_Int
PUSH EAX
PUSH [EBX].TControl.fHandle
CALL CheckRadioButton
@@exit:
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
procedure ClickRadio( Sender:PObj );
var Self_:PControl;
begin
Self_ := PControl( Sender );
if Self_.FParent <> nil then
CheckRadioButton( Self_.fParent.fHandle,
Self_.fParent.PropInt[ @RADIO_1ST ],
Self_.fParent.PropInt[ @RADIO_LAST ],
Self_.fMenu );
end;
{$ENDIF ASM_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 ASM_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
AParent.PropInt[ @RADIO_LAST ] := Result.fMenu;
if AParent.PropInt[ @RADIO_1ST ] = 0 then
begin
AParent.PropInt[ @RADIO_1ST ] := Result.fMenu;
Result.SetRadioChecked;
end;
end;
{$IFDEF GRAPHCTL_XPSTYLES}
Attach_WM_THEMECHANGED(Result, XP_Themes_For_RadioBox);
{$ENDIF}
end;
{$ENDIF ASM_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}
const StaticClass: Array[0..6] of AnsiChar=('S','T','A','T','I','C',#0);
{$ENDIF}
{$IFDEF ASM_UNICODE}
function NewLabel( AParent: PControl; const Caption: KOLString ): PControl;
asm
PUSH EDX
PUSH 0
{$IFDEF PACK_COMMANDACTIONS}
PUSH [LabelActions_Packed]
{$ELSE}
PUSH offset[LabelActions]
{$ENDIF}
MOV ECX, WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY
MOV EDX, offset[StaticClass]
CALL _NewControl
//INC byte ptr [EAX].TControl.aAutoSzX
//INC byte ptr [EAX].TControl.aAutoSzY
MOV word ptr [EAX].TControl.aAutoSzX, $101
{$IFDEF USE_FLAGS}
OR [EAX].TControl.fFlagsG1, (1 shl G1_SizeRedraw) or (1 shl G1_IsStaticControl)
{$ELSE}
INC [EAX].TControl.fIsStaticControl
INC [EAX].TControl.fSizeRedraw
{$ENDIF}
MOV EDX, [EAX].TControl.fBoundsRect.Top
ADD EDX, 22
MOV [EAX].TControl.fBoundsRect.Bottom, EDX
POP EDX
PUSH EAX
CALL TControl.SetCaption
POP EAX
{$IFDEF GRAPHCTL_XPSTYLES}
PUSH EAX
MOV EDX, offset[XP_Themes_For_Label]
CALL Attach_WM_THEMECHANGED
POP EAX
{$ENDIF}
end;
{$ELSE ASM_VERSION} //Pascal
function NewLabel( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or
SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,
False, {$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 ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE LabelSetTextAlign( Self_: PControl );
BEGIN
gtk_misc_set_alignment( GTK_MISC( Self_.fCaptionHandle ), HorAlignments[ Self_.fTextAlign ],
VerAlignments[ Self_.fVerticalAlign ] );
END;
FUNCTION NewLabel( AParent: PControl; const Caption: KOLString ): PControl;
BEGIN
Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or
SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,
False, gtk_label_new( 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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_VERSION}
{$ENDIF GRAPHCTL_XPSTYLES}
{$IFDEF ASM_LOCAL}
function NewPaintbox( AParent: PControl ): PControl;
asm
XOR EDX, EDX
CALL NewLabel
ADD [EAX].TControl.fBoundsRect.Bottom, 64-22
end;
{$ELSE ASM_LOCAL} //Pascal
function NewPaintbox( AParent: PControl ): PControl;
begin
{$IFDEF GRAPHCTL_XPSTYLES}
Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD {or
SS_LEFTNOWORDWRAP or SS_NOPREFIX }or SS_NOTIFY,
False, {$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 ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
FUNCTION NewPaintbox( AParent: PControl ): PControl;
BEGIN
Result := NewLabel( AParent, '' );
Result.Height := 64;
END;
{$ENDIF GTK}
{$ENDIF _X_}
{$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 ASM_VERSION}
function WndProcImageShow( Sender: PControl; var Msg: TMsg;
var Rslt: Integer ): Boolean;
var PaintStruct: TPaintStruct;
IL: PImageList;
OldPaintDC: HDC;
begin
Result := FALSE;
if (Msg.message = WM_PAINT) or (Msg.message = WM_PRINT) then
begin
OldPaintDC := Sender.fPaintDC;
Sender.fPaintDC := Msg.wParam;
if Sender.fPaintDC = 0 then
Sender.fPaintDC := BeginPaint( Sender.fHandle, PaintStruct );
IL := Sender.ImageListNormal;
if IL <> nil then
begin
IL.Draw( Sender.fCurIndex, Sender.fPaintDC, Sender.fClientLeft, Sender.fClientTop );
Result := TRUE;
end;
if Msg.wParam = 0 then
EndPaint( Sender.fHandle, PaintStruct );
Sender.fPaintDC := OldPaintDC;
Rslt := 0;
//Result := True;
Exit;
end;
end;
function NewImageShow( AParent: PControl; AImgList: PImageList;
ImgIdx: Integer ): PControl;
var W, H: Integer;
begin
Result := NewLabel( AParent, '' );
Result.ImageListNormal := AImgList;
Result.AttachProc( WndProcImageShow );
Result.AttachProc( WndProcDoEraseBkgnd );
W := 32; H := 32;
if AImgList <> nil then
begin
W := AImgList.ImgWidth;
H := AImgList.ImgHeight;
end;
with Result.fBoundsRect do
begin
Right := Left + W;
Bottom := Top + H;
end;
end;
//===================== 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
//FillChar(SI, SizeOf(SI), #0);
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);
SB_THUMBTRACK: NewPos := SI.nTrackPos;
else
Exit;
end;}
Cmd := Msg.wParam and $0000FFFF;
case Cmd of
SB_BOTTOM: NewPos := SI.nMax;
SB_TOP: NewPos := SI.nMin;
SB_LINEDOWN: NewPos := SI.nPos + 1;
SB_LINEUP: NewPos := SI.nPos - 1;
SB_PAGEDOWN: NewPos := SI.nPos + Integer(SI.nPage);
SB_PAGEUP: NewPos := SI.nPos - Integer(SI.nPage);
{!ecm}
SB_THUMBPOSITION,SB_THUMBTRACK: NewPos := SI.nTrackPos;
SB_ENDSCROLL: NewPos := SI.nPos;
{/!ecm}
else
Exit;
end;
if (NewPos > SI.nMax - Integer(SI.nPage) + 1) then
NewPos := SI.nMax - Integer(SI.nPage) + 1;
if (NewPos < SI.nMin) then
NewPos := SI.nMin;
AllowChange := True;
{$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 begin
Result := FALSE;
Exit;
end;
end;
SI.cbSize := Sizeof( SI );
SI.fMask := SIF_RANGE or SIF_POS or SIF_PAGE or
{$IFDEF F_P}$10{$ELSE}SIF_TRACKPOS{$ENDIF};
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}
function NewGroupbox( AParent: PControl; const Caption: KOLString ): PControl;
asm
PUSH EDX
PUSH 0
{$IFDEF PACK_COMMANDACTIONS}
PUSH [ButtonActions_Packed]
{$ELSE}
PUSH offset[ButtonActions]
{$ENDIF}
MOV EDX, offset[ButtonClass]
MOV ECX, WS_VISIBLE or WS_CHILD or BS_GROUPBOX or WS_CLIPCHILDREN or WS_CLIPSIBLINGS
CALL _NewControl
OR [EAX].TControl.fExStyle, WS_EX_CONTROLPARENT
MOV EDX, [EAX].TControl.fBoundsRect.Left
ADD EDX, 100
MOV [EAX].TControl.fBoundsRect.Right, EDX
MOV EDX, [EAX].TControl.fBoundsRect.Top
ADD EDX, 100
MOV [EAX].TControl.fBoundsRect.Bottom, EDX
MOV byte ptr [EAX].TControl.fClientTop, 22
XOR EDX, EDX
{$IFDEF USE_FLAGS}
AND [EAX].TControl.fStyle.f2_Style, not(1 shl F2_Tabstop)
{$ELSE}
MOV [EAX].TControl.fTabstop, DL
{$ENDIF USE_FLAGS}
MOV DL, 2
ADD [EAX].TControl.fClientBottom, DL
ADD [EAX].TControl.fClientLeft, DL
ADD [EAX].TControl.fClientRight, DL
POP EDX
PUSH EAX
CALL TControl.SetCaption
POP EAX
PUSH EAX
{$IFDEF USE_FLAGS}
OR [EAX].TControl.fFlagsG5, 1 shl G5_IsGroupbox
{$ELSE}
INC [EAX].TControl.fIsGroupBox
{$ENDIF}
MOV EDX, offset[WndProcDoEraseBkgnd]
CALL TControl.AttachProc
POP EAX
{$IFDEF GRAPHCTL_XPSTYLES}
PUSH EAX
MOV EDX, offset[XP_Themes_For_GroupBox]
CALL Attach_WM_THEMECHANGED
POP EAX
{$ENDIF}
end;
{$ELSE ASM_VERSION} //Pascal
function NewGroupbox( AParent: PControl; const Caption: KOLString ): PControl;
begin
Result := _NewControl( AParent, 'BUTTON',
WS_CHILD
or WS_CLIPSIBLINGS
or WS_CLIPCHILDREN
or WS_VISIBLE
or BS_GROUPBOX,
FALSE, {$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 ASM_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}
function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
const CreateStyle = WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or
SS_NOPREFIX or SS_NOTIFY;
asm
{$IFDEF GRAPHCTL_XPSTYLES}
MOVZX EDX, EdgeStyle
PUSH EDX
{$ENDIF}
PUSH EDX
MOV EDX, offset[StaticClass]
MOV ECX, CreateStyle
PUSH 0
{$IFDEF PACK_COMMANDACTIONS}
PUSH [LabelActions_Packed]
{$ELSE}
PUSH offset[LabelActions]
{$ENDIF}
CALL _NewControl
//INC byte ptr [EAX].TControl.aAutoSzX
//INC byte ptr [EAX].TControl.aAutoSzY
MOV word ptr [EAX].TControl.aAutoSzX, $101
ADD [EAX].TControl.fBoundsRect.Right, 100-64
ADD [EAX].TControl.fBoundsRect.Bottom, 100-64
OR byte ptr [EAX].TControl.fExStyle+2, 1
POP ECX
CMP CL, 1
JG @@exit
JE @@sunken
OR byte ptr [EAX].TControl.fStyle+2, $40
{$IFDEF GRAPHCTL_XPSTYLES}
JMP @@visual
{$ELSE}
RET
{$ENDIF}
@@sunken:
OR byte ptr [EAX].TControl.fStyle+1, $10
@@exit:
{$IFDEF GRAPHCTL_XPSTYLES}
@@visual:
CMP AppTheming, TRUE
JNE @@es_none_
CMP CL, 1
JG @@es_none_
JE @@not_sunken
AND byte ptr [EAX].TControl.fStyle+2, $00
JNE @@es_none_
@@not_sunken:
AND byte ptr [EAX].TControl.fStyle+1, $00
@@es_none_:
POP EDX
PUSH EAX
CALL TControl.SetEdgeStyle
POP EAX
PUSH EAX
MOV EDX, offset[XP_Themes_For_Panel]
CALL Attach_WM_THEMECHANGED
POP EAX
{$ENDIF}
end;
{$ELSE ASM_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 ASM_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 );
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 ASM_VERSION} //Pascal
function WndProcSplitter( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var I: Integer;
Prev: PControl;
procedure FinDrag;
begin
KillTimer( Self_.fHandle, $7B );
{$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 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 ASM_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 ASM_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 ASM_VERSION}
{$ENDIF USE_CONSTRUCTORS}
//===================== 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, 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
if not 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;
end;
Result := FALSE;
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} );
{$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_.Parent = nil then Exit;
if {$IFDEF USE_FLAGS} G2_Destroying in Sender_.Parent.fFlagsG2
{$ELSE} Sender_.Parent.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 -- } 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;
function NewMDIChild( AParent: PControl; const ACaption: KOLString ): PControl;
var MDIClient: PControl;
MDIChildren: PList;
begin
Assert( (AParent <> nil) and (AParent.ParentForm <> nil) and
(AParent.ParentForm.MDIClient <> nil), 'Error creating MDI child' );
MDIClient := AParent.ParentForm.MDIClient;
Result := NewForm( MDIClient, ACaption );
{$IFDEF USE_FLAGS} include( Result.fFlagsG3, G3_IsMDIChild );
{$ELSE} Result.fIsMDIChild := TRUE; {$ENDIF}
Result.fMenu := CtlIdCount;
Inc( CtlIdCount );
MDIChildren := Pointer( MDIClient.PropInt[ MDI_CHLDRN ] );
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;
end;
//===================== 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 ASM_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 ASM_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 ASM_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 ASM_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: WideString;
RepeatCount: Integer;
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;
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 ASM_VERSION} //Pascal
function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl;
var Flags: Integer;
begin
Flags := MakeFlags( @Options, EditFlags );
if not(eoMultiline in Options) then
Flags := Flags and not(WS_HSCROLL or WS_VSCROLL);
Result := _NewControl( AParent, 'EDIT', WS_VISIBLE or WS_CHILD or WS_TABSTOP
or WS_BORDER or Flags, True,
{$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 ASM_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}
const ListBoxClass : Array[ 0..7 ] of AnsiChar = ( 'L','I','S','T','B','O','X',#0 );
function NewListbox( AParent: PControl; Options: TListOptions ): PControl;
asm
PUSH EAX
PUSH EDX
MOV EAX, ESP
MOV EDX, offset[ListFlags]
XOR ECX, ECX
MOV CL, 11
CALL MakeFlags
POP EDX
OR EAX, WS_VISIBLE or WS_CHILD or WS_TABSTOP or WS_BORDER or WS_VSCROLL or LBS_NOTIFY
XCHG ECX, EAX
POP EAX
PUSH 1
{$IFDEF PACK_COMMANDACTIONS}
PUSH [ListActions_Packed]
{$ELSE}
PUSH offset[ListActions]
{$ENDIF}
MOV EDX, offset[ListBoxClass]
CALL _NewControl
{$IFDEF PACK_COMMANDACTIONS}
MOV EDX, [EAX].TControl.fCommandActions
MOV [EDX].TCommandActionsObj.aClear, offset[ClearListbox]
{$ENDIF}
ADD [EAX].TControl.fBoundsRect.Right, 100
ADD [EAX].TControl.fBoundsRect.Bottom, 200-64
MOV [EAX].TControl.fColor, clWindow
MOV [EAX].TControl.fLookTabKeys, 3
end;
{$ELSE ASM_VERSION} //Pascal
function NewListbox( AParent: PControl; Options: TListOptions ): PControl;
var Flags: Integer;
begin
Flags := MakeFlags( @Options, ListFlags );
Result := _NewControl( AParent, 'LISTBOX', WS_VISIBLE or WS_CHILD or WS_TABSTOP
or WS_BORDER or WS_VSCROLL
or LBS_NOTIFY or Flags, True,
{$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 ASM_VERSION}
{$ENDIF USE_CONSTRUCTORS}
//===================== Combo box ========================//
{$IFNDEF USE_DROPDOWNCOUNT}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure ComboboxDropDown( Sender: PObj );
var
CB: PControl;
IC: Integer;
begin
CB := PControl( Sender );
IC := CB.Count;
if IC > 8 then IC := 8;
if IC < 1 then IC := 1;
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 ASM_VERSION}
{$ELSE newcode}
procedure ComboboxDropDown( Sender: PObj );
var
CB: PControl;
Count: Integer;
DropDownCount: Integer;
ItemHeight: Integer;
begin
CB := PControl(Sender);
Count := CB.Count;
DropDownCount := CB.DropDownCount;
//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}
procedure CreateComboboxWnd( Combo: PControl );
//const PrevProcStr: PAnsiChar = 'PREV_PROC'; //************ Remarked By M.Gerasimov
asm
PUSH EDI
PUSH EBX
XCHG EBX, EAX
PUSH GW_CHILD
PUSH [EBX].TControl.fHandle
@@getwindow:
CALL GetWindow
TEST EAX, EAX
JZ @@fin
PUSH offset[WndFuncCombo]
PUSH GWL_WNDPROC
PUSH EAX
XCHG EDI, EAX
CALL SetWindowLong
PUSH EAX
PUSH offset [ID_PREVPROC] //
PUSH EDI
CALL SetProp
@@2getnext:
PUSH GW_HWNDNEXT
PUSH EDI
JMP @@getwindow
@@fin: POP EBX
POP EDI
end;
{$ELSE ASM_VERSION} //Pascal
procedure CreateComboboxWnd( Combo: PControl );
var W : HWND;
PrevProc: DWORD;
begin
W := GetWindow( Combo.fHandle, GW_CHILD );
{if W <> 0 then
W := GetWindow( W, GW_HWNDNEXT );}
while W <> 0 do
begin
PrevProc :=
SetWindowLong( W, GWL_WNDPROC, Longint( @WndFuncCombo ) );
SetProp( W, ID_PREVPROC, PrevProc ); //
W := GetWindow( W, GW_HWNDNEXT );
end;
end;
{$ENDIF ASM_VERSION}
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 ASM_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 ASM_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 ASM_VERSION} //Pascal
function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var I: Integer;
C: PControl;
begin
if Msg.message = WM_SIZE then
begin
for I:= 0 to Self_.fChildren.fCount - 1 do
begin
C := Self_.fChildren.Items[ I ];
C.Perform( CM_SIZE, 0, 0 );
end;
end;
Result := False; // don't stop further processing
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function WndProcParentResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := False;
case Msg.message of
CM_SIZE:
begin
Self_.Perform( WM_SIZE, 0, 0 );
end;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}
procedure InitCommonControlCommonNotify( Ctrl: PControl );
asm
{$IFDEF USE_FLAGS}
OR [EAX].TControl.fFlagsG5, 1 shl G5_IsCommonCtl
{$ELSE}
MOV [EAX].TControl.fIsCommonControl, 1
{$ENDIF}
MOV ECX, [EAX].TControl.fParent
JECXZ @@fin
PUSH ECX
MOV EDX, offset[WndProcCommonNotify]
CALL TControl.AttachProc
POP EAX
MOV EDX, offset[WndProcNotify]
CALL TControl.AttachProc
@@fin:
end;
{$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 ASM_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 ASM_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 ASM_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 ASM_VERSION} //Pascal
function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;
const ProgressBarFlags: array[ TProgressbarOption ] of Integer =
(PBS_VERTICAL, PBS_SMOOTH );
begin
Result := NewProgressbar( AParent );
Result.fStyle.Value := Result.fStyle.Value or
DWORD( MakeFlags( @Options, ProgressBarFlags ) );
end;
{$ENDIF ASM_VERSION}
{$ENDIF USE_CONSTRUCTORS}
//===================== List view ========================//
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var NMhdr: PNMHdr;
Child: PControl;
begin
Result := False;
if Msg.message = WM_NOTIFY then
begin
NMhdr := Pointer( Msg.lParam );
{$IFDEF USE_PROP}
Child := Pointer( GetProp( NMhdr.hwndFrom, ID_SELF ) );
{$ELSE}
Child := Pointer( GetWindowLong( NMhdr.hwndFrom, GWL_USERDATA ) );
{$ENDIF}
if (Child <> nil)
and (Child <> Self_) //+ by Galkov, Jun-2009
then
begin
Msg.hwnd := Child.fHandle;
Result := EnumDynHandlers( Child, Msg, Rslt );
end;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var NMhdr: PNMHdr;
begin
Result := False;
if Msg.message = WM_NOTIFY then
begin
NMHdr := Pointer( Msg.lParam );
case 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 ASM_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 ASM_VERSION} //Pascal
procedure ApplyImageLists2Control( Sender: PControl );
var IL: PImageList;
begin
if Sender.fCommandActions.aSetImgList = 0 then Exit;
IL := Sender.ImageListNormal;
if IL <> nil then
Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_NORMAL, IL.Handle );
IL := Sender.ImageListSmall;
if IL <> nil then
Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_SMALL, IL.Handle );
IL := Sender.ImageListState;
if IL <> nil then
Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_STATE, IL.Handle );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_VERSION} //Pascal
function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;
ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;
begin
Result := _NewCommonControl( AParent, WC_LISTVIEW, ListViewStyles[ Style ] or
LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE or WS_TABSTOP or WS_CLIPCHILDREN,
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 ASM_VERSION}
{$ENDIF USE_CONSTRUCTORS}
//===================== Tree view ========================//
{$IFDEF ASM_UNICODE}
function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
asm //cmd //opd
CMP word ptr [EDX].TMsg.message, WM_NOTIFY
JNZ @@ret_false
PUSH EBX
XCHG EBX, EAX
MOV EDX, [EDX].TMsg.lParam
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [EBX].TControl.EV
LEA EAX, [EAX].TEvents.fOnTVBeginDrag
{$ELSE}
LEA EAX, [EBX].TControl.EV.fOnTVBeginDrag
{$ENDIF}
CMP word ptr [EDX].TNMTreeView.hdr.code, NM_RCLICK
JNE @@chk_TVN_BEGINDRAG
PUSH ECX
PUSH ECX
PUSH ESP
CALL GetCursorPos
MOV EAX, EBX
MOV EDX, ESP
MOV ECX, EDX
CALL TControl.Screen2Client
POP EAX
AND EAX, $FFFF
POP EDX
SHL EDX, 16
OR EAX, EDX
PUSH EAX
CALL GetShiftState
PUSH EAX
PUSH WM_RBUTTONUP
PUSH [EBX].TControl.fHandle
CALL PostMessage
JMP @@2fin_false1
@@chk_TVN_BEGINDRAG:
{$IFDEF UNICODE_CTRLS}
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINDRAGW
JZ @@event_drag
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINRDRAGW
JZ @@event_drag
{$ENDIF UNICODE_CTRLS}
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINDRAG
JZ @@event_drag
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINRDRAG
JNZ @@chk_BEGINLABELEDIT
@@event_drag:
MOV EDX, [EDX].TNMTreeView.itemNew.hItem
@@event_call:
MOV ECX, [EAX].TMethod.Code
JECXZ @@2fin_false1
MOV EAX, [EAX].TMethod.Data
XCHG EBX, ECX
XCHG EDX, ECX
CALL EBX
@@2fin_false1: JMP @@fin_false
@@chk_BEGINLABELEDIT:
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [EBX].TControl.EV
LEA EAX, [EAX].TEvents.FOnTVBeginEdit
{$ELSE}
LEA EAX, [EBX].TControl.EV.fOnTVBeginEdit
{$ENDIF}
{$IFDEF UNICODE_CTRLS}
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINLABELEDITW
JZ @@beginlabeledit
{$ENDIF UNICODE_CTRLS}
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINLABELEDIT
JNZ @@chk_ITEMEXPANDED //@@chk_DELETEITEM
@@beginlabeledit:
{$IFDEF USE_FLAGS}
TEST [EBX].TControl.fFlagsG6, 1 shl G6_Dragging
{$ELSE}
CMP [EBX].TControl.fDragging, 0
{$ENDIF}
JZ @@allow_LABELEDIT
XOR EAX, EAX
INC EAX
MOV [ECX], EAX
JMP @@ret_true
@@allow_LABELEDIT:
PUSH ECX // @Rslt
MOV ECX, [EAX].TMethod.Code
JECXZ @@2fin_false1
PUSH EBX
XCHG EBX, ECX
MOV EDX, [EDX].TTVDispInfo.item.hItem
XCHG EDX, ECX
MOV EAX, [EAX].TMethod.Data
CALL EBX
TEST AL, AL
SETZ AL // Rslt := not event result;
POP EBX
JMP @@ret_EAX
@@call_EBX:
CALL EBX
@@2fin_false:
JMP @@fin_false
@@chk_ITEMEXPANDED:
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [EBX].TControl.EV
LEA EAX, [EAX].TEvents.fOnTVExpanded
{$ELSE}
LEA EAX, [EBX].TControl.EV.fOnTVExpanded
{$ENDIF}
{$IFDEF UNICODE_CTRLS}
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDEDW
JZ @@itemexpanded
{$ENDIF UNICODE_CTRLS}
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDED
JNZ @@chk_SELCHANGING
@@itemexpanded:
MOV ECX, [EAX].TMethod.Code
JECXZ @@2fin_false
CMP [EDX].TNMTreeView.action, TVE_EXPAND
PUSH ECX
SETZ CL
XCHG ECX, [ESP]
JMP @@event_drag
@@chk_SELCHANGING:
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_SELCHANGING
JNE @@chk_ITEMEXPANDING
XCHG EAX, ECX
{$IFDEF EVENTS_DYNAMIC}
MOV ECX, [EBX].TControl.EV
MOV ECX, [ECX].TEvents.fOnTVSelChanging.TMethod.Code
{$ELSE}
MOV ECX, [EBX].TControl.EV.fOnTVSelChanging.TMethod.Code
{$ENDIF}
@@2fin_false2:
JECXZ @@2fin_false
PUSH EAX //@Rslt
PUSH [EDX].TNMTreeView.itemNew.hItem
XCHG ECX, EBX //EBX=OnTVSelChanging.Code ECX=Sender
XCHG ECX, EDX //EDX=Sender ECX=Msg
MOV ECX, [ECX].TNMTreeView.itemOld.hItem
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [EDX].TControl.EV
MOV EAX, [EAX].TEvents.fOnTVSelChanging.TMethod.Data
{$ELSE}
MOV EAX, [EDX].TControl.EV.fOnTVSelChanging.TMethod.Data
{$ENDIF}
CALL EBX
XOR AL, 1
MOVZX EAX, AL
JMP @@ret_EAX
@@chk_ITEMEXPANDING:
{$IFDEF UNICODE_CTRLS}
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDINGW
JZ @@itemexpanding
{$ENDIF UNICODE_CTRLS}
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDING
JNE @@chk_ENDLABELEDIT
@@itemexpanding:
XCHG EAX, ECX
{$IFDEF EVENTS_DYNAMIC}
MOV ECX, [EBX].TControl.EV
MOV ECX, [ECX].TEvents.fOnTVExpanding.TMethod.Code
{$ELSE}
MOV ECX, [EBX].TControl.EV.fOnTVExpanding.TMethod.Code
{$ENDIF}
JECXZ @@2fin_false2
PUSH EAX // @Rslt
CMP [EDX].TNMTreeView.action, TVE_EXPAND
PUSH ECX
SETZ CL
XCHG ECX, [ESP]
XCHG ECX, EBX //EBX=OnTVExpanding.Code ECX=Seneder
XCHG EDX, ECX //ECX=Msg EDX=Sender
MOV ECX, [ECX].TNMTreeView.itemNew.hItem //ECX=Item
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [EDX].TControl.EV
MOV EAX, [EAX].TEvents.fOnTVExpanding.TMethod.Data
{$ELSE}
MOV EAX, [EDX].TControl.EV.fOnTVExpanding.TMethod.Data //EAX=object
{$ENDIF}
@@111:
CALL EBX
@@ret_EAX:
POP EDX //EDX=@Rslt
MOVZX EAX, AL
NEG EAX
MOV [EDX], EAX
@@ret_true:
MOV AL, 1
POP EBX
RET
@@chk_ENDLABELEDIT:
{$IFDEF UNICODE_CTRLS}
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_ENDLABELEDITW
JZ @@endlabeledit
{$ENDIF UNICODE_CTRLS}
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_ENDLABELEDIT
JNZ @@chk_SELCHANGED
@@endlabeledit:
XCHG EAX, ECX
{$IFDEF EVENTS_DYNAMIC}
MOV ECX, [EBX].TControl.EV
MOV ECX, [ECX].TEvents.fOnTVEndEdit.TMethod.Code
{$ELSE}
MOV ECX, [EBX].TControl.EV.fOnTVEndEdit.TMethod.Code
{$ENDIF}
JECXZ @@ret_1
PUSH EAX
PUSH EBX
PUSH 0
XCHG EDX, EBX
MOV EAX, [EBX].TTVDispInfo.item.pszText
PUSH EDX
PUSH ECX
XCHG EAX, EDX
{$IFDEF UNICODE_CTRLS}
CMP [EBX].TNMTreeView.hdr.code, TVN_ENDLABELEDITW
JNZ @@endlabeleditA
CALL TControl.TVGetItemTextW
JMP @@NewTxt_ready
@@endlabeleditA:
{$ENDIF UNICODE_CTRLS}
TEST EDX, EDX
JNZ @@prepare_NewTxt
// NewTxt := [EDX].TControl.TVItemText[ hItem ]
LEA ECX, [ESP + 8]
MOV EDX, [EBX].TTVDispInfo.item.hItem
CALL TControl.TVGetItemText
JMP @@NewTxt_ready
@@prepare_NewTxt:
LEA EAX, [ESP+8]
{$IFDEF _D2009orHigher}
PUSH ECX
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
{$IFDEF _D2009orHigher}
POP ECX
{$ENDIF}
@@NewTxt_ready:
POP ECX
POP EDX
POP EAX
PUSH EAX
PUSH EAX
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [EDX].TControl.EV
MOV EAX, [EAX].TEvents.fOnTVEndEdit.TMethod.Data
{$ELSE}
MOV EAX, [EDX].TControl.EV.fOnTVEndEdit.TMethod.Data
{$ENDIF}
MOV EBX, [EBX].TTVDispInfo.item.hItem
XCHG ECX, EBX
CALL EBX
XCHG EBX, EAX
CALL RemoveStr
XCHG EAX, EBX
POP EBX
JMP @@ret_EAX
@@ret_1:
INC ECX
MOV [EAX], ECX
JMP @@ret_true
@@chk_SELCHANGED:
{$IFDEF UNICODE_CTRLS}
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_SELCHANGEDW
JZ @@selchanged
{$ENDIF UNICODE_CTRLS}
CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_SELCHANGED
JNZ @@fin_false
@@selchanged:
XCHG EAX, EBX
CALL TControl.DoSelChange
@@fin_false:
POP EBX
@@ret_false:
XOR EAX, EAX
end;
{$ELSE ASM_VERSION} //Pascal
function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var NM: PNMTreeView;
DI: PTVDispInfo;
P: TPoint;
S: KOL_String;
begin
if Msg.message = WM_NOTIFY then
begin
NM := Pointer( Msg.lParam );
case NM.hdr.code of
NM_RCLICK:
begin
GetCursorPos( P );
P := Self_.Screen2Client( P );
PostMessage( Self_.fHandle, WM_RBUTTONUP, MK_RBUTTON or GetShiftState,
(P.x and $FFFF) or (P.y shl 16) );
end;
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 ASM_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 ASM_VERSION} //Pascal
function NewTreeView( AParent: PControl; Options: TTreeViewOptions;
ImgListNormal, ImgListState: PImageList ): PControl;
var Flags: Integer;
begin
Flags := MakeFlags( @Options, TreeViewFlags );
Result := _NewCommonControl( AParent, WC_TREEVIEW, Flags or WS_VISIBLE or
WS_CHILD or WS_TABSTOP, 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 ASM_VERSION}
{$ENDIF USE_CONSTRUCTORS}
//===================== Tab Control ========================//
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Hdr: PNMHdr;
A: Integer;
R: TRect;
WasActive: Boolean;
{$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 ASM_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}
function NewTabControl( AParent: PControl; const Tabs: array of PKOLChar; Options: TTabControlOptions;
ImgList: PImageList; ImgList1stIdx: Integer ): PControl;
const lenf=high(TabControlFlags); //+++
asm //cmd //opd
PUSH EBX
PUSH ESI
PUSH EDI
XCHG EBX, EAX
PUSH EDX
PUSH ECX
LEA EAX, [Options]
MOV EDX, offset[TabControlFlags]
XOR ECX, ECX
MOV CL, lenf
CALL MakeFlags
TEST byte ptr [Options], 4
JZ @@0
OR EAX, WS_TABSTOP or TCS_FOCUSONBUTTONDOWN
@@0: OR EAX, WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE
XCHG ECX, EAX
XCHG EAX, EBX
MOV EDX, offset[WC_TABCONTROL]
PUSH 1
{$IFDEF PACK_COMMANDACTIONS}
PUSH [TabControlActions_Packed]
{$ELSE}
PUSH offset[TabControlActions]
{$ENDIF}
CALL _NewCommonControl
MOV EBX, EAX
TEST [Options], 2 shl (tcoBorder - 1)
JNZ @@borderfixed
AND [EBX].TControl.fExStyle, not WS_EX_CLIENTEDGE
@@borderfixed:
MOV EDX, offset[WndProcTabControl]
CALL TControl.AttachProc
ADD [EBX].TControl.fBoundsRect.Right, 100-64
ADD [EBX].TControl.fBoundsRect.Bottom, 100-64
MOV ECX, [ImgList]
JECXZ @@2
XCHG EAX, ECX
CALL TImageList.GetHandle
PUSH EAX
PUSH 0
PUSH TCM_SETIMAGELIST
PUSH EBX
CALL TControl.Perform
@@2:
POP EDI // EDI = High(Tabs)
POP ESI // ESI = Tabs
XOR EDX, EDX // EDX := 0 (=I)
MOV EAX, [ImgList1stIdx] //(=II)
@@loop:
CMP EDX, EDI
JG @@e_loop
PUSH EAX
PUSH EDX
PUSH EAX
LODSD
XCHG ECX, EAX
MOV EAX, EBX
CALL TControl.TC_Insert
POP EDX
POP EAX
INC EAX
INC EDX
JMP @@loop
@@e_loop:
MOV byte ptr [EBX].TControl.fLookTabKeys, 1
XCHG EAX, EBX
POP EDI
POP ESI
POP EBX
end;
{$ELSE ASM_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 ASM_VERSION}
{$IFNDEF OLD_ALIGN}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$ENDIF}
{$ENDIF USE_CONSTRUCTORS}
//===================== Tool bar ========================//
{$IFDEF ASM_noVERSION} //TTN_NEEDTEXTW ASM_TLIST!
function WndProcToolbarCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
asm
CMP word ptr [EDX].TMsg.message, WM_WINDOWPOSCHANGED
JNE @@chk_CM_COMMAND
MOV dword ptr [ECX], 0 // Rslt := 0
MOV ECX, [EAX].TControl.fOnResize.TMethod.Code
JECXZ @@ret_true
XCHG EDX, EAX // Sender := Self_
MOV EAX, [EDX].TControl.fOnResize.TMethod.Data
CALL ECX // Self_.fOnResize
XOR EAX, EAX // Result := FALSE
RET
@@chk_CM_COMMAND:
CMP word ptr [EDX].TMsg.message, CM_COMMAND
JNE @@chk_WM_NOTIFY
MOVZX ECX, word ptr [EDX].TMsg.wParam
MOV [EAX].TControl.fCurItem, ECX
PUSH EAX
PUSH 0
PUSH ECX
PUSH TB_COMMANDTOINDEX
PUSH EAX
CALL TControl.Perform
PUSH EAX
PUSH VK_RETURN
CALL GetKeyState
TEST EAX, EAX
POP ECX
POP EAX
MOV [EAX].TControl.fCurIndex, ECX
{$IFDEF USE_FLAGS}
SETL DL
SHL DL, G6_RightClick
AND [EAX].TControl.fFlagsG6, not(1 shl G6_RightClick)
OR [EAX].TControl.fFlagsG6, DL
{$ELSE}
SETL DL
MOV [EAX].TControl.fRightClick, DL
{$ENDIF}
@@ret_false:
XOR EAX, EAX
RET
@@chk_WM_NOTIFY:
CMP word ptr [EDX].TMsg.message, WM_NOTIFY
JNE @@ret_false
MOV EDX, [EDX].TMsg.lParam
MOV ECX, [EDX].TTooltipText.hdr.code
CMP ECX, TTN_NEEDTEXT
JNE @@chk_NM_RCLICK
PUSH EAX
PUSH EDX
MOV EDX, [EDX].TTooltipText.hdr.idFrom
MOV ECX, [EAX].TControl.DF.fTBttCmd
OR EAX, -1
JECXZ @@idxReady
XCHG EAX, ECX
CALL TList.IndexOf
@@idxReady: // EAX = -1 or index of button tooltip
TEST EAX, EAX
POP EDX
LEA EDX, [EDX].TTooltipText.szText
MOV byte ptr [EDX], 0
POP ECX
JL @@ret_true
MOV ECX, [ECX].TControl.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
CALL StrLCopy
JMP @@ret_true
@@chk_NM_RCLICK:
CMP ECX, NM_RCLICK
JNE @@chk_NM_CLICK
OR [EAX].TControl.fRightClick, 1
MOV ECX, [EDX].TNMMouse.dwItemSpec
MOV [EAX].TControl.fCurItem, -1
PUSH EAX
PUSH 0
PUSH ECX
PUSH TB_COMMANDTOINDEX
PUSH EAX
CALL TControl.Perform
POP EDX
MOV [EDX].TControl.fCurIndex, EAX
XOR EAX, EAX
RET
@@chk_NM_CLICK:
CMP ECX, NM_CLICK
JNE @@chk_TBN_DROPDOWN
MOV [EAX].TControl.fRightClick, 0
OR [EAX].TControl.fCurItem, -1
OR [EAX].TControl.fCurIndex, -1
CMP [EDX].TTBNotify.iItem, -1
SETNZ AL
RET
@@chk_TBN_DROPDOWN:
CMP ECX, TBN_DROPDOWN
JNE @@ret_false
MOV EDX, [EDX].TTBNotify.iItem
MOV [EAX].TControl.fCurItem, EDX
PUSH EAX
CALL TControl.TBItem2Index
POP EDX
MOV [EDX].TControl.fCurIndex, EAX
MOV ECX, [EDX].TControl.fOnDropDown.TMethod.Code
JECXZ @@ret_z
MOV EAX, [EDX].TControl.fOnDropDown.TMethod.Data
CALL ECX
@@ret_z:
XOR EAX, EAX
end;
{$ELSE ASM_VERSION} //Pascal
function WndProcToolbarCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
var lpttt: PTooltipText;
idBtn, Idx: Integer;
var Notify: PTBNotify;
Mouse: PNMMouse;
{$IFNDEF _FPC}
{$IFNDEF _D2}
var WStr: WideString;
{$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 ) );
//FillChar( lpttt.szText[ 0 ], 160, #0 );
ZeroMemory( @lpttt.szText[ 0 ], 160 );
if Idx >= 0 then
begin
WStr := WideString(Self_.DF.fTBttTxt.Items[ Idx ]);
if WStr <> '' then
Move( Wstr[ 1 ], lpttt.szText, Min( 158, (Length( WStr ) + 1) * 2 ) );
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 - if it 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 ASM_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}
function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
Bitmap: HBitmap; const Buttons: array of PKOLChar;
const BtnImgIdxArray: array of Integer ) : PControl;
const szTBButton = Sizeof( TTBButton );
Option3DBorder = 1 shl Ord( tbo3DBorder );
asm //cmd //opd
PUSH EDI
MOVZX EDX, DL
PUSH EDX // Align
PUSH EAX // AParent
XOR EAX, EAX
TEST CL, Option3DBorder
SETNZ AL
PUSH EAX
PUSH ECX // Options
MOV AL, ICC_BAR_CLASSES
CALL DoInitCommonControls
MOV EAX, ESP
MOV EDX, offset[ToolbarOptions]
XOR ECX, ECX
MOV CL, 6
CALL MakeFlags
POP EDX
{$IFDEF COMMANDACTIONS_OBJ}
PUSH TOOLBAR_ACTIONS
{$ELSE}
PUSH 0 //: actions : = nil
{$ENDIF}
XCHG ECX, EAX // ECX = MakeFlags(...)
MOV EDI, ECX
MOV EAX, [ESP+8] // EAX = AParent
MOV EDX, [ESP+12] // EDX = Align
OR ECX, [EDX*4+offset ToolbarAligns]
OR ECX, WS_CHILD or WS_VISIBLE or TBSTYLE_TOOLTIPS
MOV EDX, offset[ TOOLBARCLASSNAME ]
CALL _NewCommonControl
{$IFDEF COMMANDACTIONS_OBJ}
MOV EDX, [EAX].TControl.fCommandActions
MOV [EDX].TCommandActionsObj.aClear, offset[ClearToolbar]
MOV [EDX].TCommandActionsObj.aGetCount, TB_BUTTONCOUNT
{$ELSE}
MOV [EAX].TControl.fCommandActions.aClear, offset[ClearToolbar]
MOV [EAX].TControl.fCommandActions.aGetCount, TB_BUTTONCOUNT
{$ENDIF}
{$IFDEF USE_FLAGS}
OR [EAX].TControl.fFlagsG5, 1 shl G5_IsButton
{$ELSE}
INC [EAX].TControl.fIsButton
{$ENDIF}
POP EDX // pop AParent
POP EDX // EDX = Align
PUSH EDX
TEST EDX, EDX
JE @@zero_bounds
ADD [EAX].TControl.fBoundsRect.Bottom, 26-64
ADD [EAX].TControl.fBoundsRect.Right, 1000-64
JMP @@bounds_ready
@@zero_bounds:
MOV [EAX].TControl.fBoundsRect.Left, EDX
MOV [EAX].TControl.fBoundsRect.Top, EDX
MOV [EAX].TControl.fBoundsRect.Right, EDX
MOV [EAX].TControl.fBoundsRect.Bottom, EDX
@@bounds_ready:
PUSH EBX
PUSH ESI
XCHG EBX, EAX
MOV ESI, offset[TControl.Perform]
PUSH 0
PUSH 0
PUSH TB_GETEXTENDEDSTYLE
PUSH EBX
CALL ESI
OR EAX, TBSTYLE_EX_DRAWDDARROWS
PUSH EAX
PUSH 0
PUSH TB_SETEXTENDEDSTYLE
PUSH EBX
CALL ESI
MOV EDX, offset[WndProcToolbarCtrl]
MOV EAX, EBX
CALL TControl.AttachProc
MOV EDX, offset[WndProcDoEraseBkgnd]
MOV EAX, EBX
CALL TControl.AttachProc
PUSH 0
PUSH szTBButton
PUSH TB_BUTTONSTRUCTSIZE
PUSH EBX
CALL ESI
PUSH 0
MOVSX EAX, [EBX].TControl.fMargin
PUSH EAX
PUSH TB_SETINDENT
PUSH EBX
CALL ESI
MOV EAX, [ESP+8] // Align
{$IFDEF PARANOIA} DB $2C, 1 {$ELSE} SUB AL, 1 {$ENDIF}
JL @@bounds_correct
JE @@corr_right
{$IFDEF PARANOIA} DB $2C, 2 {$ELSE} SUB AL, 2 {$ENDIF}
JNE @@corr_bottom
@@corr_right:
MOV EDX, [EBX].TControl.fBoundsRect.Left
ADD EDX, 24
MOV [EBX].TControl.fBoundsRect.Right, EDX
JMP @@bounds_correct
@@corr_bottom:
MOV EDX, [EBX].TControl.fBoundsRect.Top
ADD EDX, 22
MOV [EBX].TControl.fBoundsrect.Bottom, EDX
@@bounds_correct:
{$IFnDEF TBBUTTONS_DFLT_NOAUTOSIZE}
MOV byte ptr [EBX].TControl.DF.fDefaultTBBtnStyle, TBSTYLE_AUTOSIZE
{$ENDIF}
MOV EDX, [Bitmap]
TEST EDX, EDX
JZ @@bitmap_added
MOV EAX, EBX
CALL TControl.TBAddBitmap
@@bitmap_added:
PUSH dword ptr [BtnImgIdxArray]
PUSH dword ptr [BtnImgIdxArray-4]
MOV ECX, [Buttons-4]
MOV EDX, [Buttons]
MOV EAX, EBX
CALL TControl.TBAddButtons
PUSH 0
PUSH 0
PUSH WM_SIZE
PUSH EBX
CALL ESI
// ---
{+|ecm|}
// ---
MOV EDX,EDI
OR EDX,[EBX].TControl.FStyle
MOV EAX,EBX
CALL TControl.SetStyle
// ---
{/+|ecm|}
// ---
XCHG EAX, EBX
POP ESI
POP EBX
POP EDX
POP EDI
end;
{$ELSE ASM_VERSION} //Pascal
function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
Bitmap: HBitmap; const Buttons: array of PKOLChar;
const BtnImgIdxArray: array of Integer ) : PControl;
var Flags: DWORD;
begin
if 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 ASM_VERSION}
{$ENDIF USE_CONSTRUCTORS}
//================== DateTimePicker =====================//
function WndProcDateTimePickerNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var NMhdr: PNMHdr;
D: TDateTime;
AllowChg: Boolean;
NMDTString: PNMDateTimeString;
begin
Result := False;
if Msg.message = WM_NOTIFY then
begin
NMHdr := Pointer( Msg.lParam );
CASE 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.fOnChange ) then
{$ENDIF}
Self_.EV.fOnChange( 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;
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 ASM_VERSION} //Pascal
function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Link: PENLink;
Range: TextRangeA;
Buffer: Array[ 0..1023 ] of 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[0]; //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[ 0 ];
{$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 ASM_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 ASM_VERSION} //Pascal
function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var NMhdr: PNMHdr;
begin
Result := False;
if Msg.message = WM_NOTIFY then
begin
NMHdr := Pointer( Msg.lParam );
case NMHdr.code of
EN_SELCHANGE:
begin
Self_.DoSelChange;
if {$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 ASM_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 ASM_VERSION} //Pascal
function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;
var Flags, I, d, Last, SaveErrMode: Integer;
label search_richedit;
begin
{$IFDEF INPACKAGE}
Log( '->NewRichEdit1' );
TRY
{$ENDIF INPACKAGE}
if FRichEditModule = 0 then
begin
search_richedit:
I := RichEditIdx;
Last := High( RichEditLibnames );
d := 1;
if RichEditIdx > 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 ASM_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 ASM_VERSION} //Pascal
function OleInit: Boolean;
begin
if OleInitCount = 0 then
begin
Result := False;
if OleInitialize( nil ) <> 0 then Exit;
end;
Inc( OleInitCount );
Result := True;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure OleUnInit;
begin
if OleInitCount > 0 then
begin
Dec( OleInitCount );
if OleInitCount = 0 then
OleUninitialize;
end;
end;
{$ENDIF ASM_VERSION}
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}
const RichEdit50W: array[0..11] of AnsiChar = ('R','i','c','h','E','d','i','t','5','0','W',#0 );
function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;
const deltaChr = 24; // sizeof( TCharFormat2 ) - sizeof( RichEdit.TCharFormat );
deltaPar = sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat );
asm
PUSHAD
CALL OleInit
TEST EAX, EAX
POPAD
JZ @@new1
MOV [RichEditIdx], 0
CALL NewRichEdit1
MOV byte ptr [EAX].TControl.DF.fCharFmtDeltaSz, deltaChr
MOV byte ptr [EAX].TControl.DF.fParaFmtDeltaSz, deltaPar
RET
@@new1: CALL NewRichEdit1
end;
{$ELSE ASM_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 ASM_VERSION}
{$ENDIF USE_CONSTRUCTORS}
{$ENDIF NOT_USE_RICHEDIT}
//=====================================================================//
{$ENDIF WIN_GDI}
{ TControl }
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.InitParented( AParent: PControl );
begin
Init;
if AParent <> nil then
fColor := AParent.fColor;
Parent := AParent;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE TControl.InitParented( AParent: PControl; widget: PGtkWidget;
need_eventbox: Boolean );
BEGIN
Init;
fHandle := widget;
fCaptionHandle := fHandle;
fEventboxHandle := fHandle;
IF need_eventbox THEN
BEGIN
fEventboxHandle := gtk_event_box_new();
gtk_widget_set_events( fEventboxHandle, GDK_ALL_EVENTS_MASK );
//gtk_container_add( GTK_CONTAINER( AParent.fHandle ), fEventboxHandle );
gtk_widget_show( fEventboxHandle );
gtk_container_add( GTK_CONTAINER( fEventboxHandle ), fHandle );
END;
g_object_set_data( G_OBJECT( fEventboxHandle ), ID_SELF, @ Self );
if AParent <> nil then
fColor := AParent.fColor;
Parent := AParent;
END;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
procedure TControl.InitOrthaned( AParentWnd: HWnd );
begin
Init;
FParentWnd := AParentWnd;
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
destructor TControl.Destroy;
var I: Integer;
F: PControl;
Ico: HIcon;
begin
{$IFDEF USE_CUSTOMEXTENSIONS}
{$I CUSTOM_TCONTROL_DESTROY.INC}
{$ENDIF}
{$IFDEF USE_MHTOOLTIP}
{$DEFINE destroy}
{$I KOLMHToolTip}
{$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;
//fREUrl := '';
inherited;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF USE_MHTOOLTIP}
{$DEFINE code}
{$I KOLMHToolTip}
{$UNDEF code}
{$ENDIF}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_noVERSION}
{$ELSE ASM_VERSION} //Pascal
function TControl.GetParentWindow: HWnd;
begin
{if fHandle = 0 then
begin
Result := 0;
if fParent = nil then Exit;
Result := fParent.GetWindowHandle;
end
else
begin
Result := GetWindow( fHandle, GW_OWNER );
if (Result = 0) and (fParent <> nil) then
Result := fParent.GetWindowHandle;
end;}
Result := GetParentWnd( TRUE );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function TControl.GetWindowHandle: HWnd;
asm
MOV ECX, [EAX].fHandle
JECXZ @@1
XCHG EAX, ECX
RET
@@1:
PUSH EBX
MOV EBX, EAX
{$IFDEF USE_FLAGS}
TEST [EBX].fFlagsG4, 1 shl G4_CreateVisible
{$ELSE}
CMP [EBX].fCreateVisible, 0
{$ENDIF}
JNZ @@2
XOR EDX, EDX
CALL TControl.Set_Visible
MOV EAX, EBX
CALL CallTControlCreateWindow
{ This is a call to Pascal piece of code, which
calls virtual method TControl.CreateWindow }
{$IFDEF USE_FLAGS}
OR [EBX].fFlagsG4, 1 shl G4_CreateHidden
{$ELSE}
INC [EBX].fCreateHidden
{$ENDIF}
JMP @@0
@@2: CALL CallTControlCreateWindow
@@0: MOV EAX, [EBX].fHandle
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function TControl.GetWindowHandle: HWnd;
begin
{$IFDEF INPACKAGE}
Log( '->TControl.GetWindowHandle' );
TRY
{$ENDIF INPACKAGE}
if fHandle = 0 then
begin
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
CreateWindow; //virtual!!!
end;
Result := fHandle;
{$IFDEF INPACKAGE}
LogOK;
FINALLY
Log( '<-TControl.GetWindowHandle' );
END;
{$ENDIF INPACKAGE}
end;
{$ENDIF ASM_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}
{$IFDEF ASM_UNICODE}
function TControl.CreateWindow: Boolean;
type PCreateWndParams = ^TCreateWndParams;
const
CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS;
CS_ON = 0; //CS_VREDRAW or CS_HREDRAW;
szWndClass = sizeof( TWndClass );
int_IDC_ARROW = integer( IDC_ARROW );
asm
PUSH EBX
XCHG EBX, EAX
{$IFDEF DEBUG_CREATEWINDOW}
MOV EAX, EBX
CALL Debug_CreateWindow1
{$ENDIF}
MOV ECX, [EBX].fParent
JECXZ @@chk_handle
XCHG EAX, ECX
CALL GetWindowHandle
TEST EAX, EAX
JZ @@ret_0
@@chk_handle:
MOV ECX, [EBX].fHandle
JECXZ @@prepare_Params
MOV EAX, EBX
{$IFDEF USE_FLAGS}
TEST [EBX].fFlagsG4, 1 shl G4_CreateHidden
{$ELSE}
//MOV DL, 0
CMP [EBX].fCreateHidden, 0
{$ENDIF}
JZ @@create_children
CALL CreateChildWindows
MOV EAX, EBX
MOV DL, 1
CALL Set_Visible
{$IFDEF USE_FLAGS}
AND [EBX].fFlagsG4, not(1 shl G4_CreateHidden)
{$ELSE}
MOV [EBX].fCreateHidden, 0
{$ENDIF}
JMP @@ret_true
@@create_children:
CALL CreateChildWindows
@@ret_true:
MOV AL, 1
@@ret_0:
POP EBX
RET
@@prepare_params:
{$IFDEF USE_GRAPHCTLS}
{$IFDEF USE_FLAGS}
TEST [EBX].fFlagsG6, 1 shl G6_GraphicCtl
SETNZ AL
JNZ @@ret_0
{$ELSE}
MOV AL, [EBX].fWindowed
CMP AL, 0
JZ @@ret_0
{$ENDIF}
{$ENDIF}
PUSH EBP
MOV EBP, ESP
PUSH ECX // Params.WindowClass.lpszClassName := nil
PUSH ECX // Params.WindowClass.lpszMenuName := nil
PUSH ECX // Params.WindowClass.hbrBackground := 0
PUSH int_IDC_ARROW
PUSH ECX
CALL LoadCursor
PUSH EAX // Params.WindowClass.hCursor := LoadCursor( 0, IDC_ARROW )
XOR ECX, ECX
PUSH ECX // Params.WindowClass.hIcon := 0
PUSH [hInstance]// Params.WindowClass.hInstance := hInstance
PUSH ECX // Params.WindowClass.cbWndExtra := 0
PUSH ECX // Params.WindowClass.cbClsExtra := 0
{$IFDEF SAFE_CODE}
PUSH [EBX].fDefWndProc // Params.WindowClass.lpfnWndProc := fDefWndProc
{$ELSE}
PUSH 0
{$ENDIF}
PUSH [EBX].fClsStyle // Params.WindowClass.style := fStyle
ADD ESP, -64
PUSH ECX
MOV EAX, EBX
MOV EDX, ESP
CALL get_ClassName
POP EDX
MOV EAX, ESP
PUSH EDX
//CALL StrPCopy // StrPCopy( Params.WinClsNamBuf, ClassName )
CALL StrCopy
CALL RemoveStr
PUSH 0 // Params.Param := nil
PUSH [hInstance] // Params.Inst := hInstance
PUSH [EBX].fMenu // Params.Menu := fMenu
MOV DL, 1
MOV EAX, EBX
CALL GetParentWnd
PUSH EAX // Params.WndParent := GetParentWnd( True )
MOV ECX, CW_USEDEFAULT
MOV EAX, [EBX].fBoundsRect.Bottom
MOV EDX, [EBX].fBoundsRect.Top
SUB EAX, EDX
JNZ @@1
MOV EAX, ECX
@@1: PUSH EAX // Params.Height := Height | CW_UseDefault
MOV EAX, [EBX].fBoundsRect.Right
SUB EAX, [EBX].fBoundsRect.Left
{$IFDEF USE_CMOV}
CMOVZ EAX, ECX
{$ELSE}
JNZ @@2
XCHG EAX, ECX
@@2: {$ENDIF}
PUSH EAX // Params.Width := Width | CW_UseDefault
MOV EAX, [EBX].fBoundsRect.Left
{$IFDEF USE_FLAGS}
TEST [EBX].fFlagsG3, 1 shl G3_IsControl
{$ELSE}
CMP [EBX].fIsControl, CL
{$ENDIF}
JNZ @@3
{$IFDEF USE_FLAGS}
TEST [EBX].fFlagsG2, (1 shl G2_ChangedPos) or (1 shl G2_ChangedSize)
{$ELSE}
TEST byte ptr [EBX].fChangedPosSz, 3
{$ENDIF USE_FLAGS}
JNZ @@3
MOV EDX, ECX
XCHG EAX, ECX
@@3: PUSH EDX // Params.Y := Top | CW_UseDefault
PUSH EAX // Params.X := Left | CW_UseDefault
PUSH [EBX].fStyle // Params.Style := fStyle
PUSH [EBX].fCaption // Params.Caption := fCaption
LEA EAX, [ESP+40]
PUSH EAX // Params.WinClassName := @Params.WinClsNamBuf
PUSH [EBX].fExStyle // Params.ExStyle := fExStyle
MOV ECX, [EBX].fControlClassName
JECXZ @@registerClass
LEA EAX, [ESP].TCreateWndParams.WindowClass
PUSH EAX // @Params.WindowClass
PUSH ECX // fControlClassName
PUSH [hInstance] // hInstance
CALL GetClassInfo
MOV EAX, [ESP].TCreateWndParams.Inst
MOV [ESP].TCreateWndParams.WindowClass.hInstance, EAX
AND [ESP].TCreateWndParams.WindowClass.style, not CS_OFF
@@registerClass:
CMP [EBX].fDefWndProc, 0
JNE @@fDefWndProc_ready
MOV EAX, [ESP].TCreateWndParams.WindowClass.lpfnWndProc
MOV [EBX].fDefWndProc, EAX
@@fDefWndProc_ready:
MOV ECX, [ESP].TCreateWndParams.WndParent
TEST ECX, ECX
JNZ @@registerClass1
TEST byte ptr [ESP].TCreateWndParams.Style+3, $40
XCHG EAX, ECX
JNZ @@fin
@@registerClass1:
MOV EAX, [ESP].TCreateWndParams.WinClassName
MOV EDX, [ESP].TCreateWndParams.WindowClass.hInstance
ADD ESP, -szWndClass
PUSH ESP
PUSH EAX
PUSH EDX
CALL GetClassInfo
ADD ESP, szWndClass
TEST EAX, EAX
JNZ @@registered
MOV EAX, [ESP].TCreateWndParams.WinClassName
MOV [ESP].TCreateWndParams.WindowClass.lpszClassName, EAX
MOV [ESP].TCreateWndParams.WindowClass.lpfnWndProc, offset WndFunc
LEA EAX, [ESP].TCreateWndParams.WindowClass
PUSH EAX
CALL RegisterClass
TEST EAX, EAX
JZ @@fin
@@registered:
MOV [CreatingWindow], EBX
{$IFDEF DEBUG_CREATEWINDOW}
MOV EAX, EBX
MOV EDX, ESP
CALL Debug_CreateWindow2
{$ENDIF}
CALL CreateWindowEx
MOV [EBX].fHandle, EAX
TEST EAX, EAX
JZ @@fin
PUSH EAX
{$IFDEF USE_PROP}
PUSH offset ID_SELF
{$ELSE}
PUSH GWL_USERDATA
{$ENDIF}
PUSH EAX
PUSH 0
PUSH $10002 //UIS_CLEAR or (UISF_HIDEFOCUS shl 16)
PUSH $0128 //WM_UPDATEUISTATE
PUSH EAX
CALL SendMessage
{$IFDEF USE_PROP}
CALL GetProp
{$ELSE}
CALL GetWindowLong
{$ENDIF}
XCHG ECX, EAX
POP EAX
INC ECX
LOOP @@propSet
MOV [CreatingWindow], ECX
PUSH EBX
{$IFDEF USE_PROP}
PUSH offset ID_SELF
PUSH EAX
CALL SetProp
{$ELSE}
PUSH GWL_USERDATA
PUSH EAX
CALL SetWindowLong
{$ENDIF}
@@propSet:
{$IFDEF SMALLEST_CODE}
{$ELSE}
{$IFDEF USE_FLAGS}
TEST [EBX].fFlagsG3, 1 shl G3_IsControl
{$ELSE}
CMP [EBX].fIsControl, 0
{$ENDIF}
JNZ @@iconSet
MOV EAX, EBX
CALL GetIcon
PUSH EAX
PUSH 1
PUSH WM_SETICON
PUSH EBX
CALL Perform
@@iconSet:
{$ENDIF}
MOV ECX, [EBX].PP.fCreateWndExt
{$IFDEF NIL_EVENTS}
JECXZ @@dblbufcreate
{$ENDIF}
MOV EAX, EBX
CALL ECX
@@dblbufcreate:
@@applyfont:
MOV EAX, EBX
CALL [ApplyFont2Wnd_Proc]
MOV EAX, EBX
CALL [ApplyFont2Wnd_Proc]
@@createchildren:
XCHG EAX, EBX
CALL CreateChildWindows
MOV AL, 1
@@fin:
MOV ESP, EBP
POP EBP
@@ret_false:
POP EBX
end;
{$ELSE ASM_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 ASM_VERSION}
{$IFDEF UNICODE_CTRLS}
TempOleStr : PWideChar;
{$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
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;
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}
{$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}
{$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 ASM_VERSION} //Pascal
function WndProcMouse(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
var MouseData: TMouseEventData;
begin
Result := False;
if (Msg.message >= WM_MOUSEFIRST) and (Msg.message <= $20A {WM_MOUSELAST}) then
with MouseData do
begin
Shift := Msg.wParam;
if GetKeyState( VK_MENU ) < 0 then
Shift := Shift or MK_ALT;
X := LoWord( Msg.lParam );
Y := HiWord( Msg.lParam );
//Button := TMouseButton(Msg.wParam);
// not possible: wParam can contain a combination of flags
// MK_CONTROL, MK_LBUTTON, MK_RBUTTON, MK_MBUTTON, MK_SHIFT, MK_XBUTTON1, MK_XBUTTON2
// So, Shift must be tested.
Button := mbNone;
StopHandling := FALSE;
Rslt := 0; // needed ?
case Msg.message of
WM_LBUTTONDOWN:
{$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 ASM_VERSION}
{$IFDEF ASM_UNICODE}
function WndProcKeybd( Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
asm
PUSH EBX
MOV ECX, [EDX].TMsg.message
SUB CX, $100
CMP ECX, 5
JA @@fin_false
XCHG EBX, EAX // EBX = @Self
XCHG EAX, ECX // EAX = message - WM_KEYFIRST
{$IFDEF EVENTS_DYNAMIC}
MOV ECX, [EBX].TControl.EV
LEA ECX, [ECX].TEvents.fOnKeyUp
{$ELSE}
LEA ECX, [EBX].TControl.EV.fOnKeyUp
{$ENDIF}
JZ @@event
{$IFDEF PARANOIA} DB $34, 1 {$ELSE} XOR AL, 1 {$ENDIF}
JZ @@event
//LEA ECX, [EBX].TControl.EV.fOnKeyDown
ADD ECX, 8
{$IFDEF PARANOIA} DB $34, 1 {$ELSE} XOR AL, 1 {$ENDIF}
JZ @@event
{$IFDEF PARANOIA} DB $34, 4 {$ELSE} XOR AL, 4 {$ENDIF}
JZ @@event
//LEA ECX, [EBX].TControl.EV.fOnChar
SUB ECX, 24
{$IFDEF PARANOIA} DB $34, 6 {$ELSE} XOR AL, 2 xor 4 {$ENDIF}
JZ @@event
{$IFDEF PARANOIA} DB $34, 4 {$ELSE} XOR AL, 6 xor 2 {$ENDIF}
JNZ @@fin_false
@@event:
{$IFDEF NIL_EVENTS}
CMP word ptr [ECX].TMethod.Code+2, 0
JZ @@fin_false
{$ENDIF}
PUSH EDX
PUSH ECX
LEA ECX, [EDX].TMsg.wParam
PUSH ECX
CALL GetShiftState
POP ECX // @wParam
XCHG EAX, [ESP] // ShiftState; EAX=@event
MOV EDX, EBX // @Self
MOV EBX, [EAX].TMethod.Code
MOV EAX, [EAX].TMethod.Data
CALL EBX
POP EDX
MOV ECX, [EDX].TMsg.wParam
JECXZ @@fin_true
@@fin_false:
XOR EAX, EAX
POP EBX
RET
@@fin_true:
MOV AL, 1
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function WndProcKeybd(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
var C : KOLChar;
begin
Result := True;
case Msg.message of
WM_KEYDOWN, WM_SYSKEYDOWN:
{$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 ASM_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 );
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 );
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}
{$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
{$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
PostQuitMessage( 0 );
Default;
end;
{$IFDEF USE_PROP}
WM_NCDESTROY:
begin
RemoveProp( fHandle, ID_SELF ); //********* Added By M.Gerasimov
end;
{$ENDIF}
WM_DESTROY:
begin
{$IFDEF USE_FLAGS} include( fFlagsG2, G2_BeginDestroying );
{$ELSE} fBeginDestroying := TRUE; {$ENDIF}
Default;
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit;
end;
WM_SIZE: begin
{$IFDEF INPACKAGE}
Log( 'WM_SIZE >>> Default' );
{$ENDIF INPACKAGE}
Default;
{$IFDEF INPACKAGE}
Log( '//// Default called' );
{$ENDIF INPACKAGE}
{$IFDEF OLD_ALIGN}
if {$IFDEF USE_FLAGS} not(G3_IsForm in fFlagsG3)
{$ELSE} not fIsForm {$ENDIF} then
Global_Align( fParent );
{$ENDIF}
{$IFDEF INPACKAGE}
Log( '//// Before Global_Align' );
{$ENDIF INPACKAGE}
Global_Align( @Self );
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit;
end;
WM_SysCommand:
begin
if ((Msg.wParam and $FFF0) = SC_MINIMIZE) and
IsMainWindow and (@Self <> Applet) then
begin
PostMessage( Applet.Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0 );
Result := 0;
end
else Default;
end;
WM_SETFOCUS:
begin
if not DoSetFocus then
begin
Result := 0;
end
else
begin
Inc( fClickDisabled );
Default;
Dec( fClickDisabled );
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit;
end;
end;
WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:
begin
Result := SendMessage(Msg.LParam, CN_BASE + Msg.message, Msg.WParam, Msg.LParam);
end;
WM_COMMAND:
begin
{$IFDEF USE_PROP}
C := Pointer( GetProp( Msg.lParam, ID_SELF ) );
{$ELSE}
C := Pointer( GetWindowLong( Msg.lParam, GWL_USERDATA ) );
{$ENDIF}
if C <> nil then
begin
Result := SendMessage( Msg.lParam, CM_COMMAND, Msg.wParam, Msg.lParam );
end
else Default;
end;
WM_KEYFIRST..WM_KEYLAST:
begin
F := GetFocus;
if {(F <> fFocusHandle) and} (F <> fHandle)
{$IFDEF USE_GRAPHCTLS} and
{$IFDEF USE_FLAGS} not(G6_GraphicCtl in fFlagsG6)
{$ELSE} fWindowed {$ENDIF} {$ENDIF}
{$IFDEF KEY_PREVIEW}
and {$IFDEF USE_FLAGS} not(G4_Pushed in fFlagsG4)
{$ELSE} not fKeyPreviewing {$ENDIF}
{$ENDIF}
then
begin
Result := 0;
// Jump to PassFun here. Prevents beep in case when WM_KEYDOWN
// called another form and focus is changed, so WM_KEYUP failed
// to handle.
end
else
begin
{$IFDEF KEY_PREVIEW} //ADDITION JUST FOR CORRECT KEYPREVIEWING
{$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_Pushed );
{$ELSE} fKeyPreviewing:=false; {$ENDIF}
{$ENDIF}
if fGlobalProcKeybd( @Self, Msg, Result ) then
begin
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit; //??????????????????
end;
if PP.fWndProcKeybd( @Self, Msg, Result ) then
begin
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit; //???????????????????
end;
if ((GetKeystate( VK_CONTROL ) or GetKeyState( VK_MENU )) >= 0) then
begin
//+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
if (Msg.message <> WM_CHAR) // v1.02 Tabulate AND " in EditBox fix
//+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
then
begin
C := ParentForm;
if (C <> nil)
{$IFDEF NIL_EVENTS}
and Assigned(C.PP.fGotoControl)
{$ENDIF}
and C.PP.fGotoControl( @Self, Msg.wParam,
(Msg.message <> WM_KEYDOWN) and
(Msg.message <> WM_SYSKEYDOWN) ) then
begin
Msg.wParam := 0;
Result := 0;
end
else Default;
end
//+++++++++++++++++++++++++++++++++++++++++++++//
else //
if Msg.wParam = 9 then // prevent system beep //
begin //
Msg.wParam := 0; //
Result := 0; //
end //
//+++++++++++++++++++++++++++++++++++++++++++++//
else Default;
end
else Default;
end;
end;
else begin
{$IFDEF DEBUG_MCK} mck_Log( 'else' ); {$ENDIF}
Default; //+-+
{$IFDEF INPACKAGE}
LogOK;
{$ENDIF INPACKAGE}
Exit; //+-+
end;
end;
end;
end;
end;
end;
{$IFDEF DEBUG_MCK} mck_Log( '06' ); {$ENDIF}
if not AppletTerminated
{$IFDEF USE_fNCDestroyed} and not fNCDestroyed {$ENDIF} then
begin {$IFDEF DEBUG_MCK} mck_Log( '07' ); {$ENDIF}
PassFun( @Self, Msg, Result ); //+-+
{$IFDEF DEBUG_MCK} mck_Log( '08' ); {$ENDIF}
end;
{$IFDEF INPACKAGE}
LogOK;
FINALLY
Log( '<-TControl.WndProc' );
END;
{$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 ASM_VERSION} //Pascal
procedure TControl.SetClsStyle( Value: DWord );
begin
if fClsStyle = Value then Exit;
fClsStyle := Value;
if fHandle = 0 then Exit;
SetClassLong( fHandle, GCL_STYLE, Value );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_VERSION} //Pascal
procedure TControl.SetExStyle( Value: DWord );
begin
if fExStyle = Value then Exit;
fExStyle := Value;
if fHandle = 0 then Exit;
SetWindowLong( fHandle, GWL_EXSTYLE, Value );
SetWindowPos( fHandle, 0, 0, 0, 0, 0,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or
SWP_NOZORDER or SWP_FRAMECHANGED );
Invalidate;
end;
{$ENDIF ASM_VERSION}
function WndProcSetCursor( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var Cur: HCursor;
begin
Result := FALSE;
if Msg.message = WM_SETCURSOR then
begin
if (GetCapture = 0) and
(LOWORD( Msg.lParam ) = HTCLIENT) then
begin
if ScreenCursor <> 0 then //YS
Cur := ScreenCursor //YS
else //YS
Cur := Self_.fCursor; //YS
if Cur <> 0 then //YS
begin //YS
Windows.SetCursor( Cur ); //YS
Rslt := 1; //YS
Result := TRUE;
end;
end;
end;
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetCursor( Value: HCursor );
var P: TPoint;
begin
AttachProc( WndProcSetCursor );
if fCursor = Value then Exit;
fCursor := Value;
if (fHandle = 0) or (fCursor = 0) then Exit; //YS
if ScreenCursor <> 0 then Exit;
GetCursorPos( P );
P := Screen2Client( P );
if PointInRect( P, ClientRect ) then
Windows.SetCursor( Value );
end;
{$ENDIF ASM_VERSION}
procedure TControl.CursorLoad(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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetMenu( Value: HMenu );
begin
if fMenu = Value then Exit;
if fMenuObj <> nil then
begin
{$IFDEF USE_AUTOFREE4CONTROLS}
RemoveFromAutoFree( fMenuObj );
{$ENDIF}
fMenuObj.Free;
end;
if fMenu <> 0 then
DestroyMenu( fMenu );
fMenu := Value;
if fHandle = 0 then Exit;
Windows.SetMenu( fHandle, Value );
end;
{$ENDIF ASM_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;
//ShowMessage( Int2Str( Cmd ) + ' ' + Int2Str( Context ) );
HtmlHelpCommand( {$IFDEF HTMLHELP_NOTOP} 0 {$ELSE} Applet.Handle {$ENDIF},
HelpFilePath, Cmd, Context );
end;
var
Global_HelpProc: procedure( Context: Integer; CtxCtl: PControl ) = CallWinHelp;
function WndProcHelp( 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
//fHelpContext := Value;
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
Assert( (HtmlHelpPath <> '') and (Applet <> nil), 'Error parameters' );
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
Assert( Value <> '', 'Error parameter' );
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}
function TControl.GetCaption: KOLString;
asm
PUSH EBX
PUSH EDI
XCHG EBX, EAX
MOV EDI, EDX
{$IFDEF USE_FLAGS}
TEST [EBX].fFlagsG1, (1 shl G1_IgnoreWndCaption)
{$ELSE}
CMP [EBX].fIgnoreWndCaption, 0
{$ENDIF USE_FLAGS}
JNZ @@getFCaption
MOV ECX, [EBX].fHandle
JECXZ @@getFCaption
@@getWndCaption:
PUSH ECX
CALL GetWindowTextLength
PUSH EAX
XCHG EDX, EAX
LEA EAX, [EBX].fCaption
CALL System.@LStrSetLength
POP ECX
JECXZ @@getFCaption
INC ECX
PUSH ECX
PUSH [EBX].fCaption
PUSH [EBX].fHandle
CALL GetWindowText
@@getFCaption:
MOV EDX, [EBX].fCaption
XCHG EAX, EDI
{$IFNDEF UNICODE_CTRLS}
CALL System.@LStrAsg
{$ELSE}
CALL System.@WStrFromPChar
{$ENDIF}
@@exit:
POP EDI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function TControl.GetCaption: KOLString;
var Sz: Integer;
begin
if {$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 ASM_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 ASM_VERSION} //Pascal
procedure TControl.SetCaption( const Value: KOLString );
begin
fCaption := Value;
if fHandle <> 0 then
SendMessage( fHandle, WM_SETTEXT,
0, Integer( PKOLChar( Value ) ) );
if {$IFDEF USE_FLAGS} (G1_IsStaticControl in fFlagsG1)
{$ELSE} fIsStaticControl <> 1 {$ENDIF} then
Invalidate;
DoAutoSize;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE TControl.SetCaption( CONST Value: KOLString );
BEGIN
fCaption := Value;
if Assigned( fSetCaption ) THEN
fSetCaption( @Self, Value );
DoAutoSize;
END;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION}
function TControl.GetVisible: Boolean;
begin
{$IFDEF USE_FLAGS}
if (fHandle <> 0) then
Result := IsWindowVisible( fHandle )
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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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;
if not Value and (fHandle <> 0) then
{$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_CreateHidden );
{$ELSE} fCreateHidden := FALSE; {$ENDIF} // { +++ }
{$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 USE_FLAGS} exclude( fFlagsG4, G4_CreateHidden );
{$ELSE} fCreateHidden := FALSE; {$ENDIF} // { +++ }
ShowWindow( fHandle, SW_HIDE );
Global_Align( @Self );
end;
{$ENDIF}
end;
{$ENDIF ASM_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 ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
FUNCTION TControl.GetBoundsRect: TRect;
VAR R: TRect;
window: PGtkWindow;
requisition: TGtkRequisition;
BEGIN
//if fHandle <> nil then
BEGIN
IF fIsControl THEN
BEGIN
R.Left := fBoundsRect.Left;
R.Top := fBoundsRect.Top;
gtk_widget_get_size_request( fEventboxHandle, @ R.Right, @ R.Bottom );
gtk_widget_size_request( fHandle, @ requisition );
IF R.Right < 0 THEN R.Right := requisition.width;
IF R.Bottom < 0 THEN R.Bottom := requisition.height;
END ELSE
BEGIN
window := GTK_WINDOW( fHandle );
gtk_window_get_position(window, @ R.Left, @ R.Top);
gtk_window_get_size(window, @ R.Right, @ R.Bottom);
END;
inc( R.Right, R.Left );
inc( R.Bottom, R.Top );
fBoundsRect := R;
END;
Result := fBoundsRect;
END;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE TControl.SetBoundsRect( const Value: TRect );
VAR Rect: TRect;
window: PGtkWindow;
BEGIN
Rect := GetBoundsRect;
if RectsEqual( Value, Rect ) then Exit;
{$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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.Show;
begin
CreateWindow;
SetVisible( True );
SetForegroundWindow( Handle );
DoSetFocus;
end;
{$ENDIF ASM_VERSION}
procedure TControl.Hide;
begin
SetVisible( False );
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.Client2Screen( const P: TPoint ): TPoint;
begin
Result := P;
if fHandle <> 0 then
Windows.ClientToScreen( fHandle, Result );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.Screen2Client( const P: TPoint ): TPoint;
begin
Result := P;
if Handle <> 0 then
Windows.ScreenToClient( Handle, Result );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
FUNCTION TControl.ClientRect: TRect; //todo: implement exact, now for PaintBox only
BEGIN
Result := fBoundsRect;
OffsetRect( Result, -Result.Left, -Result.Top );
Inc( Result.Top, fClientTop );
Dec( Result.Bottom, fClientBottom );
Inc( Result.Left, fClientLeft );
Dec( Result.Right, fClientRight );
END;
{$ENDIF GTK}
{$ENDIF _X_}
{$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 ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE TControl.Invalidate;
BEGIN
gtk_widget_queue_draw_area( fHandle, 0, 0, Width, Height );
END;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
{$IFDEF USE_GRAPHCTLS}
procedure 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 ASM_VERSION}
{$ENDIF USE_GRAPHCTLS}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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
begin
Inc( fClickDisabled );
SetFocus( fHandle );
Dec( fClickDisabled );
Result := True;
end;
end;
{$ENDIF ASM_VERSION}
function TControl.HandleAllocated: Boolean;
begin
Result := FHandle <> 0;
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetEnabled: Boolean;
begin
if FHandle = 0 then
Result := (Style and WS_DISABLED) = 0
else Result := IsWindowEnabled( FHandle );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.IsMainWindow: Boolean;
begin
if Applet = nil then
Result := not IsControl
else if not AppButtonUsed then
Result := @ Self = Applet
else
Result := Applet.Children[ 0 ] = @ Self;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
{$IFDEF ASM_UNICODE}
function TControl.get_ClassName: AnsiString;
asm
PUSH EBX
XCHG EBX, EAX
XCHG EAX, EDX
MOV EDX, [EBX].fControlClassName
PUSH EAX
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar // EAX^ := String(EDX)
POP EAX
{$IFDEF USE_FLAGS}
TEST [EBX].fFlagsG6, 1 shl G6_CtlClassNameChg
{$ELSE}
CMP [EBX].fCtlClsNameChg, 0
{$ENDIF}
JNZ @@exit
MOV ECX, [EAX]
MOV EDX, offset[ @@obj ]
CALL System.@LStrCat3 // EAX^ := EDX + ECX
JMP @@exit
{$IFDEF _D2009orHigher}
DW 1252, 1 // CP_ANSI_LATIN1, Byte // TODO: CP_ACP
{$ENDIF}
DD -1, 4 // FFFFFFFF 04000000 obj_, 0
@@obj: DB 'obj_', 0
@@exit:
POP EBX
end;
{$ELSE ASM_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 ASM_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 ASM_VERSION} //Pascal
procedure TControl.SetParent( Value: PControl );
begin
if Value = fParent then Exit;
if fParent <> nil then
begin
{$IFDEF USE_GRAPHCTLS}
Invalidate; // necessary for graphic controls
{$ENDIF}
{$IFDEF DEBUG_MCK}
if ( 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 ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE TControl.SetParent( Value: PControl );
BEGIN
IF Value = fParent THEN Exit;
IF fParent <> nil THEN
begin
fParent.fChildren.Remove( @Self );
{$IFDEF NOT_USE_AUTOFREE4CONTROLS}
{$ELSE}
fParent.RemoveFromAutoFree( @Self );
{$ENDIF}
END;
fParent := Value;
IF fParent <> nil THEN
BEGIN
fParent.fChildren.Add( @Self );
{$IFDEF USE_AUTOFREE4CHILDREN}
fParent.Add2AutoFree( @ Self );
{$ENDIF}
END;
fParent.fGetClientArea( fParent );
fParent.fChildPut( fParent, @ Self, fBoundsRect.Left, fBoundsRect.Top );
END;
{$ENDIF GTK}
{$ENDIF _X_}
function TControl.ChildIndex(Child: PControl): Integer;
begin
Result := fChildren.IndexOf( Child );
end;
procedure TControl.MoveChild(Child: PControl; NewIdx: Integer);
var I: Integer;
begin
I := ChildIndex( Child );
Assert( I>=0, 'TControl.MoveChild: index out of bounds' );
fChildren.MoveItem( I, NewIdx );
end;
{$IFDEF WIN_GDI}
procedure TControl.EnableChildren(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 ASM_VERSION} //Pascal
constructor TControl.CreateParented(AParent: PControl);
begin
InitParented( AParent ); // because InitParented is virtual, but CreateParented
end; // can not be virtual (as an _object_ - not a class - constructor)
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
CONSTRUCTOR TControl.CreateParented(AParent: PControl; widget: PGtkWidget;
need_eventbox: Boolean);
BEGIN
InitParented( AParent, widget, need_eventbox );
// because InitParented is virtual, but CreateParented
END; // can not be virtual (as an _object_ - not a class - constructor)
{$ENDIF GTK}
{$ENDIF _X_}
constructor TControl.CreateOrthaned( AParentWnd: HWnd );
begin
InitOrthaned( AParentWnd );
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetLeft: Integer;
begin
Result := BoundsRect.Left;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetLeft( Value: Integer );
var R: TRect;
begin
R := BoundsRect;
R.Left := Value;
R.Right := Value + Width;
SetBoundsRect( R );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetTop: Integer;
begin
Result := BoundsRect.Top;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetTop( Value: Integer );
var R: TRect;
begin
R := BoundsRect;
R.Top := Value;
R.Bottom := Value + Height;
SetBoundsRect( R );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetWidth: Integer;
begin
with BoundsRect do
Result := Right - Left;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetWidth( Value: Integer );
var R: TRect;
begin
R := BoundsRect;
with R do
Right := Left + Value;
SetBoundsRect( R );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetHeight: Integer;
begin
with BoundsRect do
Result := Bottom - Top;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetHeight( Value: Integer );
var R: TRect;
begin
R := BoundsRect;
with R do
Bottom := Top + Value;
SetBoundsRect( R );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetPosition: TPoint;
begin
Result.x := BoundsRect.Left;
Result.y := BoundsRect.Top;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.Set_Position( Value: TPoint );
var R: TRect;
begin
R.Top := Value.y;
R.Left := Value.x;
R.Right := R.Left + Width;
R.Bottom := R.Top + Height;
BoundsRect := R;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
function WndProcConstraints( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var MMI: PMinMaxInfo;
begin
Result := FALSE;
if Msg.message = WM_GETMINMAXINFO then
begin
Rslt := Sender.CallDefWndProc( Msg );
MMI := Pointer( Msg.lParam );
if Sender.FMaxWidth > 0 then
begin
MMI.ptMaxSize.x := Sender.FMaxWidth;
MMI.ptMaxTrackSize.x := Sender.FMaxWidth;
end;
if Sender.FMaxHeight > 0 then
begin
MMI.ptMaxSize.y := Sender.FMaxHeight;
MMI.ptMaxTrackSize.y := Sender.FMaxHeight;
end;
MMI.ptMinTrackSize := MakePoint( Sender.FMinWidth, Sender.FMinHeight );
Rslt := 0;
Result := TRUE;
end;
end;
{$IFDEF USE_MHTOOLTIP}
{$DEFINE implementation}
{$I KOLMHToolTip}
{$UNDEF implementation}
{$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 ASM_VERSION} //Pascal
procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect );
{$IFDEF GDI} var B: HBrush; {$ENDIF GDI}
begin
{$IFDEF GDI}
B := CreateSolidBrush( Color2Rgb( Sender.Color ) );
Windows.FillRect( DC, Rect^, B );
DeleteObject( B );
{$ENDIF GDI}
end;
{$ENDIF ASM_VERSION}
{$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 ASM_VERSION} //Pascal
procedure TControl.SetCtlColor( Value: TColor );
begin
{$IFNDEF INPACKAGE}
if GetWindowHandle <> 0 then
{$ELSE}
if fHandle <> 0 then
{$ENDIF}
if fCommandActions.aSetBkColor <> 0 then
Perform( fCommandActions.aSetBkColor, 0, Color2RGB( Value ) );
if fColor = Value then Exit;
fColor := Value;
if fTmpBrush <> 0 then
begin
DeleteObject( fTmpBrush );
fTmpBrush := 0;
end;
if fBrush <> nil then
fBrush.Color := Value;
Invalidate;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE TControl.SetCtlColor( Value: TColor );
VAR gcolor: TGdkColor;
i: Integer;
BEGIN
if fColor = Value then Exit;
fColor := Value;
//oldfontdesc := PGtkWidget( _Self.fHandle ).style.font_desc;
gcolor := Color2GdkColor( Value );
FOR i := 0 to 4 do
BEGIN
gtk_widget_modify_bg( fEventboxHandle, {GTK_STATE_NORMAL} i, @ gcolor );
gtk_widget_modify_base( fEventboxHandle, {GTK_STATE_NORMAL} i, @ gcolor );
END;
//if Assigned( _Self.fFont ) then
{begin
_Self.fHandle.style.font_desc :=
pango_font_description_copy( _Self.fFont.GetPangoFontDesc );
if oldfontdesc <> nil then
pango_font_description_free( oldfontdesc );
end;}
//Invalidate;
END;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.CreateChildWindows;
var I: Integer;
C: PControl;
begin
{$IFDEF INPACKAGE}
Log( '->TControl.CreateChildWindows' );
TRY
{$ENDIF INPACKAGE}
for I := 0 to fChildren.Count - 1 do
begin
{$IFDEF INPACKAGE}
Log( Int2Str( I ) );
{$ENDIF INPACKAGE}
C := fChildren.Items[ I ];
C.CreateWindow; //virtual!!!
end;
{$IFDEF INPACKAGE}
LogOK;
FINALLY
Log( '<-TControl.CreateChildWindows' );
END;
{$ENDIF INPACKAGE}
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
function TControl.GetMembers(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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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( Msg );
DispatchMessage( Msg );
{$IFDEF PSEUDO_THREADS}
if Assigned( MainThread ) then
MainThread.NextThread;
{$ENDIF}
end;
end;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.ProcessMessages;
begin
while ProcessMessage do ;
end;
{$ENDIF ASM_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 ASM_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;
{$IFDEF SNAPMOUSE2DFLTBTN}
//WM_INITDIALOG:
// Result := FALSE;
{$ENDIF}
else Result := False;
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function GetPrevCtrlBoundsRect( P: PControl; var R: TRect ): Boolean;
var Idx: Integer;
begin
Result := False;
if P.FParent = nil then Exit;
Idx := P.FParent.ChildIndex( P ) - 1;
if Idx < 0 then Exit;
Result := True;
R := P.FParent.Children[ Idx ].BoundsRect;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.PlaceUnder: PControl;
var R: TRect;
begin
Result := @Self;
if not GetPrevCtrlBoundsRect( @Self, R ) then Exit;
Top := R.Bottom + fParent.fMargin;
Left := R.Left;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.PlaceDown: PControl;
var R: TRect;
begin
Result := @Self;
if not GetPrevCtrlBoundsRect( @Self, R ) then Exit;
Top := R.Bottom + fParent.fMargin;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.PlaceRight: PControl;
var R: TRect;
begin
Result := @Self;
if not GetPrevCtrlBoundsRect( @Self, R ) then Exit;
Top := R.Top;
Left := R.Right + fParent.fMargin;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.SetSize(W, H: Integer): PControl;
var R: TRect;
begin
R := BoundsRect;
if W > 0 then R.Right := R.Left + W;
if H > 0 then R.Bottom := R.Top + H;
SetBoundsRect( R );
Result := @Self;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
function TControl.SetClientSize(W, H: Integer): PControl;
begin
if W > 0 then ClientWidth := W;
if H > 0 then ClientHeight := H;
Result := @Self;
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.AlignLeft(P: PControl): PControl;
begin
Result := @Self;
Left := P.Left;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.AlignTop(P: PControl): PControl;
begin
Result := @Self;
Top := P.Top;
end;
{$ENDIF ASM_VERSION}
{$IFDEF KEY_PREVIEW}
{$DEFINE KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
{$ENDIF}
{$IFDEF ESC_CLOSE_DIALOGS}
{$IFNDEF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
{$DEFINE KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
{$ENDIF}
{$ENDIF}
{$IFDEF ASM_VERSION} // see addition for combobox in pas version
{$ELSE ASM_VERSION} //Pascal
function WndProcCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
var F: PControl;
Cmd : DWORD;
begin
Result := FALSE;
with Self_^ do
case Msg.message of
CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:
begin
SetTextColor(Msg.WParam, Color2RGB(fTextColor));
if {$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.fOnChange ) then EV.fOnChange( Self_ );
end else
if Integer(Cmd) = fCommandActions.aSelChange then
begin
DoSelChange;
end
else Result := False;
if Result then
Rslt := CallDefWndProc( Msg );
end;
WM_SETFOCUS:
begin
Rslt := 0;
Result := TRUE;
F := ParentForm;
if F <> nil then
begin
if (F.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-------------------------------------
if ParentForm <> Self_ then
begin
if {$IFDEF USE_FLAGS} G6_KeyPreview in ParentForm.fFlagsG6
{$ELSE} ParentForm.fKeyPreview {$ENDIF} then
begin
{$IFDEF USE_FLAGS}
include( ParentForm.fFlagsG4, G4_Pushed );
{$ELSE} ParentForm.fKeyPreviewing := TRUE; {$ENDIF}
inc( ParentForm.DF.fKeyPreviewCount );
ParentForm.Perform(WM_KEYDOWN,msg.wParam,msg.lParam);
dec( ParentForm.DF.fKeyPreviewCount );
end;
end;
//--------------------------------Truf-------------------------------------
{$ENDIF KEY_PREVIEW}
{$IFDEF ESC_CLOSE_DIALOGS}
//---------------------------------Babenko Alexey--------------------------
begin
if (Self_.ParentForm.fExStyle and WS_EX_DLGMODALFRAME) <> 0 then
if Msg.wParam = 27 then
Self_.ParentForm.Perform(WM_CLOSE, 0, 0);
end;
//---------------------------------Babenko Alexey--------------------------
{$ENDIF ESC_CLOSE_DIALOGS}
end;
{$IFDEF KEY_PREVIEW}
WM_SYSKEYDOWN,
WM_KEYUP, WM_SYSKEYUP,
WM_CHAR, WM_SYSCHAR:
if ParentForm <> Self_ then
begin
if {$IFDEF USE_FLAGS} G6_KeyPreview in ParentForm.fFlagsG6
{$ELSE} ParentForm.fKeyPreview {$ENDIF} then
begin
{$IFDEF USE_FLAGS}
include( ParentForm.fFlagsG4, G4_Pushed );
{$ELSE} ParentForm.fKeyPreviewing := TRUE; {$ENDIF}
ParentForm.Perform(Msg.message,msg.wParam,msg.lParam);
end;
end;
{$ENDIF KEY_PREVIEW}
{$ENDIF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF OLD_TRANSPARENT}
function WndProcTransparent( Sender: PControl; var Msg: TMsg;
var Rslt: Integer ): Boolean;
var DC, PDC, BLTDC: HDC;
Save: integer;
OLDp: THANDLE;
L, T: SmallInt;
TP, ParentClient: TPoint;
TR, Margins: TRect;
Wnd: HWND;
tRgn: HRgn;
C: PControl;
begin
Result := FALSE;
{$IFDEF STOP_WNDPROCTRANSPARENT_AFTER_APPLETTERMINATED}
if AppletTerminated or not Sender.ToBeVisible then
begin
Exit;
end;
{$ENDIF}
case Msg.message of
WM_HSCROLL, WM_VSCROLL:
begin
Sender.Invalidate;
exit;
end;
WM_SETTEXT:
begin
if {$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
begin
Exit;
end;
{$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 ASM_VERSION} //Pascal
function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var PaintStruct: TPaintStruct;
Cplxity: Integer;
OldPaintDC: HDC;
begin
with Self_^ do
case Msg.message of
//WM_PRINT,
WM_PAINT: if assigned( 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 ASM_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 ASM_VERSION} //Pascal
procedure TControl.DoClick;
begin
PP.fControlClick( @Self );
{$IFDEF NIL_EVENTS}
if Assigned( EV.fOnClick ) then
{$ENDIF}
EV.fOnClick( @Self );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetProgressColor(const Value: TColor);
begin
if Perform( PBM_SETBARCOLOR, 0, Color2RGB(Value) ) <> 0 then
fTextColor := Value;
end;
{$ENDIF ASM_VERSION}
procedure TControl.SetShadowDeep(const Value: Integer);
begin
DF.fShadowDeep := Value;
Invalidate;
end;
{$ENDIF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetFont: PGraphicTool;
begin
if FFont = nil then
begin
FFont := NewFont;
{$IFDEF USE_AUTOFREE4CONTROLS}
Add2AutoFree( FFont );
{$ENDIF}
FFont.fData.Color := fTextColor;
FFont.OnChange := FontChanged;
end;
Result := FFont;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetBrush: PGraphicTool;
begin
if FBrush = nil then
begin
FBrush := NewBrush;
FBrush.fData.Color := fColor;
FBrush.OnChange := BrushChanged;
{$IFDEF USE_AUTOFREE4CONTROLS}
Add2AutoFree( FBrush );
{$ENDIF}
end;
Result := FBrush;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.FontChanged(Sender: PGraphicTool);
begin
fTextColor := Sender.fData.Color;
ApplyFont2Wnd_Proc(@Self);
Invalidate;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.BrushChanged(Sender: PGraphicTool);
begin
fColor := Sender.fData.Color;
if fTmpBrush <> 0 then
begin
DeleteObject( fTmpBrush );
fTmpBrush := 0;
end;
if fPaintDC = 0 then
// only if not in painting already :
Invalidate;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure DoApplyFont2Wnd( _Self: PControl );
begin
if _Self.fFont <> nil then
begin
if _Self.fHandle <> 0 then
begin
_Self.fTextColor := _Self.fFont.fData.Color;
_Self.Perform( WM_SETFONT, _Self.FFont.Handle, 1 );
end;
if _Self.fCanvas <> nil then
begin
_Self.fCanvas.Free;
_Self.fCanvas := nil;
end;
_Self.DoAutoSize;
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE DoApplyFont2Wnd( _Self: PControl );
VAR oldfontdesc: PPangoFontDescription;
rcstyle: PGtkRcStyle;
gcolor: TGdkColor;
i: Integer;
BEGIN
IF ( _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 ASM_VERSION} //Pascal
function TControl.ResizeParent: PControl;
begin
ResizeParentBottom;
ResizeParentRight;
// Once again, to fix Windows (or my???) bug with
// incorrect calculating of GetClientRect after
// SetWindowLong( GWL_[EX}STYLE,... )
Result := ResizeParentBottom;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.ResizeParentBottom: PControl;
var NewCH: Integer;
begin
Result := @Self;
if fParent <> nil then
begin
NewCH := BoundsRect.Bottom + fParent.fMargin;
if {$IFDEF USE_FLAGS} G2_ChangedSize 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_ChangedSize );
{$ELSE} fParent.fChangedPosSz := fParent.fChangedPosSz or $20; {$ENDIF}
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.ResizeParentRight: PControl;
var NewCW: Integer;
begin
Result := @Self;
if fParent <> nil then
begin
NewCW := fBoundsRect.Right + fParent.fMargin;
if {$IFDEF USE_FLAGS} G2_ChangedSize 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_ChangedSize );
{$ELSE} fParent.fChangedPosSz := fParent.fChangedPosSz or $10; {$ENDIF}
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetClientHeight: Integer;
begin
with ClientRect do
Result := Bottom - Top;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetClientWidth: Integer;
begin
with ClientRect do
Result := Right - Left;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetClientHeight(const Value: Integer);
var Delta: Integer;
begin
Delta := ClientHeight;
Delta := Height - Delta;
Height := Value + Delta;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetClientWidth(const Value: Integer);
var Delta: Integer;
begin
Delta := ClientWidth;
Delta := Width - Delta;
Width := Value + Delta;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetHasCaption(const Value: Boolean);
begin
if Value = GetHasCaption then Exit;
if Value then
begin
Style := fStyle.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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetCanResize: Boolean;
begin
{$IFDEF USE_FLAGS}
Result := not(G1_PreventResize in fFlagsG1);
{$ELSE}
Result := not fPreventResize;
{$ENDIF}
end;
{$ENDIF ASM_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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetStayOnTop: Boolean;
begin
UpdateWndStyles;
Result := LongBool( fExStyle and WS_EX_TOPMOST);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetStayOnTop(const Value: Boolean);
begin
if Value = GetStayOnTop then Exit;
if fHandle <> 0 then
if Value then
SetWindowPos( fHandle, HWND_TOPMOST, 0,0,0,0,
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE )
else
SetWindowPos( fHandle, HWND_NOTOPMOST, 0,0,0,0,
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE )
else
if Value then fExStyle := fExStyle or WS_EX_TOPMOST
else fExStyle := fExStyle and not WS_EX_TOPMOST;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_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 ASM_VERSION} //Pascal
function TControl.GetSelStart: Integer;
begin
Result := 0;
if fCommandActions.aGetSelRange <> 0 then
Perform( fCommandActions.aGetSelRange, Integer( @ Result ), 0 );
end;
{$ENDIF ASM_VERSION}
procedure TControl.SetSelStart(const Value: Integer);
begin
ItemSelected[ Value ] := True;
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetSelLength: Integer;
var Start, Finish: Integer;
begin
Result := 0;
if fCommandActions.aGetSelCount <> 0 then
begin
if fCommandActions.aGetSelCount = EM_GETSEL then
begin
Perform( fCommandActions.aGetSelCount, Integer( @ Start ), Integer( @ Finish ) );
Result := Finish - Start;
end
else
begin
Result := Perform( fCommandActions.aGetSelCount {and $7FFF}, 0, 0 );
end;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetSelLength(const Value: Integer);
var SR: TCharRange;
begin
SR.cpMin := GetSelStart;
SR.cpMax := SR.cpMin + Value;
if Value < 0 then
SR.cpMax := -1;
if fCommandActions.aSetSelRange <> 0 then
Perform( fCommandActions.aSetSelRange, SR.cpMin, SR.cpMax )
else
if fCommandActions.aExSetSelRange <> 0 then
Perform( fCommandActions.aExSetSelRange, 0, Integer( @SR ) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function TControl.GetItems(Idx: Integer): AnsiString;
asm
PUSH ESI
PUSH EDI
PUSH EBX
PUSH EBP
MOV EBP, ESP
MOV EBX, EAX // @Self
MOV ESI, EDX // Idx
MOV EDI, ECX // @Result
CALL Item2Pos
PUSH 0 // push 0
PUSH EAX // store Pos
XCHG EDX, EAX
MOV EAX, EBX
CALL Pos2Item // EAX = Idx'
XCHG ESI, EAX // ESI = Idx'
XOR EAX, EAX
{$IFDEF COMMANDACTIONS_OBJ}
MOV ECX, [EBX].fCommandActions
MOVZX ECX, [ECX].TCommandActionsObj.aGetItemLength
{$ELSE}
MOVZX ECX, [EBX].fCommandActions.aGetItemLength
{$ENDIF}
JECXZ @@ret_empty
PUSH ECX // push aGetItemLength
PUSH EBX
CALL Perform
TEST EAX, EAX
JZ @@ret_empty
PUSH EAX // save L
ADD EAX, 4
CALL System.@GetMem // GetMem( L+4 )
POP EDX // restore L
LEA ECX, [EDX+1]
MOV dword ptr [EAX], ECX
{$IFDEF COMMANDACTIONS_OBJ}
MOV ECX, [EBX].fCommandActions
MOVZX ECX, [ECX].TCommandActionsObj.aGetItemText
{$ELSE}
MOVZX ECX, [EBX].fCommandActions.aGetItemText
{$ENDIF}
JECXZ @@ret_buf
PUSH EDX // save L
//MOV word ptr [EAX], DX
PUSH EAX
PUSH EAX // push Buf
PUSH ESI // push Idx
PUSH ECX // push aGetItemText
PUSH EBX
CALL Perform
POP EAX
POP EDX
@@ret_buf:
MOV byte ptr [EAX + EDX], 0 // Buf[ L ] := #0
@@ret_empty: // EAX = 0
XCHG EDX, EAX
MOV EAX, EDI
PUSH EDX
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
POP ECX
JECXZ @@exit
XCHG EAX, ECX
CALL System.@FreeMem
@@exit:
MOV ESP, EBP
POP EBP
POP EBX
POP EDI
POP ESI
end;
{$ELSE ASM_VERSION} //Pascal
function TControl.GetItems(Idx: Integer): KOLString;
var L, Pos: Integer;
Buf: PKOLChar;
begin
Result := '';
Pos := Item2Pos( Idx );
Idx := Pos2Item( Pos );
if fCommandActions.aGetItemLength <> 0 then
L := Perform( fCommandActions.aGetItemLength, Pos, 0 )
else
Exit;
if L = 0 then Exit;
GetMem( Buf, (L + 4) * SizeOf( KOLChar ) );
PDWORD( Buf )^ := L + 1;
if fCommandActions.aGetItemText <> 0 then
Perform( fCommandActions.aGetItemText, Idx, Integer( Buf ) );
Buf[ L ] := #0;
Result := Buf;
FreeMem( Buf );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
procedure TControl.SetItems(Idx: Integer; const Value: AnsiString);
asm
PUSH EDI
PUSH EBX
XCHG EBX, EAX
XCHG EDI, EDX // EDI = Idx
CALL ECX2PChar
PUSH ECX // @Value[1]
{$IFDEF COMMANDACTIONS_OBJ}
MOV ECX, [EBX].fCommandActions
MOVZX ECX, [ECX].TCommandActionsObj.aSetItemText
{$ELSE}
MOVZX ECX, [EBX].fCommandActions.aSetItemText
{$ENDIF}
JECXZ @@1
PUSH 0
PUSH ECX
MOV EDX, EDI
MOV EAX, EBX
CALL Item2Pos
PUSH EAX // store Strt
MOV EDX, EDI
INC EDX
MOV EAX, EBX
CALL Item2Pos
POP EDX // EDX = Strt
SUB EAX, EDX
PUSH EAX // store L
MOV EAX, EBX
CALL SetSelStart
POP EDX // EDX = L
PUSH EBX // prepare @Self for Perform
XCHG EAX, EBX
CALL SetSelLength
// @Value[1] already in stack,
// 0 already in stack
// aSetItemText already in stack
// @Self already in stack
CALL Perform
JMP @@exit
@@1: // @Value[1] in stack already
POP EDX
{$IFDEF COMMANDACTIONS_OBJ}
MOV ECX, [EBX].fCommandActions
MOVZX ECX, [ECX].TCommandActionsObj.aDeleteItem
{$ELSE}
MOVZX ECX, [EBX].fCommandActions.aDeleteItem
{$ENDIF}
JECXZ @@exit
{$IFNDEF NOT_FIX_CURINDEX}
PUSH ESI
PUSH EBP
PUSH EDX
MOV EAX, EBX // +AK
CALL GetCurIndex // +AK
XCHG ESI, EAX // ESI = TmpCurIdx
MOV EAX, EBX
MOV EDX, EDI
CALL GetItemData
XCHG EBP, EAX // EBP = TmpData
MOV EDX, EDI
MOV EAX, EBX
CALL Delete
MOV EAX, EBX // *AK
MOV EDX, EDI
POP ECX
CALL Insert
MOV ECX, EBP // ECX = TmpData
MOV EDX, EDI
MOV EAX, EBX
CALL SetItemData
XCHG EAX, EBX // +AK
MOV EDX, ESI // +AK
CALL SetCurIndex // +AK
POP EBP
POP ESI
{$ELSE NOT_FIX_CURINDEX}
PUSH EDX
MOV EDX, EDI
MOV EAX, EBX
CALL Delete
XCHG EAX, EBX
XCHG EDX, EDI
POP ECX
CALL Insert
{$ENDIF NOT_FIX_CURINDEX}
@@exit:
POP EBX
POP EDI
end;
{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetItems(Idx: Integer; const Value: KOLString);
var Strt, L : DWORD;
{$IFNDEF NOT_FIX_CURINDEX}
TmpCurIdx: Integer; // AK - Andrzey Kubasek
TmpData: DWORD;
{$ENDIF NOT_FIX_CURINDEX}
begin
if fCommandActions.aSetItemText <> 0 then
begin
Strt := Item2Pos( Idx );
L := Item2Pos( Idx + 1 ) - Strt;
SelStart := Strt;
SelLength := L;
Perform( fCommandActions.aSetItemText, 0, Integer( PKOLChar( Value ) ) );
end
else
if fCommandActions.aDeleteItem <> 0 then
begin
{$IFNDEF NOT_FIX_CURINDEX}
TmpCurIdx := CurIndex; // +AK
TmpData := ItemData[ Idx ];
{$ENDIF}
Delete( Idx );
Insert( Idx, Value );
{$IFNDEF NOT_FIX_CURINDEX}
CurIndex := TmpCurIdx; //+AK
ItemData[ Idx ] := TmpData;
{$ENDIF}
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetItemsCount: Integer;
begin
Result := 0;
{$IFDEF DEBUG}
try
{$ENDIF}
if fCommandActions.aGetCount = 0 then Exit;
Result := Perform( fCommandActions.aGetCount, 0, 0 );
{$IFDEF DEBUG}
except
asm
int 3
end;
end;
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
procedure TControl.SetItemsCount(const Value: Integer);
begin
if fCommandActions.aSetCount = 0 then Exit;
Perform( fCommandActions.aSetCount, Value, 0 );
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
function TControl.SavePosition: TEditPositions;
var {$IFNDEF NOT_USE_RICHEDIT}
p: TPoint;
{$ENDIF USE_RICHEDIT}
i: Integer;
begin
Result.SelStart := SelStart;
Result.SelLength := SelLength;
{$IFNDEF NOT_USE_RICHEDIT}
if {$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}
function TControl.Add(const S: KOLString): Integer;
asm
PUSH EBX
MOV EBX, EAX // EBX = @Self
{$IFDEF COMMANDACTIONS_OBJ}
MOV ECX, [EBX].fCommandActions
MOVZX ECX, [ECX].TCommandActionsObj.aAddItem
{$ELSE}
MOVZX ECX, [EBX].fCommandActions.aAddItem // ECX = aAddItem
{$ENDIF}
JECXZ @@chk_addtext
CALL EDX2PChar
PUSH EDX
PUSH 0
PUSH ECX
PUSH EBX
CALL Perform
PUSH EAX
MOV EAX, EBX
CALL TControl.GetItemsCount
XCHG EAX, ECX
LOOP @@ret_EAX
XCHG EAX, EBX
INC ECX
XOR EDX, EDX
CALL TControl.SetItemSelected
@@ret_EAX:
POP EAX
JMP @@exit
@@chk_addtext:
{$IFDEF COMMANDACTIONS_OBJ}
MOV ECX, [EBX].fCommandActions
MOV ECX, [ECX].TCommandActionsObj.aAddText
{$ELSE}
MOV ECX, [EBX].fCommandActions.aAddText
{$ENDIF}
JECXZ @@add_text_simple
CALL ECX
JMP @@exit_0
@@add_text_simple:
LEA EAX, [EBX].fCaption
CALL System.@LStrCat
MOV EDX, [EBX].fCaption
MOV EAX, EBX
CALL SetCaption
@@exit_0:
XOR EAX, EAX
@@exit:
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function TControl.Add(const S: KOLString): Integer;
begin
if fCommandActions.aAddItem <> 0 then
begin
Result := Perform( fCommandActions.aAddItem, 0, Integer( PKOLChar( S ) ) );
if Count = 1 then
ItemSelected[ 0 ] := True;
end
else
begin
if Assigned( fCommandActions.aAddText ) then
fCommandActions.aAddText( @Self, S )
else
Text := Text + S;
Result := 0;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.Delete(Idx: Integer);
begin
if fCommandActions.aDeleteItem <> 0 then
Perform( fCommandActions.aDeleteItem, Idx, 0 );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function TControl.Insert(Idx: Integer; const S: AnsiString): Integer;
asm
CALL ECX2PChar
PUSH ECX
{$IFDEF COMMANDACTIONS_OBJ}
MOV ECX, [EAX].fCommandActions
MOVZX ECX, [ECX].TCommandActionsObj.aInsertItem
{$ELSE}
MOVZX ECX, [EAX].fCommandActions.aInsertItem
{$ENDIF}
JECXZ @@exit_1
PUSH EDX
PUSH ECX
PUSH EAX
CALL Perform
RET
@@exit_1:OR EAX, -1
POP ECX
end;
{$ELSE ASM_VERSION} //Pascal
function TControl.Insert(Idx: Integer; const S: KOLString): Integer;
begin
if fCommandActions.aInsertItem <> 0 then
Result := Perform( fCommandActions.aInsertItem, Idx, Integer( PKOLChar( S ) ) )
else
Result := -1;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetItemSelected(ItemIdx: Integer): Boolean;
var SS: Integer;
begin
if fCommandActions.aGetSelected <> 0 then
begin
SS := Perform( fCommandActions.aGetSelected, ItemIdx, LVIS_SELECTED );
{ Though it is written in docs that for combobox lParam for CB_GETCURSEL
is not used and _must_ be 0, therefore this code is working for
combobox too. }
if fCommandActions.aGetSelected <> CB_GETCURSEL then
ItemIdx := 1;
Result := SS = ItemIdx;
end
else
begin
SS := SelStart;
Result := (ItemIdx >= SS) and (ItemIdx < SS + SelLength);
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetItemSelected(ItemIdx: Integer; const Value: Boolean);
var SR: TCharRange;
begin
if fCommandActions.aSetSelected <> 0 then
Perform( fCommandActions.aSetSelected, Integer( Value ), ItemIdx )
else
if fCommandActions.aSetCurrent <> 0 then
Perform( fCommandActions.aSetCurrent, ItemIdx, 0 )
else
if fCommandActions.aSetSelRange <> 0 then
Perform( fCommandActions.aSetSelRange, ItemIdx, ItemIdx )
else
if fCommandActions.aExSetSelRange <> 0 then
begin
SR.cpMin := ItemIdx;
SR.cpMax := ItemIdx;
Perform( fCommandActions.aExSetSelRange, 0, Integer( @SR ) );
end
else
begin // for ImageShow: set the index and invalidate the control
FCurIndex := ItemIdx;
Invalidate;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetCtl3D(const Value: Boolean);
begin
//fCtl3D := Value;
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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.Shift(dX, dY: Integer): PControl;
begin
Left := fBoundsRect.Left + dX;
Top := fBoundsRect.Top + dY;
Result := @Self;
end;
{$ENDIF ASM_VERSION}
procedure SetKeyEvent( 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 ASM_VERSION} //Pascal
function CollectTabControls( Form: PControl ): PList;
var R: PList;
function CollectTab( P: PControl ): Boolean;
var I, J: Integer;
C, D: PControl;
begin
Result := FALSE;
for I := 0 to P.fChildren.fCount - 1 do
begin
C := P.fChildren.{$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 ASM_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 ASM_VERSION} //Pascal
procedure Tabulate2Next( Form: PControl; Dir: Integer );
var CL : PList;
I, J : Integer;
Ctrl1, Ctrl2, C : PControl;
begin
CL := CollectTabControls( Form );
I := 0;
C := Form.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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function Tabulate2Control( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
var Form: PControl;
begin
Result := False;
case Key of
VK_TAB: if not (tkTab in Self_.fLookTabKeys) then exit;
VK_LEFT, VK_RIGHT: if not (tkLeftRight in Self_.fLookTabKeys) then exit;
VK_UP, VK_DOWN: if not (tkUpDown in Self_.fLookTabKeys) then exit;
VK_NEXT, VK_PRIOR: if not (tkPageUpPageDn in Self_.fLookTabKeys) then exit;
else Exit;
end;
Result := True;
if checkOnly then Exit;
Form := Self_.ParentForm;
case Key of
VK_TAB:
if GetKeyState( VK_SHIFT ) < 0 then
Tabulate2Next( Form, -1 )
else
Tabulate2Next( Form, 1 );
VK_RIGHT, VK_DOWN, VK_NEXT: Tabulate2Next( Form, 1 );
VK_LEFT, VK_UP, VK_PRIOR: Tabulate2Next( Form, -1 );
end;
end;
{$ENDIF ASM_VERSION}
{$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 ASM_VERSION} //Pascal
function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
label search_tabcontrol;
var Form: PControl;
CL : PList;
I : Integer;
CurCtrl, Ctrl, Found : PControl;
MinDist, Dist: Integer;
R, R1 : TRect;
begin
Result := False;
case Key of
VK_TAB: if not (tkTab in Self_.fLookTabKeys) then exit;
VK_LEFT, VK_RIGHT: if not (tkLeftRight in Self_.fLookTabKeys) then exit;
VK_UP, VK_DOWN: if not (tkUpDown in Self_.fLookTabKeys) then exit;
VK_NEXT, VK_PRIOR: if not (tkPageUpPageDn in Self_.fLookTabKeys) then exit;
else exit;
end;
Result := True;
if checkOnly then Exit;
Form := Self_.ParentForm;
if Key = VK_TAB then
if GetKeyState( VK_SHIFT ) < 0 then
Tabulate2Next( Form, -1 )
else
Tabulate2Next( Form, 1 )
else
begin
CL := CollectTabControls( Form );
I := CL.IndexOf( Form.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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.Tabulate: PControl;
var F : PControl;
begin
Result := @Self;
F := ParentForm;
if F = nil then Exit;
F.PP.fGotoControl := Tabulate2Control;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.TabulateEx: PControl;
var F : PControl;
begin
Result := @Self;
F := ParentForm;
if F = nil then Exit;
F.PP.fGotoControl := Tabulate2ControlEx;
end;
{$ENDIF ASM_VERSION}
function WndProcMouseTransparent( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
Result := FALSE;
if Msg.message = WM_NCHITTEST then
begin
Rslt := HTTRANSPARENT;
Result := TRUE;
end;
end;
function TControl.MouseTransparent: PControl;
begin
AttachProc( WndProcMouseTransparent );
Result := @ Self;
end;
procedure TControl.GotoControl(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 ASM_VERSION} //Pascal
function TControl.GetCurIndex: Integer;
var I, J: Integer;
begin
Result := fCurIndex;
if fCommandActions.aGetCurrent = 0 then
Exit;
I := 0;
if fCommandActions.aGetCurrent = EM_LINEINDEX then
Dec( I );
J := 0;
if fCommandActions.aGetCurrent = LVM_GETNEXTITEM then
begin
J := 2 {LVNI_SELECTED};
Dec( I );
end;
Result := Perform( fCommandActions.aGetCurrent, I, J );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_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 ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE TControl.SetTextAlign(const Value: TTextAlign);
BEGIN
IF fTextAlign = Value THEN Exit;
fTextAlign := Value;
IF Assigned( fSetTextAlign ) THEN
fSetTextAlign( @ Self );
END;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_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 ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
PROCEDURE TControl.SetVerticalAlign(const Value: TVerticalAlign);
BEGIN
if fVerticalAlign = Value then Exit;
fVerticalAlign := Value;
if Assigned( fSetTextAlign ) then
fSetTextAlign( @ Self );
END;
{$ENDIF GTK}
{$ENDIF _X_}
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.Dc2Canvas( Sender: PCanvas ): HDC;
begin
if fPaintDC <> 0 then
begin
Result := fPaintDC;
Sender.SetHandle( Result );
Sender.fIsPaintDC := True;
end
else
begin
if Sender.fHandle <> 0 then
Result := Sender.fHandle
else
Result := GetDC( GetWindowHandle );
end;
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetCanvas: PCanvas;
begin
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 ASM_VERSION}
{$ENDIF GDI}
{$IFDEF _X_}
{$IFDEF GTK}
FUNCTION TControl.ProvideCanvasHandle( Sender: PCanvas ): HDC;
TYPE PPGdkGC = ^PGdkGC;
VAR Array_gc: PPGdkGC;
BEGIN
IF fInBkPaint THEN Array_gc := @ fEventboxHandle.style.bg_gc[ 0 ]
ELSE 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
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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_VERSION} //Pascal
function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
var Self_: PTrayIcon;
I : Integer;
begin
Result := False;
case Msg.message of
CM_TRAYICON:
begin
Self_ := Pointer( Msg.wParam );
if Assigned( Self_.FOnMouse ) then
Self_.FOnMouse( @Self_, Msg.lParam );
Rslt := 0;
Result := True;
end;
WM_CLOSE:
if Msg.hwnd = Control.fHandle then
begin
if FTrayItems <> nil then // ?????????????????
for I := FTrayItems.Count - 1 downto 0 do
begin
Self_ := FTrayItems.Items[ I ];
if not Self_.FNoAutoDeactivate then
if Self_.FControl = Control then
Self_.Active := False;
end;
end;
end;
end;
{$ENDIF ASM_VERSION}
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 ASM_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 ASM_VERSION}
var fRecreateMsg: DWORD;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function WndProcRecreateTrayIcons( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var I: Integer;
TI: PTrayIcon;
begin
if Msg.message = fRecreateMsg then
begin
for I := 0 to FTrayItems.fCount - 1 do
begin
TI := FTrayItems.Items[ I ];
if TI.fAutoRecreate then
if TI.fActive then
begin
TI.fActive := False;
TI.Active := True;
end;
end;
end;
Result := False;
end;
{$ENDIF ASM_VERSION}
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 ASM_VERSION} //Pascal
procedure TTrayIcon.SetAutoRecreate(const Value: Boolean);
begin
fAutoRecreate := Value;
FControl.ParentForm.AttachProc( WndProcRecreateTrayIcons );
fRecreateMsg := RegisterWindowMessage( TaskbarCreatedMsg );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
destructor TTrayIcon.Destroy;
begin
Active := False;
if fIcon <> 0 then
DestroyIcon( fIcon );
FTrayItems.Remove( @ Self );
if FTrayItems.Count = 0 then
Free_And_Nil( FTrayItems );
FTooltip := '';
inherited;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TTrayIcon.SetIcon(const Value: HIcon);
var Cmd : DWORD;
begin
if FIcon = Value then Exit;
// Previous icon is not destroying. This is normal for
// icons, loaded from resources using LoadIcon. For icons,
// created using CreateIconIndirect, You have to call
// DestroyIcon manually.
Cmd := NIM_MODIFY;
if FIcon = 0 then
Cmd := NIM_ADD;
FIcon := Value;
if FActive then
SetTrayIcon( Cmd );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
procedure TTrayIcon.SetTooltip(const Value: AnsiString);
asm
PUSH EBX
XCHG EBX, EAX
MOV EAX, [EBX].fTooltip
PUSH EDX
CALL System.@LStrCmp
POP EDX
JE @@exit
LEA EAX, [EBX].fTooltip
CALL System.@LStrAsg
CMP [EBX].fActive, 0
JE @@exit
XOR EDX, EDX
INC EDX // EDX = NIM_MODIFY
XCHG EAX, EBX
CALL SetTrayIcon
@@exit:
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
procedure TTrayIcon.SetTooltip(const Value: KOLString);
begin
if FTooltip = Value then Exit;
FTooltip := Value;
if Active then
SetTrayIcon( NIM_MODIFY );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
procedure TTrayIcon.SetTrayIcon(const Value: DWORD);
const sz_tid = sizeof( TNotifyIconData );
asm
CMP [AppletTerminated], 0
JE @@1
MOV DL, NIM_DELETE
@@1:
PUSH EBX
PUSH ESI
MOV ESI, EAX
MOV EBX, EDX
XOR ECX, ECX
PUSH ECX
ADD ESP, -60
MOV EDX, [ESI].fToolTip
CALL EDX2PChar
MOV EAX, ESP
MOV CL, 63
CALL StrLCopy
PUSH [ESI].fIcon
PUSH CM_TRAYICON
XOR EDX, EDX
CMP BL, NIM_DELETE
JE @@2
MOV DL, NIF_ICON or NIF_MESSAGE or NIF_TIP
@@2: PUSH EDX
PUSH ESI
MOV EAX, [ESI].FWnd
TEST EAX, EAX
JNZ @@3
MOV EAX, [ESI].fControl
MOV EAX, [EAX].TControl.fHandle
@@3:
PUSH EAX
PUSH sz_tid
PUSH ESP
PUSH EBX
CALL Shell_NotifyIcon
ADD ESP, sz_tid
POP ESI
POP EBX
@@exit:
end;
{$ELSE ASM_VERSION} //Pascal
procedure TTrayIcon.SetTrayIcon(const Value: DWORD);
var NID : {$IFDEF UNICODE_CTRLS} TNotifyIconDataW {$ELSE} TNotifyIconData {$ENDIF};
L : Integer;
V : DWORD;
begin
V := Value;
if AppletTerminated then
V := NIM_DELETE;
if Wnd <> 0 then
NID.Wnd := Wnd
else
NID.Wnd := FControl.fHandle;
NID.cbSize := Sizeof( NID );
NID.uID := DWORD( @Self );
NID.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
if V = NIM_DELETE then
NID.uFlags := 0;
NID.uCallbackMessage := CM_TRAYICON;
NID.hIcon := FIcon;
L := Length( FToolTip );
if L > 63 then L := 63;
Move( FTooltip[1], NID.szTip[0], Min( 63, L )*SizeOf(KOLChar) );
NID.szTip[ L ] := #0;
Shell_NotifyIcon( V, @NID );
end;
{$ENDIF ASM_VERSION}
{ -- JustOne -- }
var JustOneMutex: THandle;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
begin
Result := False;
case Msg.message of
WM_CLOSE, WM_NCDESTROY:
if LongBool( JustOneMutex ) and (Control.Handle = Msg.hwnd) then
begin
CloseHandle( JustOneMutex );
JustOneMutex := 0;
end;
end;
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
function JustOne( Wnd: PControl; const Identifier : KOLString ) : Boolean;
var CritSecMutex : THandle;
DW : Longint;
begin
Result := False;
CritSecMutex := CreateMutex( nil, True, nil );
if CritSecMutex = 0 then Exit;
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 ASM_VERSION}
{ JustOneNotify }
var
OnAnotherInstance: TOnAnotherInstance;
JustOneMsg: DWORD;
{$IFDEF ASM_UNICODE}
function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
asm
PUSH EBP
MOV EBP, ESP
PUSHAD
CALL WndProcJustOne
POPAD
XOR EAX, EAX
PUSH ECX
MOV ECX, [EDX].TMsg.message
SUB ECX, [JustOneMsg]
POP ECX
JNE @@exit
MOV [ECX], EAX
CMP [OnAnotherInstance].TMethod.Code, EAX
JE @@exit_1
//MOV EAX, (MAX_PATH + 3) and 0FFFFCh
MOV AH, 2
SUB ESP, EAX
MOV ECX, ESP
PUSH EAX
PUSH ECX
PUSH [EDX].TMsg.lParam
CALL GetWindowText
MOV EDX, ESP
PUSH 0
MOV EAX, ESP
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
MOV EDX, [ESP]
MOV EAX, [OnAnotherInstance].TMethod.Data
CALL [OnAnotherInstance].TMethod.Code
MOV EAX, ESP
CALL System.@LStrClr
@@exit_1:
MOV AL, 1
@@exit:
MOV ESP, EBP
POP EBP
end;
{$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 ASM_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}
function JustOneNotify( Wnd: PControl; const Identifier : AnsiString;
const aOnAnotherInstance: TOnAnotherInstance ) : Boolean;
asm
PUSHAD
MOV EBP, ESP
XCHG EAX, EDX
PUSH EAX
CALL System.@LStrLen
POP EDX
ADD EAX, EAX
SUB ESP, EAX
MOV EAX, ESP
CALL StrPCopy
PUSH '.ega'
PUSH 'sseM'
PUSH ESP
CALL RegisterWindowMessage
MOV [JustOneMsg], EAX
TEST EAX, EAX
MOV ESP, EBP
POPAD
JE @@exit_f
PUSHAD
CALL JustOne
DEC AL
POPAD
JZ @@exit_t
PUSH EBX
XCHG EBX, EAX
XOR EDX, EDX
XCHG [EBX].TControl.fCaption, EDX
PUSH EDX
CALL GetCommandLine
XCHG EDX, EAX
LEA EAX, [EBX].TControl.fCaption
{$IFDEF _D2009orHigher}
PUSH ECX
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
{$IFDEF _D2009orHigher}
POP ECX
{$ENDIF}
MOV EAX, EBX
MOV EDX, [EBX].TControl.fCaption
CALL TControl.SetCaption
MOV EAX, EBX
CALL TControl.GetWindowHandle
TEST EAX, EAX
JZ @@rest_cap
PUSH BSM_APPLICATIONS
MOV EDX, ESP
PUSH EAX
PUSH 0
PUSH [JustOneMsg]
PUSH EDX
PUSH BSF_QUERY or BSF_IGNORECURRENTTASK
CALL BroadcastSystemMessage
POP EDX
@@rest_cap:
LEA EAX, [EBX].TControl.fCaption
CALL System.@LStrClr
POP EDX
MOV [EBX].TControl.fCaption, EDX
MOV EAX, EBX
CALL TControl.SetCaption
POP EBX
@@exit_f:
XOR EAX, EAX
JMP @@exit
@@exit_t:
PUSHAD
LEA ESI, [aOnAnotherInstance]
LEA EDI, [OnAnotherInstance]
MOVSD
MOVSD
MOV EDX, offset[WndProcJustOneNotify]
CALL TControl.AttachProc
POPAD
MOV AL, 1
@@exit:
end;
{$ELSE ASM_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 ASM_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 ASM_VERSION} //Pascal
destructor TStrList.Destroy;
begin
Clear;
inherited;
end;
{$ENDIF ASM_VERSION}
procedure TStrList.Init;
begin
{$IFDEF CALL_INHERITED}
inherited;
{$ENDIF}
fNameDelim := DefaultNameDelimiter;
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TStrList.Add(const S: Ansistring): integer;
begin
Result := fCount;
Insert( Result, S );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TStrList.AddStrings(Strings: PStrList);
begin
SetText( Strings.Text, True );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TStrList.Assign(Strings: PStrList);
begin
Clear;
AddStrings( Strings );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TStrList.Clear;
var I: Integer;
begin
if fCount > 0 then
for I := fList.Count - 1 downto 0 do
Delete( I );
fList.Free;
fList := nil;
fCount := 0;
if fTextBuf <> nil then
begin
FreeMem( fTextBuf );
fTextBuf := nil;
fTextSiz := 0;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION} {$DEFINE TStrList_Delete_ASM} {$ENDIF}
{$IFDEF TLIST_FAST} {$UNDEF TStrList_Delete_ASM} {$ENDIF}
{$IFDEF TStrList_Delete_ASM}
{$ELSE ASM_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 ASM_VERSION}
procedure TStrList.DeleteLast;
begin
Delete( Count-1 );
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TStrList.Get(Idx: integer): Ansistring;
begin
if fList <> nil then
Result := PAnsiChar( fList.Items[ Idx ] )
else Result := '';
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
function TStrList.GetPChars(Idx: Integer): PAnsiChar;
begin
Result := PAnsiChar( fList.{$IFDEF TLIST_FAST}Items{$ELSE}fItems{$ENDIF}[ Idx ] )
end;
{$ENDIF ASM_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 ASM_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 ASM_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 ASM_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 ASM_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;
//Index := L;
if C < 0 then Index := -L;
{if L >= Count then
Dec( L );
Index := L;
if not Result then
Result := fCompareStrListFun( PAnsiChar( fList.Items[ L ] ),
PAnsiChar( S ) ) = 0;}
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 ASM_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 ASM_VERSION}
procedure TStrList.Move(CurIndex, NewIndex: integer);
begin
fList.MoveItem( CurIndex, NewIndex );
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TStrList.Put(Idx: integer; const Value: Ansistring);
begin
Delete( Idx );
Insert( Idx, Value );
end;
{$ENDIF ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_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 ASM_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;
//-- 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 );
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}
function TStrList.AppendToFile(const FileName: Ansistring): Boolean;
asm
PUSH EBX
MOV EBX, EDX
PUSH 0
MOV EDX, ESP
CALL GetTextStr
XCHG EAX, EBX
MOV EDX, ofOpenWrite or ofOpenAlways
CALL FileCreate
MOV EBX, EAX
INC EAX
JZ @@exit
DEC EAX
XOR EDX, EDX
XOR ECX, ECX
MOV CL, spEnd
CALL FileSeek
POP EAX
PUSH EAX
CALL System.@LStrLen
XCHG ECX, EAX
MOV EAX, EBX
POP EDX
PUSH EDX
CALL FileWrite
XCHG EAX, EBX
CALL FileClose
@@exit:
CALL RemoveStr
POP EBX
end;
{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_UNICODE}
function TStrList.LoadFromFile(const FileName: AnsiString): Boolean;
asm
PUSH EAX
XCHG EAX, EDX
MOV EDX, ofOpenRead or ofShareDenyWrite or ofOpenExisting
CALL FileCreate
INC EAX
JZ @@exit
DEC EAX
PUSH EBX
XCHG EBX, EAX
PUSH 0
PUSH EBX
CALL GetFileSize
XOR EDX, EDX
PUSH EDX
XCHG ECX, EAX
MOV EAX, ESP
PUSH ECX
{$IFDEF _D2}
CALL _LStrFromPCharLen
{$ELSE}
{$IFDEF _D2009orHigher}
PUSH EDX // ushort 0, CodePage?
{$ENDIF}
CALL System.@LStrFromPCharLen
{$ENDIF}
POP ECX
MOV EAX, EBX
POP EDX
PUSH EDX
CALL FileRead
XCHG EAX, EBX
CALL FileClose
POP EDX
POP EBX
POP EAX
PUSH EDX
XOR ECX, ECX
CALL SetText
CALL RemoveStr
PUSH EDX
MOV AL, 1
@@exit: POP EDX
end;
{$ELSE ASM_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 ASM_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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TStrList.MergeFromFile(const FileName: KOLString);
var TmpStream: PStream;
begin
TmpStream := NewReadFileStream( FileName );
LoadFromStream( TmpStream, True );
TmpStream.Free;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function TStrList.SaveToFile(const FileName: Ansistring): Boolean;
asm
PUSH EBX
PUSH EAX
XCHG EAX, EDX
MOV EDX, ofOpenWrite or ofCreateAlways
CALL FileCreate
INC EAX
JZ @@exit
DEC EAX
XCHG EBX, EAX
POP EAX
PUSH 0
MOV EDX, ESP
CALL GetTextStr
POP EAX
PUSH EAX
CALL System.@LStrLen
XCHG ECX, EAX
POP EDX
PUSH EDX
MOV EAX, EBX
CALL FileWrite
PUSH EBX
CALL SetEndOfFile
XCHG EAX, EBX
CALL FileClose
CALL RemoveStr
PUSH EDX
INC EAX
@@exit:
POP EDX
POP EBX
end;
{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$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;
{$IFDEF _D3orHigher}
function UTF8_2WideString( const s: AnsiString ): WideString;
var Buffer: PWideChar;
L: Integer;
begin
L := Length( s ) + 1;
GetMem( Buffer, L * 2 );
MultiByteToWideChar( CP_UTF8, 0, 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: WideString): 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): WideString;
begin
Result := PWideChar( fList.Items[ Idx ] );
end;
function TWStrList.GetPtrs(Idx: Integer): PWideChar;
begin
Result := fList.Items[ Idx ];
end;
function TWStrList.GetText: WideString;
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: WideString);
var P: Pointer;
begin
while Idx > Count do // by Misha Shar. a.k.a. kreit
fList.Add( nil );
GetMem( P, (Length( W ) + 1) * Sizeof(WideChar) );
fList.Insert( Idx, P );
WStrCopy( P, PWideChar( W ) );
end;
function TWStrList.LoadFromFile(const Filename: KOLString): Boolean;
begin
Clear;
Result := MergeFromFile( Filename );
end;
procedure TWStrList.LoadFromStream(Strm: PStream);
begin
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: WideString;
L: Integer;
begin
L := Strm.Size - Strm.Position;
Assert( L mod 1 = 0, 'Wide strings streams must be of even length in bytes.' );
if L = 0 then Exit;
SetLength( Buf, L div 2 );
Strm.Read( Buf[ 1 ], L );
{if Word( Buf[1] ) = $FEFF then
System.Delete( Buf, 1, 1 );}
Text := Text + Buf;
end;
procedure TWStrList.Move(IdxOld, IdxNew: Integer);
begin
fList.MoveItem( IdxOld, IdxNew );
end;
procedure TWStrList.Put(Idx: integer; const Value: WideString);
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: WideString);
var P: Pointer;
begin
while Idx > Count-1 do
fList.Add( nil );
if WStrLen( ItemPtrs[ Idx ] ) > Length( Value ) then // fixed by kreit
WStrCopy( ItemPtrs[ Idx ], PWideChar( Value ) )
else
begin
P := fList.Items[ Idx ];
if P <> nil then
if not ((P >= fText) and (P <= fText + fTextBufSz)) then
FreeMem( P );
GetMem( P, (Length( Value ) + 1) * Sizeof(WideChar) );
fList.Items[ Idx ] := P;
WStrCopy( P, PWideChar( Value ) );
end;
end;
procedure TWStrList.SetText(const Value: WideString);
var L, N: Integer;
P: PWideChar;
begin
Clear;
if Value = '' then Exit;
L := (Length( Value ) + 1) * Sizeof( WideChar );
GetMem( fText, L );
System.Move( Value[ 1 ], fText^, L );
fTextBufSz := Length( Value );
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: WideString ): 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: WideString ): 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: WideString;
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): WideString;
var s: WideString;
Q: PWideChar;
begin
s := ItemPtrs[ Idx ];
Q := WStrScan( PWideChar(s), fNameDelim );
Q^ := #0;
Result := PWideChar(s);
end;
function TWStrList.GetLineValue(Idx: Integer): WideString;
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: WideString);
begin
Items[ Idx ] := NV + fNameDelim + LineValue[ Idx ];
end;
procedure TWStrList.SetLineValue(Idx: Integer; const Value: WideString);
begin
Items[ Idx ] := LineName[ Idx ] + fNameDelim + Value;
end;
{ TWStrListEx }
function TWStrListEx.AddObject(const S: WideString; 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: WideString;
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 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 ASM_VERSION} //Pascal
procedure SortData( const Data: Pointer; const uNElem: Dword;
const CompareFun: TCompareEvent;
const SwapProc: TSwapEvent );
{ uNElem - number of elements to sort }
function Compare( const e1, e2 : DWord ) : Integer;
begin
Result := CompareFun( Data, e1 - 1, e2 - 1 );
end;
procedure Swap( const e1, e2 : DWord );
begin
SwapProc( Data, e1 - 1, e2 - 1 );
end;
procedure qSortHelp(pivotP: Dword; nElem: Dword);
label
TailRecursion,
qBreak;
var
leftP, rightP, pivotEnd, pivotTemp, leftTemp: Dword;
lNum: Dword;
retval: integer;
begin
TailRecursion:
if (nElem <= 2) then
begin
if (nElem = 2) then
begin
rightP := pivotP +1;
retval := Compare(pivotP,rightP);
if (retval > 0) then Swap(pivotP,rightP);
end;
exit;
end;
rightP := (nElem -1) + pivotP;
leftP := (nElem shr 1) + pivotP;
{ sort pivot, left, and right elements for "median of 3" }
retval := Compare(leftP,rightP);
if (retval > 0) then Swap(leftP, rightP);
retval := Compare(leftP,pivotP);
if (retval > 0) then
Swap(leftP, pivotP)
else
begin
retval := Compare(pivotP,rightP);
if retval > 0 then Swap(pivotP, rightP);
end;
if (nElem = 3) then
begin
Swap(pivotP, leftP);
exit;
end;
{ now for the classic Horae algorithm }
pivotEnd := pivotP + 1;
leftP := pivotEnd;
repeat
retval := Compare(leftP, pivotP);
while (retval <= 0) do
begin
if (retval = 0) then
begin
Swap(leftP, pivotEnd);
Inc(pivotEnd);
end;
if (leftP < rightP) then
Inc(leftP)
else
goto qBreak;
retval := Compare(leftP, pivotP);
end; {while}
while (leftP < rightP) do
begin
retval := Compare(pivotP, rightP);
if (retval < 0) then
Dec(rightP)
else
begin
Swap(leftP, rightP);
if (retval <> 0) then
begin
Inc(leftP);
Dec(rightP);
end;
break;
end;
end; {while}
until (leftP >= rightP);
qBreak:
retval := Compare(leftP,pivotP);
if (retval <= 0) then Inc(leftP);
leftTemp := leftP -1;
pivotTemp := pivotP;
while ((pivotTemp < pivotEnd) and (leftTemp >= pivotEnd)) do
begin
Swap(pivotTemp, leftTemp);
Inc(pivotTemp);
Dec(leftTemp);
end; {while}
lNum := (leftP - pivotEnd);
nElem := ((nElem + pivotP) -leftP);
if (nElem < lNum) then
begin
qSortHelp(leftP, nElem);
nElem := lNum;
end
else
begin
qSortHelp(pivotP, lNum);
pivotP := leftP;
end;
goto TailRecursion;
end; {qSortHelp }
begin
if (uNElem < 2) then exit; { nothing to sort }
qSortHelp(1, uNElem);
end;
{$ENDIF ASM_VERSION}
{$IFDEF _D3orHigher}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$ENDIF _D3orHigher}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
var I1, I2 : Integer;
begin
I1 := PInteger( DWORD( Sender ) + e1 * Sizeof( Integer ) )^;
I2 := PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;
Result := 0;
if I1 < I2 then Result := -1
else
if I1 > I2 then Result := 1;
end;
{$ENDIF ASM_VERSION}
function Compare2Integers( e1, e2: Integer ) : Integer;
begin
Result := e1-e2;
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
var I1, I2 : DWord;
begin
I1 := PDWORD( DWORD( Sender ) + e1 * Sizeof( Integer ) )^;
I2 := PDWORD( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;
Result := 0;
if I1 < I2 then Result := -1
else
if I1 > I2 then Result := 1;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}
function Compare2Dwords( e1, e2 : DWORD ) : Integer;
asm
SUB EAX, EDX
JZ @@exit
MOV EAX, 0
JB @@neg
INC EAX
INC EAX
@@neg:
DEC EAX
@@exit:
end;
{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD );
var Tmp : Integer;
begin
Tmp := PInteger( DWORD( Sender ) + e1 * SizeOf( Integer ) )^;
PInteger( DWORD( Sender ) + e1 * Sizeof( Integer ) )^ :=
PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;
PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^ := Tmp;
end;
{$ENDIF ASM_VERSION}
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 -- }
{$IFDEF ASM_VERSION}
function _NewStatusbar( AParent: PControl ): PControl;
const STAT_CLS_NAM: PKOLChar = STATUSCLASSNAME;
asm
PUSH 0
{$IFDEF COMMANDACTIONS_OBJ}
PUSH OTHER_ACTIONS
{$ELSE}
PUSH 0
{$ENDIF}
{$IFDEF USE_FLAGS}
TEST [EAX].TControl.fFlagsG3, (1 shl G3_SizeGrip)
{$ELSE}
CMP [EAX].TControl.fSizeGrip, 0
{$ENDIF}
MOV ECX, WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or 3 or WS_VISIBLE
JZ @@1
INC CH
AND CL, not 3
@@1:
MOV EDX, [STAT_CLS_NAM]
CALL _NewCommonControl
PUSH EBX
XCHG EBX, EAX
PUSH EDI
LEA EDI, [EBX].TControl.fBoundsRect
XOR EAX, EAX
STOSD
STOSD
STOSD
STOSD
MOV [EBX].TControl.fAlign, caBottom
{$IFDEF USE_FLAGS}
OR [EBX].TControl.fFlagsG4, 1 shl G4_NotUseAlign
{$ELSE}
INC [EBX].TControl.fNotUseAlign
{$ENDIF}
POP EDI
MOV EAX, EBX
CALL InitCommonControlSizeNotify
XCHG EAX, EBX
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function _NewStatusbar( AParent: PControl ): PControl;
var Style: DWORD;
begin
Style := WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or 3 or WS_VISIBLE;
{if AParent.CanResize then
Style := Style or SBARS_SIZEGRIP;}
if {$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 ASM_VERSION}
{$IFDEF ASM_UNICODE}
procedure TControl.SetStatusText(Index: Integer; const Value: KOLString);
asm
PUSHAD
MOV EBX, EDX // EBX = Index
MOV ESI, EAX // ESI = @Self
PUSH Value // prepare value for call at the end of procedure
PUSH EBX // prepare Index for call at the end of procedure
MOV ECX, [ESI].fStatusCtl
MOV EBP, ECX
INC ECX
LOOP @@status_created
CALL GetClientHeight
PUSH EAX // ch = old client height
MOV EAX, ESI
CALL _NewStatusBar
MOV [ESI].fStatusCtl, EAX
XCHG EBP, EAX
XOR EDX, EDX
PUSH EDX
INC DH
DEC EDX
CMP EBX, EDX
SETZ DL
NEG EDX
PUSH EDX
PUSH SB_SIMPLE
PUSH EBP
CALL TControl.Perform
ADD ESP, -16
PUSH ESP
PUSH [EBP].fHandle
CALL GetWindowRect
POP EAX
POP EDX
POP EAX
POP EAX
SUB EAX, EDX
MOV [ESI].fClientBottom, AL
POP EDX // ch
PUSH 0
PUSH 0
PUSH WM_SIZE
PUSH EBP
MOV EAX, ESI
CALL TControl.SetClientHeight
CALL TControl.Perform
@@status_created:
CMP EBX, 255
JGE @@not_simple
PUSH 0
PUSH 0
PUSH SB_GETPARTS
PUSH EBP
CALL Perform
CMP EAX, EBX
JG @@reset_simple
MOV EAX, ESI
CALL GetWidth
CDQ
MOV ECX, EBX
INC ECX
IDIV ECX
MOV EDX, EAX
ADD ESP, -1024
///////////////////
MOV ECX, EBX
MOV EDI, ESP
JECXZ @@2
@@store_loo:
STOSD
ADD EAX, EDX
LOOP @@store_loo
@@2:
OR dword ptr [ESP+EBX*4], -1
PUSH ESP
INC EBX
PUSH EBX
PUSH SB_SETPARTS
PUSH EBP
CALL Perform
////////////////////
ADD ESP, 1024
@@reset_simple:
PUSH 0
PUSH 0
PUSH SB_SIMPLE
PUSH EBP
CALL Perform
@@not_simple:
PUSH SB_SETTEXT
PUSH EBP
CALL Perform
POPAD
end;
{$ELSE ASM_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 ASM_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 ASM_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 := //SendMessage( fStatusWnd, Msg, I, 0 ) and $FFFF;
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;
//Result := fStatusTxt;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.RemoveStatus;
var ch: Integer;
begin
if fStatusCtl = nil then Exit;
ch := ClientHeight;
//fStatusWnd := 0;
fStatusCtl.Free;
fStatusCtl := nil;
fClientBottom := 0;
ClientHeight := ch;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.StatusPanelCount: Integer;
begin
Result := 0;
//if fStatusWnd = 0 then Exit;
if fStatusCtl = nil then Exit;
Result := //SendMessage( fStatusWnd, SB_GETPARTS, 0, 0 );
fStatusCtl.Perform( SB_GETPARTS, 0, 0 );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetStatusPanelX(Idx: Integer): Integer;
var Buf: array[0..254] of Integer;
N : Integer;
begin
Result := 0;
//if fStatusWnd = 0 then Exit;
if fStatusCtl = nil then Exit;
N := //SendMessage( fStatusWnd, SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) );
fStatusCtl.Perform( SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) );
if N <= Idx then Exit;
Result := Buf[ Idx ];
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.SetStatusPanelX(Idx: Integer; const Value: Integer);
var Buf: array[0..254] of Integer;
N : Integer;
begin
//if fStatusWnd = 0 then Exit;
if fStatusCtl = nil then Exit;
N := //SendMessage( fStatusWnd, SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) );
fStatusCtl.Perform( SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) );
if N <= Idx then Exit;
Buf[ Idx ] := Value;
//SendMessage( fStatusWnd, SB_SETPARTS, N, Integer( @Buf[ 0 ] ) );
fStatusCtl.Perform( SB_SETPARTS, N, Integer( @Buf[ 0 ] ) );
end;
{$ENDIF ASM_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}
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;
begin
Result := LoadBitmap( Instance, Rsrc );
MasterObj.Add2AutoFreeEx( TObjectMethod( MakeMethod( Pointer( Result ), @ FreeBmp ) ) );
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;
begin
Result := -1;
if not HandleNeeded then Exit;
Result := ImageList_AddMasked( FHandle, Bmp, Color2RGB( Color ) );
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 ASM_VERSION} //Pascal
destructor TImageList.Destroy;
begin
Clear;
if fNext <> nil then
fNext.fPrev := fPrev;
if fPrev <> nil then
fPrev.fNext := fNext;
if fControl <> nil then
begin
if PControl( fControl ).fImageList = @Self then
PControl( fControl ).fImageList := fNext;
{$IFDEF USE_AUTOFREE4CONTROLS}
PControl(fControl).RemoveFromAutoFree( @ Self );
{$ENDIF}
end;
inherited;
end;
{$ENDIF ASM_VERSION}
procedure TImageList.Draw(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
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TImageList.GetHandle: THandle;
begin
HandleNeeded;
Result := FHandle;
end;
{$ENDIF ASM_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 ASM_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 ASM_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 ASM_VERSION} //Pascal
function TImageList.LoadBitmap(ResourceName: PKOLChar;
TranspColor: TColor): Boolean;
var NewHandle : THandle;
TranColr: TColor;
begin
TranColr := TranspColor;
if TranColr = clNone then TranColr := TColor( CLR_NONE )
else TranColr := Color2RGB( TranColr );
NewHandle := ImageList_LoadBitmap( hInstance, ResourceName,
ImgWidth, AllocBy, TranColr );
//ImageList_GetIconSize( NewHandle, fImgWidth, fImgHeight );
Result := NewHandle <> 0;
if Result then
Handle := NewHandle;
ImageList_GetIconSize( fHandle, FImgWidth, FImgHeight );
end;
{$ENDIF ASM_VERSION}
function TImageList.LoadFromFile(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 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;
//if FHandle = 0 then Exit;
L := ImageList_Merge( FHandle, Idx, ImgList2.Handle, Idx2, X, Y );
if L <> 0 then
begin
Result := NewImageList( fControl );
Result.Handle := L;
end;
end;
function TImageList.Replace(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 image list 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 ASM_VERSION} //Pascal
procedure TImageList.SetHandle(const Value: THandle);
begin
if FHandle = Value then Exit;
if (FHandle <> 0) and not FShareImages then
ImageList_Destroy( FHandle );
FHandle := Value;
if FHandle <> 0 then
ImageList_GetIconSize( FHandle, FImgWidth, FImgHeight )
else
begin
FImgWidth := 0;
FImgHeight := 0;
end;
//FBkColor := ImageList_GetBkColor( FHandle );
end;
{$ENDIF ASM_VERSION}
procedure TImageList.SetImgHeight(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;
I: Integer;
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;
I := Perform( LVM_SETITEM, 0, Integer( @LVI ) );
if (I = 0) and (Col = 0) then
Assert( False, 'Can not set item ' );
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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.Postmsg(msgcode: DWORD; wParam, lParam: Integer): Boolean; stdcall;
begin
Result := PostMessage( GetWindowHandle, msgcode, wParam, lParam );
end;
{$ENDIF ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.GetChildCount: Integer;
begin
Result := fChildren.fCount;
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
procedure TControl.LVDelete(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 ASM_VERSION} //Pascal
procedure TControl.SetItemVal(Item: Integer; const Index: Integer; const Value: Integer);
var MsgCode: Integer;
begin
MsgCode := HiWord( Index );
if MsgCode = 0 then
MsgCode := Index + 1;
Perform( MsgCode and $7FFF, Item, Value );
if (MsgCode and $8000) <> 0 then
Invalidate;
end;
{$ENDIF ASM_VERSION}
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 ASM_VERSION} //Pascal
destructor TOpenSaveDialog.Destroy;
begin
FFilter := '';
FInitialDir := '';
FDefExtension := '';
FFileName := '';
FTitle := '';
{$IFDEF OpenSaveDialog_Extended}
TemplateName := '';
{$ENDIF}
inherited;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_UNICODE}
function TOpenSaveDialog.Execute: Boolean;
asm
PUSH EBX
XCHG EBX, EAX
XOR ECX, ECX
{$IFDEF OpenSaveDialog_Extended}
MOVZX EAX, [EBX].NoPlaceBar
PUSH EAX
PUSH ECX
PUSH ECX
PUSH [EBX].TemplateName
PUSH [EBX].HookProc
{$ELSE}
PUSH ECX // prepare lpTemplateName = nil
PUSH ECX // prepare lpfnHook = nil
{$ENDIF}
PUSH EBX // prepare lCustData = @Self
MOV EDX, [EBX].FDefExtension
CALL EDX2PChar
PUSH EDX // prepare lpstrDefExt = FDefExtension
PUSH ECX // prepare nFileExtension, nFileOffset: Word = 0, 0
// prepare flags:
LEA EAX, [EBX].FOptions
MOV EDX, Offset[@@OpenSaveFlags]
{$IFDEF OpenSaveDialog_Extended}
MOV CL, 14
{$ELSE}
MOV CL, 12
{$ENDIF}
CALL MakeFlags
XOR ECX, ECX
OR EAX, OFN_EXPLORER or OFN_LONGNAMES or OFN_ENABLESIZING
PUSH EAX // push Flags
PUSH [EBX].FTitle // prepare lpstrTitle
PUSH [EBX].FInitialDir // prepare lpstrInitialDir
PUSH ECX // prepare nMaxFileTitle = 0
PUSH ECX // prepare lpstrFileTitle = nil
TEST AH, 2 // MultiSelect?
MOV EAX, 65520
JNZ @@1
MOV AX, MAX_PATH+2
@@1: PUSH EAX // prepare nMaxFile
CALL System.@GetMem
POP ECX
PUSH ECX
PUSH EAX // prepare lpStrFile
XOR EDX, EDX
@@2: MOV EDX, [EBX].fFileName // no, fill it initilly by FileName
CALL EDX2PChar
DEC ECX // added 5 october 2003 to prevent possible error if FileName too big
CALL StrLCopy
XOR EDX, EDX
PUSH [EBX].FFilterIndex // prepare nFilterIndex
PUSH EDX // prepare nMaxCustFilter
PUSH EDX // prepare lpstrCustomFilter
PUSH EDX // prepare lpstrFilter = nil
MOV EAX, ESP
OR EDX, [EBX].FFilter
JZ @@5
MOV ECX, offset[@@0]
CALL System.@LStrCat3 // prepare lpStrFilter = FFilter + #0
POP EAX
PUSH EAX
XOR EDX, EDX
@@3: INC EAX // filter is not starting from ';' or '|'...
CMP [EAX], DL
JZ @@5
CMP byte ptr [EAX], '|'
JNZ @@3
@@4: MOV [EAX], DL
JMP @@3
@@OpenSaveFlags:
DD OFN_CREATEPROMPT, OFN_EXTENSIONDIFFERENT, OFN_FILEMUSTEXIST
DD OFN_HIDEREADONLY, OFN_NOCHANGEDIR, OFN_NODEREFERENCELINKS
DD OFN_ALLOWMULTISELECT, OFN_NONETWORKBUTTON, OFN_NOREADONLYRETURN
DD OFN_OVERWRITEPROMPT, OFN_PATHMUSTEXIST, OFN_READONLY, OFN_NOVALIDATE
{$IFDEF OpenSaveDialog_Extended}
DD OFN_ENABLETEMPLATE, OFN_ENABLEHOOK
{$ENDIF}
{$IFDEF _D2009orHigher}
DW 0, 1
{$ENDIF}
DD -1, 1
@@0: DB 0
@@5:
PUSH [hInstance] // prepare hInstance
MOV ECX, [EBX].TControl.fWnd
INC ECX
LOOP @@6
MOV ECX, [Applet]
JECXZ @@6
MOV ECX, [ECX].TControl.fHandle
@@6: PUSH ECX // prepare hWndOwner
{$IFDEF OpenSaveDialog_Extended}
CALL WinVer
CMP AL, wvNT
MOV DL, 76+12
JA @@6a
CMP AL, wvME
JE @@6a
MOV DL, 76
@@6a: MOVZX EAX, DL
PUSH EAX
{$ELSE}
PUSH 76 // prepare lStructSize
{$ENDIF}
PUSH ESP
CMP [EBX].TControl.FOpenDialog, 0
JZ @@7
CALL GetOpenFileName
JMP @@8
@@7: CALL GetSaveFileName
@@8:
PUSH EAX
XOR EDX, EDX
TEST EAX, EAX
JZ @@10
MOV EAX, [ESP+4].TOpenFileName.nFilterIndex
MOV [EBX].FFilterIndex, EAX
TEST BYTE PTR [ESP+4].TOpenFileName.Flags, OFN_READONLY
SETNZ AL
MOV [EBX].fOpenReadOnly, AL
MOV EAX, [ESP+4].TOpenFileName.lpstrFile
MOV EDX, EAX
XOR ECX, ECX
TEST [EBX].FOptions, 1 shl OSAllowMultiSelect
JZ @@10
DEC EAX
@@9: INC EAX
CMP byte ptr [EAX], CL
JNZ @@9
CMP byte ptr [EAX+1], CL
JZ @@10
MOV byte ptr [EAX], 13
JMP @@9
@@10:
LEA EAX, [EBX].FFileName
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
MOV EAX, [ESP+4].TOpenFileName.lpstrFile
CALL System.@FreeMem // v1.86 +AK
LEA EAX, [ESP+4].TOpenFileName.lpstrFilter
CALL System.@LStrClr
POP EAX
{$IFDEF OpenSaveDialog_Extended}
ADD ESP, 76+12
{$ELSE}
ADD ESP, 76
{$ENDIF}
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function TOpenSaveDialog.Execute: Boolean;
const OpenSaveFlags: array[ TOpenSaveOption ] of Integer = (
OFN_CREATEPROMPT,
OFN_EXTENSIONDIFFERENT,
OFN_FILEMUSTEXIST,
OFN_HIDEREADONLY,
OFN_NOCHANGEDIR,
OFN_NODEREFERENCELINKS,
OFN_ALLOWMULTISELECT,
OFN_NONETWORKBUTTON,
OFN_NOREADONLYRETURN,
OFN_OVERWRITEPROMPT,
OFN_PATHMUSTEXIST,
OFN_READONLY,
OFN_NOVALIDATE
//{$IFDEF OpenSaveDialog_Extended}
,
OFN_ENABLETEMPLATE,
OFN_ENABLEHOOK
//{$ENDIF}
);
var
Ofn : TOpenFilename;
Fltr : KOLString;
TempFilename : KOLString;
Function MakeFilter(s : 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(#0, ffilename) > 0 do begin
FFilename[pos(#0, ffilename)]:=#13;
end;
end else
FFileName := copy(tempFileName, 1, pos(KOLString(#0), TempFilename)
-1 // by X.Y.B.
);
end else
FFilename:='';
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
destructor TOpenDirDialog.Destroy;
begin
FTitle := '';
FInitialPath := '';
FStatusText := '';
inherited;
end;
{$ENDIF ASM_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} // WndOwner
function TOpenDirDialog.Execute: Boolean;
asm
PUSH EBX
XCHG EBX, EAX
XOR ECX, ECX
PUSH ECX // prepare iImage = 0
PUSH EBX // prepare lParam = @Self
PUSH [EBX].FCallBack // prepare lpfn = FCallBack
LEA EAX, [EBX].FOptions
MOV EDX, Offset[@@FlagsArray]
MOV CL, 8
CALL MakeFlags
PUSH EAX // prepare ulFlags = Options
PUSH [EBX].FTitle // prepare lpszTitle
LEA EAX, [EBX].FBuf
PUSH EAX // prepare pszDisplayName
PUSH 0 // prepare pidlRoot
MOV ECX, [EBX].fWnd
INC ECX
LOOP @@1
MOV ECX, Applet
JECXZ @@1
MOV ECX, [ECX].TControl.fHandle
@@1: PUSH ECX // prepare hwndOwner
PUSH ESP
CALL SHBrowseForFolderA
ADD ESP, 32
TEST EAX, EAX
JZ @@exit
PUSH EAX
LEA EDX, [EBX].FBuf
PUSH EDX
PUSH EAX
CALL SHGetPathFromIDListA
CALL CoTaskMemFree
MOV AL, 1
JMP @@fin
@@FlagsArray:
DD BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER, BIF_DONTGOBELOWDOMAIN
DD BIF_RETURNFSANCESTORS, BIF_RETURNONLYFSDIRS, BIF_STATUSTEXT
DD BIF_BROWSEINCLUDEFILES, BIF_EDITBOX, BIF_NEWDIALOGSTYLE
@@exit: XOR EAX, EAX
@@fin:
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function TOpenDirDialog.Execute: Boolean;
const FlagsArray: array[ TOpenDirOption ] of Integer =
( BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER, BIF_DONTGOBELOWDOMAIN,
BIF_RETURNFSANCESTORS, BIF_RETURNONLYFSDIRS, BIF_STATUSTEXT,
BIF_BROWSEINCLUDEFILES, BIF_EDITBOX, BIF_NEWDIALOGSTYLE );
var BI : TBrowseInfo;
Browse : PItemIdList;
begin
Result := False;
if WndOwner <> 0 then
BI.hwndOwner := WndOwner
else
if 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 ASM_VERSION}
function TOpenDirDialog.GetInitialPath: KOLString;
begin
Result := IncludeTrailingPathDelimiter( fInitialPath );
end;
function TOpenDirDialog.GetPath: KOLString;
begin
Result := FBuf;
end;
{$IFDEF ASM_UNICODE}
function OpenDirSelChangeCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ):
Integer; stdcall;
asm
MOV EAX, [lpData]
MOV ECX, [EAX].TOpenDirDialog.FOnSelChanged.TMethod.Code
JECXZ @@exit
LEA EDX, [EAX].TOpenDirDialog.FBuf
PUSH EDX
PUSH [lParam]
CALL SHGetPathFromIDListA
MOV EDX, [lpData]
LEA ECX, [EDX].TOpenDirDialog.FBuf
PUSH 0
PUSH ESP
LEA EAX, [EDX].TOpenDirDialog.FStatusText
PUSH EAX
MOV EAX, [EDX].TOpenDirDialog.FOnSelChanged.TMethod.Data
CALL dword ptr [EDX].TOpenDirDialog.FOnSelChanged.TMethod.Code
PUSH 0
PUSH BFFM_ENABLEOK
PUSH [Wnd]
CALL SendMessage
@@1:
MOV EDX, [lpData]
MOV ECX, [EDX].TOpenDirDialog.FStatusText
JECXZ @@exit
PUSH ECX
PUSH 0
PUSH BFFM_SETSTATUSTEXT
PUSH [Wnd]
CALL SendMessage
@@exit: XOR EAX, EAX
end;
{$ELSE ASM_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 ASM_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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure OpenDirDlgCenter( Wnd: HWnd );
var R: TRect;
W, H: Integer;
begin
GetWindowRect( Wnd, R );
W := R.Right - R.Left;
H := R.Bottom - R.Top;
R.Left := (GetSystemMetrics( SM_CXSCREEN ) - W) div 2;
R.Top := (GetSystemMetrics( SM_CYSCREEN ) - H) div 2;
MoveWindow( Wnd, R.Left, R.Top, W, H, True );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TOpenDirDialog.SetCenterOnScreen(const Value: Boolean);
var P: procedure( Wnd: HWnd );
begin
FCenterOnScreen := Value;
P := nil;
if Value then
P := @OpenDirDlgCenter;
FCenterProc := P;
end;
{$ENDIF ASM_VERSION}
procedure TOpenDirDialog.SetInitialPath(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 ASM_VERSION} //Pascal
procedure TControl.TBAddBitmap(Bitmap: HBitmap);
const NstdBitmaps: array[ 0..5 ] of DWORD = ( 15, 15, 0, 0, 13, 13 );
var BI: TBitmapInfo;
AB: TTBAddBitmap;
N, W: Integer;
begin
if Bitmap = 0 then Exit;
if (Integer( Bitmap ) >= -10) and (Integer( Bitmap ) <= -1) then
begin
AB.hInst := THandle(-1);
AB.nID := -Integer(Bitmap) - 1;
N := 0; //NstdBitmaps[ AB.nID ]; // (this value is ignored)
end
else
if GetObject( Bitmap, sizeof( TBitmapInfo ), @BI ) > 0 then
begin
AB.hInst := 0;
AB.nID := Bitmap;
W := 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 ASM_VERSION}
{$IFDEF ASM_UNICODE}
function TControl.TBAddInsButtons(Idx: Integer; const Buttons: array of PKOLChar;
const BtnImgIdxArray: array of Integer): Integer; stdcall;
asm
{ [EBP+$8] = @Self
[EBP+$C] = Idx
[EBP+$10] = Buttons
[EBP+$14] = High(Butons)
[EBP+$18] = BtnImgIdxArray
[EBP+$1C] = High(BtnImgIdxArray)
}
PUSH EBX
PUSH ESI
PUSH EDI
OR EBX, -1
MOV EAX, 20
MOV ECX, [EBP+$14]
CMP ECX, EBX
JLE @@fin
INC ECX
MUL ECX
CALL System.@GetMem
PUSH EAX // save AB to FreeMem after
MOV EDX, EBX
DEC EDX // nBmp := -2
MOV ECX, [EBP+$14]
INC ECX
JZ @@exit
MOV ECX, [EBP+$1C]
INC ECX
JZ @@1
MOV ECX, [BtnImgIdxArray]
MOV EDX, [ECX]
DEC EDX // nBmp := BtnImgIdxArray[ 0 ] - 1
@@1: MOV ECX, [EBP+$14]
INC ECX
MOV ESI, [Buttons]
MOV EDI, EAX // EDI = PAB
PUSH 0 // N:=0 in [EBP-$14]
// -- impossible?-- JZ @@break
@@loop:
LODSD
TEST EAX, EAX
JZ @@break
PUSH ECX
CMP word ptr [EAX], '-'
JNE @@2
OR EAX, -1
STOSD
MOV EAX, [ToolbarsIDcmd]
TEST EBX, EBX
{$IFDEF USE_CMOV}
CMOVL EBX, EAX
{$ELSE}
JGE @@b0
MOV EBX, EAX
@@b0: {$ENDIF}
//INC [ToolbarsIDcmd]
STOSD
XOR EAX, EAX
INC AH // TBSTYLE_SEP = 1
STOSD
DEC AH
STOSD
DEC EAX
JMP @@3
{$IFDEF _D2009orHigher}
DW 0, 1
{$ENDIF}
DD -1, 1
@@0: DB 0
@@2:
INC EDX // Inc( nBmp )
PUSH EAX
MOV EAX, [EBP+$1C]
MOV ECX, [EBP-$14]
CMP EAX, ECX
MOV EAX, EDX
JL @@21
MOV EAX, [BtnImgIdxArray]
MOV EAX, [EAX+ECX*4]
@@21: STOSD
TEST EDX, EDX
JGE @@2a
DEC EDX
@@2a:
MOV EAX, [ToolbarsIDcmd]
//INC [ToolbarsIDcmd]
STOSD
TEST EBX, EBX
{$IFDEF USE_CMOV}
CMOVL EBX, EAX
{$ELSE}
JGE @@210
MOV EBX, EAX
@@210: {$ENDIF}
MOV ECX, [EBP+8]
MOV AH, BYTE PTR [ECX].TControl.DF.fDefaultTBBtnStyle
POP ECX
MOV AL, 4 // AL=fsState=_ENABLED, AH=fsStyle=_AUTOSIZE if fDefaultTBBtnStyle contains
CMP byte ptr [ECX], '^'
JNE @@22
OR AH, TBSTYLE_DROPDOWN
INC ECX
@@22: CMP byte ptr [ECX], '-'
JZ @@23
CMP byte ptr [ECX], '+'
JNZ @@24
MOV AL, TBSTATE_ENABLED or TBSTATE_CHECKED
@@23: INC ECX
OR AH, TBSTYLE_CHECK
CMP byte ptr [ECX], '!'
JNZ @@24
OR AH, TBSTYLE_GROUP
INC ECX
@@24: {$IFDEF TOOLBAR_DOT_NOAUTOSIZE_BUTTON}
CMP byte ptr [ECX], '.'
JNZ @@25
AND AH, not TBSTYLE_AUTOSIZE
INC ECX
@@25:
{$ENDIF TOOLBAR_DOT_NOAUTOSIZE_BUTTON}
STOSD
MOV EAX, [EBP+8]
STOSD
OR EAX, -1
CMP word ptr [ECX], ' '
JZ @@3
CMP byte ptr [ECX], 0
JZ @@3
PUSH EDX
PUSH 0
MOV EDX, ECX
MOV EAX, ESP
{$IFDEF _D2009orHigher}
PUSH ECX
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
{$IFDEF _D2009orHigher}
POP ECX
{$ENDIF}
MOV EAX, ESP
MOV EDX, offset[@@0]
CALL System.@LStrCat
PUSH dword ptr [ESP]
PUSH 0
PUSH TB_ADDSTRING
PUSH dword ptr [EBP+8]
CALL Perform
STOSD
CALL RemoveStr
POP EDX
JMP @@30
@@3: STOSD
@@30: INC dword ptr [EBP-$14]
INC [ToolbarsIDcmd]
POP ECX
DEC ECX
JNZ @@loop
@@break:
POP ECX
JECXZ @@exit
PUSH dword ptr [ESP]
MOV EAX, [Idx]
TEST EAX, EAX
JGE @@31
PUSH ECX
PUSH TB_ADDBUTTONS
JMP @@32
@@31:
PUSH EAX
PUSH TB_INSERTBUTTON
@@32:
PUSH dword ptr [EBP+8]
CALL Perform
@@exit:
POP EAX
CALL System.@FreeMem
@@fin:
POP EDI
POP ESI
XCHG EAX, EBX
POP EBX
end;
{$ELSE ASM_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;
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 (Str = KOLString( {$IFDEF F_P}''+{$ENDIF} KOLChar( ' ' ) )) or (Str^ = #0) then
PAB.iString := -1
//Perform( TB_ADDSTRING, 0, Integer( PChar( '' + #0 ) ) )
// an experiment: is it possible to remove space right to image
// without setting tboTextBottom option (non compatible with FixFlatXP)
// answer: seems not possible.
else
PAB.iString :=
Perform( TB_ADDSTRING, 0, Integer( PKOLChar( KOLString( KOLString('') + Str + #0 ) ) ) );
end;
PAB.idCommand := ToolbarsIDcmd;
if Result < 0 then Result := PAB.idCommand;
Inc( ToolbarsIDcmd );
PAB.dwData := Integer( @Self );
Inc( N );
Inc( PAB );
end;
if N > 0 then
begin
if Idx < 0 then
Perform( TB_ADDBUTTONS, N, Integer( @AB[ 0 ] ) )
else
Perform( TB_INSERTBUTTON, Idx, Integer( @AB[ 0 ] ) );
end;
if AB <> nil then
FreeMem( AB );
end;
begin
if High( Buttons ) < 0 then
Result := -1
else
Result := AddInsButtons;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.TBAddButtons(const Buttons: array of PKOLChar;
const BtnImgIdxArray: array of Integer): Integer;
begin
Result := TBAddInsButtons( -1, Buttons, BtnImgIdxArray );
end;
{$ENDIF ASM_VERSION}
function TControl.TBInsertButtons(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;
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 ASM_VERSION} //Pascal
function TControl.TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean;
begin
BtnID := GetTBBtnGoodID( @Self, BtnID );
Result := Perform( Index + 8, BtnID, 0 ) <> 0;
end;
{$ENDIF ASM_VERSION}
procedure TControl.TBSetBtnStt(BtnID: Integer; const Index: Integer; const Value: Boolean);
begin
BtnID := GetTBBtnGoodID( @Self, BtnID );
Perform( Index, BtnID, Integer( Value ) );
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.TBIndex2Item(Idx: Integer): Integer;
var ButtonInfo: TTBButton;
begin
Result := -1;
if Perform( TB_GETBUTTON, Idx, Integer( @ButtonInfo ) ) <> 0 then
Result := ButtonInfo.idCommand;
end;
{$ENDIF ASM_VERSION}
procedure TControl.TBConvertIdxArray2ID(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}
function TControl.TBGetButtonText( BtnID: Integer ): AnsiString;
asm
PUSH ECX
ADD ESP, -1024
PUSH ESP
PUSH EAX
CALL GetTBBtnGoodID
POP EDX
PUSH EAX
PUSH TB_GETBUTTONTEXT
PUSH EDX
CALL Perform
TEST EAX, EAX
JLE @@2
MOV EDX, ESP
JMP @@1
@@2: XOR EDX, EDX
@@1: MOV EAX, [ESP+1024]
{$IFDEF _D2009orHigher}
XOR ECX, ECX
{$ENDIF}
CALL System.@LStrFromPChar
ADD ESP, 1028
end;
{$ELSE ASM_VERSION} //Pascal
function TControl.TBGetButtonText( BtnID: Integer ): KOLString;
var Buffer: array[ 0..1023 ] of KOLChar;
begin
BtnID := GetTBBtnGoodID( @Self, BtnID );
if Perform( TB_GETBUTTONTEXT, BtnID, Integer( @Buffer[ 0 ] ) ) > 0 then
Result := Buffer
else
Result := '';
end;
{$ENDIF ASM_VERSION}
//*
function TControl.TBGetButtonRect(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 ASM_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 ASM_VERSION}
procedure ToolbarSetTooltips( Toolbar: PControl; BtnID1st: Integer;
const Tooltips: array of PKOLChar );
begin
Toolbar.TBSetTooltips( BtnID1st, Tooltips );
end;
function ToolbarButtonEnabled( Toolbar: PControl; BtnID: Integer ): Boolean;
begin
Result := Toolbar.TBButtonEnabled[ BtnID ];
end;
procedure EnableToolbarButton( Toolbar: PControl; BtnID: Integer; Enable: Boolean );
begin
Toolbar.TBButtonEnabled[ BtnID ] := Enable;
end;
function ToolbarButtonVisible( Toolbar: PControl; BtnID: Integer ): Boolean;
begin
Result := Toolbar.TBButtonVisible[ BtnID ];
end;
procedure ShowHideToolbarButton( Toolbar: PControl; BtnID: Integer; Show: Boolean );
begin
Toolbar.TBButtonVisible[ BtnID ] := Show;
end;
function ToolbarButtonChecked( Toolbar: PControl; BtnID: Integer): Boolean;
begin
Result := Toolbar.TBButtonChecked[ BtnID ];
end;
procedure ToolbarButtonSetChecked( Toolbar: PControl; BtnID: Integer; Checked: Boolean );
begin
Toolbar.TBButtonChecked[ BtnID ] := Checked;
end;
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 ASM_VERSION} //Pascal
function TControl.TBButtonAtPos(X, Y: Integer): Integer;
var I: Integer;
begin
I := TBBtnIdxAtPos( X, Y );
if I >= 0 then
I := TBIndex2Item( I );
Result := I;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.TBBtnIdxAtPos(X, Y: Integer): Integer;
var I: Integer;
R: TRect;
P: TPoint;
begin
P := MakePoint( X, Y );
for I := TBButtonCount - 1 downto 0 do
begin
Perform( TB_GETITEMRECT, I, Integer( @R ) );
if PointInRect( P, R ) then
begin
Result := I;
Exit;
end;
end;
Result := -1;
end;
{$ENDIF ASM_VERSION}
function TControl.TBButtonSeparator(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 ASM_VERSION} //Pascal
function TControl.TBGetBtnImgIdx(BtnID: Integer): Integer;
var B: TTBButton;
begin
Perform( TB_GETBUTTON, TBItem2Index( GetTBBtnGoodID( @Self, BtnID ) ), Integer( @B ) );
Result := B.iBitmap;
end;
{$ENDIF ASM_VERSION}
//*
procedure TControl.TBSetBtnImgIdx(BtnID: Integer; const Value: Integer);
begin
Perform( TB_CHANGEBITMAP, GetTBBtnGoodID( @Self, BtnID ), Value );
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.TBSetButtonText(BtnID: Integer; const Value: KOLString);
var BI: TTBButtonInfo;
begin
BtnID := GetTBBtnGoodID( @Self, BtnID );
BI.cbSize := Sizeof( BI );
BI.dwMask := TBIF_TEXT;
BI.pszText := PKOLChar( Value );
Perform( TB_SETBUTTONINFO, BtnID, Integer( @BI ) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TControl.TBGetBtnWidth(BtnID: Integer): Integer;
var R: TRect;
begin
R := TBButtonRect[ BtnID ];
Result := R.Right - R.Left;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TControl.TBSetBtnWidth(BtnID: Integer; const Value: Integer);
var BI: TTBButtonInfo;
begin
BI.cbSize := Sizeof( BI );
BI.dwMask := TBIF_SIZE or TBIF_STYLE;
BtnID := GetTBBtnGoodID( @Self, BtnID );
Perform( TB_GETBUTTONINFO, BtnID, Integer( @BI ) );
BI.cx := Value;
BI.fsStyle := BI.fsStyle and not TBSTYLE_AUTOSIZE;
Perform( TB_SETBUTTONINFO, BtnID, Integer( @BI ) );
end;
{$ENDIF ASM_VERSION}
procedure TControl.TBSetBtMinMaxWidth(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 ASM_VERSION} //Pascal
procedure TControl.AddDirList(const Filemask: KOLString; Attrs: DWORD);
begin
if fCommandActions.aDir <> 0 then
Perform( fCommandActions.aDir, Attrs, Integer( PKOLChar( Filemask ) ) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_noVERSION}
{$ELSE ASM_VERSION} //Pascal
function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
//var Accept: Boolean; // {Alexander Pravdin, AP}
begin
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 ASM_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 ASM_VERSION} //Pascal
{$IFDEF USE_SHOWMODALPARENTED_ALWAYS}
function TControl.ShowModal: Integer;
begin
Result := ShowModalParented(Applet);
end;
{$ELSE not USE_SHOWMODALPARENTED_ALWAYS}
function TControl.ShowModal: Integer;
var FL: PList;
var CurForm: PControl;
I: Integer;
F: PControl;
CurCtl: PControl; // { Alexander Pravdin }
begin
Result := 0;
if {$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;
Show;
ModalResult := 0;
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 ASM_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 ASM_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 ASM_VERSION}
{$ENDIF WIN}
{ TTimer }
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
destructor TTimer.Destroy;
begin
Enabled := False;
inherited;
Dec( TimerCount );
{$IFDEF WIN}
if TimerCount = 0 then
begin
TimerOwnerWnd.Free;
TimerOwnerWnd := nil;
end;
{$ENDIF WIN}
end;
{$ENDIF ASM_VERSION}
{$IFDEF WIN_GDI}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TTimer.SetEnabled(const Value: Boolean);
var WasEnabled: Boolean;
begin
WasEnabled := fEnabled;
fEnabled := Value;
if WasEnabled = Value then Exit;
{$IFDEF TIMER_APPLETWND}
if Applet = nil then Exit;
{$ENDIF}
if Value then
begin
{$IFDEF TIMER_APPLETWND}
fHandle := SetTimer( Applet.GetWindowHandle, Integer( @Self ),
fInterval, @TimerProc );
{$ELSE}
if TimerOwnerWnd = nil then
begin
TimerOwnerWnd := _NewWindowed( nil, '', 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 ASM_VERSION}
{$ENDIF WIN_GDI}
{$IFDEF _X_}
{$IFDEF GTK}
FUNCTION TimerGTKTick( Sender: Pointer ): LONGBOOL; cdecl;
BEGIN
IF NOT PTimer( Sender ).fEnabled THEN Result := FALSE
ELSE
BEGIN
IF Assigned( PTimer( Sender ).fOnTimer ) THEN
Ptimer( Sender ).fOnTimer( Sender );
Result := PTimer( Sender ).fEnabled;
END;
IF Result THEN
PTimer( Sender ).RefDec;
END;
PROCEDURE TTimer.SetEnabled(const Value: Boolean);
BEGIN
IF FEnabled = Value THEN Exit;
fEnabled := Value;
IF Value THEN
BEGIN
RefInc;
fHandle := gtk_timeout_add( fInterval, TimerGTKTick, @ Self );
END ELSE
BEGIN
IF AppletTerminated THEN
BEGIN
gtk_timeout_remove( fHandle );
RefDec;
END;
END;
END;
{$ELSE not GTK}
var fActiveTimerList: PTimer;
fClockPerSecond: Integer;
fAlarmHandling: Boolean;
procedure SetAlarm; forward;
procedure AlarmHandler(SigNum: Integer); cdecl;
var T, NT: PTimer;
c: Integer;
count_handled: Integer;
begin
c := clock;
fAlarmHandling := TRUE; // to prevent SetAlarm working while timers are handling
TRY
//--- 1. Clear fTimerHandled flag for all active timers
T := fActiveTimerList;
while T <> nil do
begin
T.fTimerHandled := FALSE;
T := T.fNext;
end;
//--- 2. Handle all expired timers
count_handled := 0;
while not AppletTerminated do // until all timers expired are handled or
begin // until the application is terminated
//--- 2.A. Search a timer which was expired before all others
T := fActiveTimerList;
NT := nil;
while T <> nil do
begin
if not T.fTimerHandled and (
(NT = nil) or ((T.fExpireNext - c) < (NT.fExpireNext - c))
) then
NT := T;
T := T.fNext;
end;
if NT = nil then break; // there are no more timers expired
if (count_handled > 0) and
((NT.fExpireNext - c > 0) or (NT.fExpireNext < 0) and (c > 0)) then break;
//--- 2.B. Handle found timer (NT)
inc( count_handled ); // count handled timer to ensure that at least 1 timer
// was handled in result of alarm call
{$IFDEF SUPPORT_LONG_TIMER}
NT.fExpireTotal := NT.fExpireTotal - (c - NT.fTimeStart);
if NT.fExpireTotal > 30 * 60 * fClockPerSecond then
NT.fExpireNext := c + 30 * 60 * fClockPerSecond
else
NT.fExpireNext := c + NT.fExpireTotal;
{$ELSE not SUPPORT_LONG_TIMER}
NT.fExpireNext := // next time to expire this timer
NT.fExpireNext + fClockPerSecond * NT.fInterval;
{$ENDIF SUPPORT_LONG_TIMER}
NT.fTimerHandled := TRUE; // do not handle that timer again in that loop
{$IFDEF SUPPORT_LONG_TIMER}
if NT.fExpireTotal <= 0 then
{$ENDIF SUPPORT_LONG_TIMER}
begin
if NT.fMultimedia and not NT.fPeriodic then
NT.Enabled := FALSE; // one-shot timer, disable it now
//--------------------------------------------------------------
//todo: for not a multimedia timer, post a signal to a window
// to synchronize timer handling with the main thread!
// (but not for fMultimedia timers)
//--------------------------------------------------------------
if Assigned( NT.fOnTimer ) then
NT.fOnTimer( NT ); // in result of this action, timer NT or any other active
// timer can be disabled and dropped from fActiveTimerList and any amount of
// previously disbled timers can be added
end;
end;
FINALLY
fAlarmHandling := FALSE;
END;
// 3. finally, install the next alarm to the nearest expirating timer if any
SetAlarm;
end;
procedure SetAlarm;
var i: Integer;
T, NT: PTimer;
TV: itimerval;
c: clock_t;
begin
if AppletTerminated then Exit; // if the application is terminated we do not install alarms
if fAlarmHandling then Exit; // while alarm is handling do not reinstall alarms
c := clock;
T := fActiveTimerList;
NT := T;
while T <> nil do
begin
if (T.fExpireNext - c) < (NT.fExpireNext - c) then
NT := T;
T := T.fNext;
end;
if NT = nil then Exit;
i := (NT.fExpireNext - c) * 1000 div fClockPerSecond;
if i < 0 then i := 10; // 10 milliseconds as minimum time to alarm
TV.it_interval.tv_sec := 0; // set interval to alarm once
TV.it_interval.tv_usec := 0;
TV.it_value.tv_sec := i div 1000; // set time to alarm next time
TV.it_value.tv_usec := (i mod 1000) * 1000;
signal( SIGALRM, AlarmHandler );
setitimer( ITIMER_REAL, TV, nil );
end;
procedure TTimer.SetEnabled(const Value: Boolean);
begin
if FEnabled = Value then Exit;
fEnabled := Value;
if Value then
begin
if fClockPerSecond = 0 then
fClockPerSecond := CLK_TCK;
fExpireTotal := Int64( fClockPerSecond ) * fInterval;
{$IFDEF SUPPORT_LONG_TIMER}
if fExpireTotal > 30 * 60 * fClockPerSecond then
fExpireNext := clock + 30 * 60 * fClockPerSecond
else
fExpireNext := clock + fExpireTotal;
{$ELSE}
fExpireNext := clock + fExpireTotal;
{$ENDIF SUPPORT_LONG_TIMER}
if fActiveTimerList <> nil then
begin
fNext := fActiveTimerList;
fActiveTimerList.fPrev := @ Self;
end;
fActiveTimerList := @ Self;
end
else
begin
if fPrev <> nil then
fPrev.fNext := fNext;
if fNext <> nil then
fNext.fPrev := fPrev;
if fActiveTimerList = @ Self then
fActiveTimerList := fNext;
fPrev := nil;
fNext := nil;
end;
if fActiveTimerList <> nil then
begin // set alarm to the nearest expiring timer
SetAlarm;
end;
end;
{$ENDIF not GTK}
{$ENDIF _X_}
procedure TTimer.SetInterval(const Value: Integer);
var WasEnabled : Boolean;
begin
if fInterval = Value then Exit;
fInterval := Value;
WasEnabled := Enabled;
Enabled := False;
Enabled := WasEnabled {$IFDEF STOPTIMER_AFTER_APPLETTERMINATED}
and not AppletTerminated
{$ENDIF};
end;
{$IFDEF WIN}
{ 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} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
////////////////////////////////////////////////////////////////////////
// t B I T M A P
///////////////////////////////////////////////////////////////////////
{ -- bitmap -- }
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo;
begin
Assert( W > 0, 'Width must be >0' );
Assert( H > 0, 'Height must be >0' );
Result := AllocMem( 256*Sizeof(TRGBQuad)+Sizeof(TBitmapInfoHeader) );
Assert( Result <> nil, 'No memory' );
Result.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );
Result.bmiHeader.biWidth := W;
Result.bmiHeader.biHeight := H; // may be, -H ?
Result.bmiHeader.biPlanes := 1;
Result.bmiHeader.biBitCount := BitsPerPixel;
end;
{$ENDIF ASM_VERSION}
const
BitsPerPixel_By_PixelFormat: array[ TPixelFormat ] of Byte =
( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat;
var I: TPixelFormat;
begin
for I := High(I) downto Low(I) do
if BitsPerPixel = BitsPerPixel_By_PixelFormat[ I ] then
begin
Result := I;
Exit;
end;
Result := pfDevice;
end;
{$ENDIF ASM_VERSION}
procedure DummyDetachCanvas( Sender: PBitmap );
begin
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_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 );
Assert( Result.fHandle <> 0, 'Can not create bitmap handle' );
ReleaseDC( 0, DC );
end;
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
procedure PreparePF16bit( DIBHeader: PBitmapInfo );
begin
DIBHeader.bmiHeader.biCompression := BI_BITFIELDS;
Move( InitColors[ 0 ], DIBHeader.bmiColors[ 0 ], 19*Sizeof(TRGBQUAD) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap;
const BitsPerPixel: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
var BitsPixel: Integer;
begin
New( Result, Create );
{$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;
ASSERT( Result.fNewPixelFormat in [ pf1bit..pf32bit ], 'Strange pixel format' );
Result.fDIBHeader := PrepareBitmapHeader( W, H, BitsPixel );
if PixelFormat = pf16bit then
begin
PreparePF16bit( Result.fDIBHeader );
end;
Result.fDIBSize := Result.ScanLineSize * H;
Result.fDIBBits :=
Pointer( GlobalAlloc( GMEM_FIXED or GMEM_ZEROINIT, Result.fDIBSize + 16 ) );
ASSERT( Result.fDIBBits <> nil, 'No memory' );
end;
end;
{$ENDIF ASM_VERSION}
{ TBitmap }
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.ClearData;
begin
fDetachCanvas( @Self );
if fHandle <> 0 then
begin
DeleteObject( fHandle );
fHandle := 0;
fDIBBits := nil;
end;
if fDIBBits <> nil then
begin
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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.Clear;
begin
RemoveCanvas;
ClearData;
fWidth := 0;
fHeight := 0;
fDIBAutoFree := FALSE;
end;
{$ENDIF ASM_VERSION}
function TBitmap.GetBoundsRect: TRect;
begin
Result := MakeRect( 0, 0, Width, Height );
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
destructor TBitmap.Destroy;
begin
Clear;
inherited;
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
procedure TBitmap.Draw(DC: HDC; X, Y: Integer);
var
DCfrom, DC0: HDC;
oldBmp: HBitmap;
oldHeight: Integer;
B: tagBitmap;
label
TRYAgain;
begin
TRYAgain:
if Empty then Exit;
if fHandle <> 0 then
begin
fDetachCanvas( @Self );
oldHeight := fHeight;
if GetObject( fHandle, sizeof( B ), @B ) <> 0 then
oldHeight := B.bmHeight;
ASSERT( oldHeight > 0, 'oldHeight must be > 0' );
DC0 := GetDC( 0 );
DCfrom := CreateCompatibleDC( DC0 );
ReleaseDC( 0, DC0 );
oldBmp := SelectObject( DCfrom, fHandle );
ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
BitBlt( DC, X, Y, fWidth, oldHeight, DCfrom, 0, 0, SRCCOPY );
{$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
SelectObject( DCfrom, oldBmp );
DeleteDC( DCfrom );
end
else
if fDIBBits <> nil then
begin
oldHeight := Abs(fDIBHeader.bmiHeader.biHeight);
ASSERT( oldHeight > 0, 'oldHeight must be > 0' );
ASSERT( fWidth > 0, 'Width must be > 0' );
if StretchDIBits( DC, X, Y, fWidth, oldHeight, 0, 0, fWidth, oldHeight,
fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY ) = 0 then
begin
if GetHandle <> 0 then
goto TRYAgain;
end;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.StretchDraw(DC: HDC; const Rect: TRect);
var DCfrom: HDC;
oldBmp: HBitmap;
label DrawHandle;
begin
if Empty then Exit;
DrawHandle:
if fHandle <> 0 then
begin
fDetachCanvas( @Self );
DCfrom := CreateCompatibleDC( 0 );
oldBmp := SelectObject( DCfrom, fHandle );
ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
Rect.Bottom - Rect.Top, DCfrom, 0, 0, fWidth, fHeight,
SRCCOPY );
SelectObject( DCfrom, oldBmp );
DeleteDC( DCfrom );
end
else
if fDIBBits <> nil then
begin
if StretchDIBits( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
Rect.Bottom - Rect.Top, 0, 0, fWidth, fHeight,
fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY )<=0 then
begin
if GetHandle <> 0 then
goto DrawHandle;
end;
end;
end;
{$ENDIF ASM_VERSION}
procedure TBitmap.DrawMasked(DC: HDC; X, Y: Integer; Mask: HBitmap);
begin
StretchDrawMasked( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ), Mask );
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.DrawTransparent(DC: HDC; X, Y: Integer; TranspColor: TColor);
begin
if TranspColor = clNone then
Draw( DC, X, Y )
else
StretchDrawTransparent( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ),
TranspColor );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_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 ASM_VERSION} //Pascal
procedure TBitmap.StretchDrawMasked(DC: HDC; const Rect: TRect; Mask: HBitmap);
var
DCfrom, MemDC, MaskDC: HDC;
MemBmp: HBITMAP;
//Save4From,
Save4Mem, Save4Mask: THandle;
crText, crBack: TColorRef;
{$IFDEF FIX_TRANSPBMPPALETTE}
FixBmp: PBitmap;
{$ENDIF FIX_TRANSPBMPPALETTE}
begin
{$IFDEF FIX_TRANSPBMPPALETTE}
if PixelFormat in [ pf4bit, pf8bit ] then
begin
FixBmp := NewBitmap( 0, 0 );
FixBmp.Assign( @ Self );
FixBmp.PixelFormat := pf32bit;
FixBmp.StretchDrawMasked( DC, Rect, Mask );
FixBmp.Free;
Exit;
end;
{$ENDIF FIX_TRANSPBMPPALETTE}
if GetHandle = 0 then Exit;
//fDetachCanvas( @Self );
//DCfrom := CreateCompatibleDC( 0 );
DCFrom := Canvas.Handle;
//Save4From := SelectObject( DCfrom, fHandle );
//ASSERT( Save4From <> 0, 'Can not select source bitmap to DC' );
MaskDC := CreateCompatibleDC( 0 );
Save4Mask := SelectObject( MaskDC, Mask );
ASSERT( Save4Mask <> 0, 'Can not select mask bitmap to DC' );
MemDC := CreateCompatibleDC( 0 );
MemBmp := CreateCompatibleBitmap( DCfrom, fWidth, fHeight );
Save4Mem := SelectObject( MemDC, MemBmp ); if Save4Mem <> 0 then;
ASSERT( Save4Mem <> 0, 'Can not select memory bitmap to DC' );
StretchBlt( MemDC, 0, 0, fWidth, fHeight, MaskDC, 0, 0, fWidth, fHeight, SrcCopy);
{$IFDEF DEBUG_DRAWTRANSPARENT}
DebugDrawTransparent( MemDC, 0, 0, fWidth, fWidth, PixelFormat, '1SrcCopy.bmp' );
{$ENDIF}
StretchBlt( MemDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, fWidth, fHeight, SrcErase);
{$IFDEF DEBUG_DRAWTRANSPARENT}
DebugDrawTransparent( MemDC, 0, 0, fWidth, fWidth, PixelFormat, '2SrcErase.bmp' );
{$ENDIF}
crText := SetTextColor(DC, $0);
crBack := Windows.SetBkColor(DC, $FFFFFF);
StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
MaskDC, 0, 0, fWidth, fHeight, SrcAnd);
{$IFDEF DEBUG_DRAWTRANSPARENT}
DebugDrawTransparent( DC, Rect.Left, Rect.Top, fWidth, fHeight, PixelFormat, '3SrcAnd.bmp' );
{$ENDIF}
StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
MemDC, 0, 0, fWidth, fHeight, SrcInvert);
{$IFDEF DEBUG_DRAWTRANSPARENT}
DebugDrawTransparent( DC, Rect.Left, Rect.Top, fWidth, fHeight, PixelFormat, '4SrcInvert.bmp' );
{$ENDIF}
Windows.SetBkColor( DC, crBack);
SetTextColor( DC, crText);
//if Save4Mem <> 0 then
// SelectObject( MemDC, Save4Mem );
DeleteObject(MemBmp);
DeleteDC(MemDC);
//SelectObject( DCfrom, Save4From );
//DeleteDC( DCfrom );
SelectObject( MaskDC, Save4Mask );
DeleteDC( MaskDC );
end;
{$ENDIF ASM_VERSION}
procedure ApplyBitmapBkColor2Canvas( Sender: PBitmap );
begin
if Sender.fCanvas = nil then Exit;
Sender.fCanvas.Brush.Color := Sender.BkColor;
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure DetachBitmapFromCanvas( Sender: PBitmap );
begin
if Sender.fCanvasAttached = 0 then Exit;
SelectObject( Sender.fCanvas.fHandle, Sender.fCanvasAttached );
Sender.fCanvasAttached := 0;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetCanvas: PCanvas;
var DC: HDC;
begin
Result := nil;
if Empty then Exit;
if GetHandle = 0 then Exit;
if fCanvas = nil then
begin
fApplyBkColor2Canvas := ApplyBitmapBkColor2Canvas;
DC := CreateCompatibleDC( 0 );
fCanvas := NewCanvas( DC );
fCanvas.fIsPaintDC := FALSE;
fCanvas.OnChange := CanvasChanged;
if fBkColor <> 0 then
fCanvas.Brush.Color := fBkColor;
end;
Result := fCanvas;
if fCanvas.fHandle = 0 then
begin
DC := CreateCompatibleDC( 0 );
fCanvas.Handle := DC;
fCanvasAttached := 0;
end;
if fCanvasAttached = 0 then
begin
fCanvasAttached := SelectObject( fCanvas.Handle, fHandle );
ASSERT( fCanvasAttached <> 0, 'Can not select bitmap to DC of Canvas' );
end;
fDetachCanvas := DetachBitmapFromCanvas;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetEmpty: Boolean;
begin
Result := (fWidth = 0) or (fHeight = 0);
ASSERT( (fWidth >= 0) and (fHeight >= 0), 'Bitmap dimensions can be negative' );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_noVERSION}
function TBitmap.GetHandle: HBitmap;
asm
PUSH EBX
MOV EBX, EAX
CALL GetEmpty
JZ @@exit
MOV EAX, EBX
CALL [EAX].fDetachCanvas
MOV ECX, [EBX].fHandle
INC ECX
LOOP @@exit
MOV ECX, [EBX].fDIBBits
JECXZ @@exit
PUSH ECX
PUSH 0
CALL GetDC
PUSH EAX
PUSH 0
PUSH 0
LEA EDX, [EBX].fDIBBits
PUSH EDX
PUSH DIB_RGB_COLORS
PUSH [EBX].fDIBHeader
PUSH EAX
CALL CreateDIBSection
MOV [EBX].fHandle, EAX
PUSH 0
CALL ReleaseDC
POP EAX
PUSH EAX
MOV EDX, [EBX].fDIBBits
MOV ECX, [EBX].fDIBSize
CALL System.Move
POP EAX
CMP [EBX].fDIBAutoFree, 0
JNZ @@freed
PUSH EAX
CALL GlobalFree
@@freed:MOV [EBX].fDIBAutoFree, 1
XOR EAX, EAX
MOV [EBX].fGetDIBPixels, EAX
MOV [EBX].fSetDIBPixels, EAX
@@exit: MOV EAX, [EBX].fHandle
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetHandle: HBitmap;
var OldBits: Pointer;
DC0: HDC;
begin
Result := 0;
if Empty then Exit;
fDetachCanvas( @ Self );
if fHandle = 0 then
begin
if fDIBBits <> nil then
begin
OldBits := fDIBBits;
DC0 := GetDC( 0 );
fDIBBits := nil;
fHandle := CreateDIBSection( DC0, fDIBHeader^, DIB_RGB_COLORS,
fDIBBits, 0, 0 );
{$IFDEF DEBUG}
if fHandle = 0 then
ShowMessage( 'Can not create DIB section, error: ' + Int2Str( GetLastError ) +
', ' + SysErrorMessage( GetLastError ) );
{$ELSE}
ASSERT( fHandle <> 0, 'Can not create DIB section, error: ' + Int2Str( GetLastError ) +
', ' + SysErrorMessage( GetLastError ) );
{$ENDIF}
ReleaseDC( 0, DC0 );
if fHandle <> 0 then
begin
Move( OldBits^, fDIBBits^, fDIBSize );
if not fDIBAutoFree then
GlobalFree( THandle( OldBits ) );
fDIBAutoFree := TRUE;
fGetDIBPixels := nil;
fSetDIBPixels := nil;
end
else
fDIBBits := OldBits;
end;
end;
Result := fHandle;
end;
{$ENDIF ASM_VERSION}
function TBitmap.GetHandleAllocated: Boolean;
begin
Result := fHandle <> 0;
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.LoadFromFile(const Filename: KOLString);
var Strm: PStream;
begin
Strm := NewReadFileStream( Filename );
LoadFromStream( Strm );
Strm.Free;
end;
{$ENDIF ASM_VERSION}
procedure TBitmap.LoadFromResourceID(Inst: DWORD; ResID: Integer);
begin
LoadFromResourceName( Inst, MAKEINTRESOURCE( ResID ) );
end;
{$IFDEF ASM_UNICODE}
procedure TBitmap.LoadFromResourceName(Inst: DWORD; ResName: PAnsiChar);
asm
PUSH EBX
MOV EBX, EAX
PUSHAD
CALL Clear
POPAD
XOR EAX, EAX
PUSH ECX
MOVZX ECX, [EBX].fHandleType
INC ECX
LOOP @@1
MOV AH, LR_CREATEDIBSECTION shr 8 // = $2000
@@1: MOV AL, LR_DEFAULTSIZE // = $40
POP ECX
PUSH EAX
PUSH 0
PUSH 0
PUSH IMAGE_BITMAP
PUSH ECX
PUSH EDX
CALL LoadImage
TEST EAX, EAX
JZ @@exit
XCHG EDX, EAX
XCHG EAX, EBX
CALL SetHandle
@@exit: POP EBX
end;
{$ELSE ASM_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 ASM_VERSION}
{$IFDEF F_P}
type
TBITMAPFILEHEADER = packed record
bfType: Word;
bfSize: DWORD;
bfReserved1: Word;
bfReserved2: Word;
bfOffBits: DWORD;
end;
{$ENDIF}
{$IFDEF ASM_noVERSION} // error + 16Colors->swap(Gray,Silver) + Core
procedure TBitmap.LoadFromStream(Strm: PStream);
type tBFH = TBitmapFileHeader;
tBIH = TBitmapInfoHeader;
const szBIH = Sizeof( tBIH );
szBFH = Sizeof( tBFH );
asm
PUSH EBX
PUSH ESI
MOV EBX, EAX
PUSH EDX
CALL Clear
POP ESI
MOV EAX, ESI
CALL TStream.GetPosition
PUSH EAX // [EBP+4] = Strm.Pos (starting pos)
PUSH EBP
MOV EBP, ESP
ADD ESP, -(szBIH + szBFH)
// reading bitmap
XOR ECX, ECX
MOV [EBX].fHandleType, CL
MOV CL, szBFH
MOV EDX, ESP
PUSH ECX
MOV EAX, ESI
CALL TStream.Read
POP ECX
SUB ECX, EAX
JNZ @@eread1
CMP [ESP].tBFH.bfType, $4D42
JE @@1
MOV EDX, [EBP+4]
MOV EAX, ESI
CALL TStream.Seek
XOR EAX, EAX
XOR EDX, EDX
JMP @@2
@@1:
MOV EDX, [ESP].tBFH.bfSize
MOV EAX, [ESP].tBFH.bfOffBits
@@2:
PUSH EDX // Push Size
PUSH EAX // Push Off
XOR ECX, ECX
MOV CL, szBIH
LEA EDX, [EBP-szBIH]
MOV EAX, ESI
PUSH ECX
CALL TStream.Read // read BIH
POP ECX
@@eread1:
XOR ECX, EAX
JNZ @@eread
MOVZX EAX, [EBP-szBIH].tBIH.biBitCount
MOVZX EDX, [EBP-szBIH].tBIH.biPlanes
MUL EDX
CALL Bits2PixelFormat
{$IFDEF PARANOIA} DB $3C, pf15bit {$ELSE} CMP AL, pf15bit {$ENDIF}
JNZ @@no15bit
CMP [EBP-szBIH].tBIH.biCompression, 0
JZ @@no15bit
INC AL // AL = pf16bit
@@no15bit:
MOV [EBX].fNewPixelFormat, AL
MOV EAX, szBIH + 1024
CALL System.@GetMem
MOV [EBX].fDIBHeader, EAX
XCHG EDX, EAX
LEA EAX, [EBP-szBIH]
XOR ECX, ECX
MOV CL, szBIH
CALL System.Move
MOV EAX, [EBP-szBIH].tBIH.biWidth
MOV [EBX].fWidth, EAX
MOV EAX, [EBP-szBIH].tBIH.biHeight
TEST EAX, EAX
JGE @@20
NEG EAX
@@20: MOV [EBX].fHeight, EAX
MOV EAX, EBX
CALL GetScanLineSize
MOV EDX, [EBX].fHeight
MUL EDX
MOV [EBX].fDIBSize, EAX
PUSH EAX
PUSH GMEM_FIXED or GMEM_ZEROINIT
CALL GlobalAlloc
MOV [EBX].fDIBBits, EAX
MOVZX EAX, [EBP-szBIH].tBIH.biBitCount
{$IFDEF PARANOIA} DB $3C, 8 {$ELSE} CMP AL, 8 {$ENDIF}
JA @@3
MOV AL, 4
MOVZX ECX, [EBP-szBIH].tBIH.biBitCount
SAL EAX, CL
XCHG ECX, EAX
@@3:
CMP [EBX].TBitmap.fNewPixelFormat, pf16bit
JNE @@30
XOR ECX, ECX
MOV CL, 12 // ColorCount = 12
@@30:
POP EAX // EAX = off
TEST EAX, EAX
JLE @@4
SUB EAX, szBFH + szBIH
CMP EAX, ECX
JZ @@4
XCHG ECX, EAX
@@4:
JECXZ @@5
PUSH ECX
MOV EDX, [EBX].fDIBHeader
ADD EDX, szBIH
MOV EAX, ESI
CALL TStream.Read
POP ECX
XOR EAX, ECX
JNZ @@eread
@@5:
MOV ECX, [EBX].fDIBSize
@@7:
PUSH ECX
MOV EAX, ESI
CALL TStream.GetPosition
PUSH EAX
MOV EAX, ESI
CALL TStream.GetSize
POP EDX
SUB EAX, EDX
POP ECX // Size = fDIBSize
CMP EAX, ECX // Strm.Size - Strm.Position > Size ?
JL @@8
XCHG ECX, EAX
@@8: // ++++++++++++++ 26-Oct-2003 VK see comment in Pascal
MOV EAX, [EBX].fDIBSize
CMP ECX, EAX
JGE @@9
SUB EAX, ECX
PUSH EAX
MOV EAX, ESI
PUSH ECX
CALL TStream.GetPosition
POP ECX
POP EDX
CMP EDX, EAX
JG @@9
MOV EAX, ESI
NEG EDX
XOR ECX, ECX
INC ECX
CALL TStream.Seek
MOV ECX, [EBX].fDIBSize
@@9: // ++++++++++++++
PUSH ECX
MOV EDX, [EBX].fDIBBits
MOV EAX, ESI
CALL TStream.Read
POP ECX
XOR EAX, ECX
POP EAX // Strm.Size - Position
POP ECX // fDIBSize
// end of reading bitmap
@@eread:
MOV ESP, EBP
POP EBP
POP EDX
JZ @@exit
// not success:
XCHG EAX, ESI
XOR ECX, ECX // ECX = spBegin
CALL TStream.Seek
XCHG EAX, EBX
CALL Clear
@@exit: POP ESI
POP EBX
end;
{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.LoadFromStream(Strm: PStream);
type
TColorsArray = array[ 0..15 ] of TColor;
PColorsArray = ^TColorsArray;
PColor = ^TColor;
var Pos : DWORD;
BFH : TBitmapFileHeader;
function ReadBitmap : Boolean;
var Size, Size1: Integer;
BCH: TBitmapCoreHeader;
RGBSize: DWORD;
C: PColor;
Off, HdSz, ColorCount: DWORD;
//BFHValid: Boolean;
begin
fHandleType := bmDIB;
Result := False;
//BFHValid := FALSE;
if Strm.Read( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit;
Off := 0; Size := 0;
if BFH.bfType <> $4D42 then
Strm.Seek( Pos, spBegin )
else
begin
//BFHValid := TRUE;
Off := BFH.bfOffBits - Sizeof( BFH );
Size := BFH.bfSize; // don't matter, just <> 0 is good
end;
RGBSize := 4;
HdSz := Sizeof( TBitmapInfoHeader );
fDIBHeader := AllocMem( 256*sizeof(TRGBQuad) + HdSz );
if Strm.Read( fDIBHeader.bmiHeader.biSize, Sizeof( DWORD ) ) <> Sizeof( DWORD ) then
Exit;
if fDIBHeader.bmiHeader.biSize = HdSz then
begin
if Strm.Read( fDIBHeader.bmiHeader.biWidth, HdSz - Sizeof( DWORD ) ) <>
HdSz - Sizeof( DWORD ) then
Exit;
end
else
if fDIBHeader.bmiHeader.biSize = Sizeof( TBitmapCoreHeader ) then
begin
RGBSize := 3;
HdSz := Sizeof( TBitmapCoreHeader );
if Strm.Read( BCH.bcWidth, HdSz - Sizeof( DWORD ) ) <>
HdSz - Sizeof( DWORD ) then
Exit;
fDIBHeader.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );
fDIBHeader.bmiHeader.biWidth := BCH.bcWidth;
fDIBHeader.bmiHeader.biHeight := BCH.bcHeight;
fDIBHeader.bmiHeader.biPlanes := BCH.bcPlanes;
fDIBHeader.bmiHeader.biBitCount := BCH.bcBitCount;
end
else Exit;
fNewPixelFormat := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount
* fDIBHeader.bmiHeader.biPlanes );
if (fNewPixelFormat = pf15bit) and (fDIBHeader.bmiHeader.biCompression <> BI_RGB) then
begin
ASSERT( fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS, 'Unsupported bitmap format' );
end;
fWidth := fDIBHeader.bmiHeader.biWidth;
ASSERT( fWidth > 0, 'Bitmap width must be > 0' );
fHeight := Abs(fDIBHeader.bmiHeader.biHeight);
ASSERT( fHeight > 0, 'Bitmap height must be > 0' );
fDIBSize := ScanLineSize * fHeight;
fDIBBits :=
Pointer( GlobalAlloc( GMEM_FIXED or GMEM_ZEROINIT, fDIBSize ) );
ASSERT( fDIBBits <> nil, 'No memory' );
ColorCount := 0;
if fDIBHeader.bmiHeader.biBitCount <= 8 then
begin
if fDIBHeader.bmiHeader.biClrUsed > 0 then
ColorCount := fDIBHeader.bmiHeader.biClrUsed * Sizeof( TRGBQuad )
else
ColorCount := (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad )
end
else if (fNewPixelFormat in [ pf16bit ]) or
(fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
ColorCount := 12;
if Off > 0 then
begin
Off := Off - HdSz;
if (Off <> ColorCount) then
if not(fNewPixelFormat in [pf15bit,pf16bit])
or (Off = 0) //+++ to fix loading 15- and 16-bit bmps with mask omitted
then
ColorCount := Min( 1024, Off );
end;
if ColorCount <> 0 then
begin
if Off >= ColorCount then
Off := Off - ColorCount;
if RGBSize = 4 then
begin
if Strm.Read( fDIBheader.bmiColors[ 0 ], ColorCount )
<> DWORD( ColorCount ) then Exit;
end
else
begin
C := @ fDIBHeader.bmiColors[ 0 ];
while ColorCount > 0 do
begin
if Strm.Read( C^, RGBSize ) <> RGBSize then Exit;
Dec( ColorCount, RGBSize );
Inc( C );
end;
end;
end;
if Off > 0 then
Strm.Seek( Off, spCurrent );
if (Size = 0) or (Strm.Size <= 0) then
Size := fDIBSize
else
Size := Min( fDIBSize, Strm.Size - Strm.Position );
Size1 := Min( Size, fDIBSize );
if (Size1 < fDIBSize)
and (DWORD( fDIBSize - Size1 ) <= Strm.Position) then
begin
Strm.Seek( Size1 - fDIBSize, spCurrent );
Size1 := fDIBSize;
end;
//if BFHValid and (Integer( Strm.Size - BFH.bfOffBits - Pos ) >= Integer( Size )) then
//if Strm.Position - Pos <= BFH.bfOffbits then
// Strm.Position := Pos + BFH.bfOffbits;
if Size1 > fDIBSize then Size1 := fDIBSize;
// +++++++++++++++++++ to fix some "incorrect" bitmaps while loading
if Strm.Read( fDIBBits^, Size1 ) <> DWORD( Size1 ) then Exit;
if Size > Size1 then
Strm.Seek( Size - Size1, spCurrent );
Result := True;
end;
begin
Clear;
Pos := Strm.Position;
if not ReadBitmap then
begin
Strm.Seek( Pos, spBegin );
Clear;
end;
end;
{$ENDIF ASM_VERSION}
////////////////// bitmap RLE-decoding and loading - by Vyacheslav A. Gavrik
// 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 );
//if fNewPixelFormat = pf15bit then fNewPixelFormat := pf16bit;
fWidth := fDIBHeader.bmiHeader.biWidth;
ASSERT( fWidth > 0, 'Bitmap width must be > 0' );
fHeight := Abs(fDIBHeader.bmiHeader.biHeight);
ASSERT( fHeight > 0, 'Bitmap height must be > 0' );
fDIBSize := ScanLineSize * fHeight;
ZI := 0;
if (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or
(fDIBHeader.bmiHeader.biCompression = BI_RLE4) then
ZI := GMEM_ZEROINIT;
fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED or ZI, fDIBSize + 4 ) );
ASSERT( fDIBBits <> nil, 'No memory' );
ASSERT( (fDIBHeader.bmiHeader.biCompression and
(BI_RLE8 or BI_RLE4 or BI_RLE8 or BI_BITFIELDS) <> 0) or
(fDIBHeader.bmiHeader.biCompression = BI_RGB),
'Unknown compression algorithm');
ColorCount := 0;
if fDIBHeader.bmiHeader.biBitCount <= 8 then
begin
if fDIBHeader.bmiHeader.biClrUsed > 0 then
ColorCount := fDIBHeader.bmiHeader.biClrUsed * Sizeof( TRGBQuad )
else
ColorCount := (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad )
end
else if (fNewPixelFormat in [ pf15bit, pf16bit ]) or
(fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
begin
if (Strm.Size = 0) or (Strm.Size - Strm.Position - DWORD( Size ) >= 12) then
ColorCount := 12;
end;
if ColorTriples then
ColorCount := ColorCount div 4 * 3;
if Off > 0 then
begin
Off := Off - SizeOf( TBitmapFileHeader ) - Sizeof( TBitmapInfoHeader );
if (Off <> ColorCount) and (fNewPixelFormat <= pf8bit) then
if ColorTriples then
ColorCount := min( Off, 3 * 256 )
else
ColorCount := min( Off, 4 * 256 );
end;
if (fNewPixelFormat in [ pf15bit, pf16bit ]) then
if (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
begin
PDWORD( DWORD( @ fDIBHeader.bmiColors[ 0 ] ) + 8 )^ := ( $00001F );
PDWORD( DWORD( @ fDIBHeader.bmiColors[ 0 ] ) + 4 )^ := ( $0007E0 );
TColor( fDIBHeader.bmiColors[ 0 ] ) := ( $00F800 );
end
else
begin
ColorCount := 0;
end;
if ColorCount <> 0 then
if ColorTriples then
begin
PColr := @ fDIBheader.bmiColors[ 0 ];
while ColorCount >= 3 do
begin
if strm.Read( PColr^, 3 ) <> 3 then Exit;
Inc( PColr );
Dec( ColorCount, 3 );
end;
end
else
begin
if (Integer( Strm.Size - Strm.Position ) > fDIBSize) or
(fDIBHeader.bmiHeader.biCompression = BI_RLE8) or
(fDIBHeader.bmiHeader.biCompression = BI_RLE4) then
begin
if Strm.Read( fDIBheader.bmiColors[ 0 ], ColorCount )
<> DWORD( ColorCount ) then Exit;
if Off - ColorCount > 0 then
Strm.Position := Integer( Strm.Position ) + Off - ColorCount;
end;
end;
if not BFHValid then
Size := fDIBSize
else
if (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or
(fDIBHeader.bmiHeader.biCompression = BI_RLE4) then
begin
//if BFHValid then //-- already TRUE here
Size := BFH.bfSize - BFH.bfOffBits;
end
else
begin
if (Strm.Size = 0) or
(Integer( Strm.Size - BFH.bfOffBits - Pos ) > Integer(Size)) then
Size := fDIBSize
else
Size := Strm.Size - BFH.bfOffBits - DWORD( Pos );
if Size > fDIBSize then Size := fDIBSize
else if (Size < fDIBSize) and (fDIBheader.bmiHeader.biClrUsed <> 0) then
begin
BFHValid := FALSE;
Strm.Position := Strm.Position + fDIBheader.bmiHeader.biClrUsed * 4;
Size := Strm.Size - Strm.Position;
end;
end;
if (fDIBHeader.bmiHeader.biCompression = BI_RGB) or
(fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
begin
if BFHValid and
( (Strm.Size > 0) and
(Integer( Strm.Size - BFH.bfOffBits - Pos) > Integer(Size))
or
(Strm.Size = 0) and
(Off > 0)
) then
if Integer( Strm.Position - Pos ) <= Integer( BFH.bfOffbits ) then
Strm.Position := Pos + BFH.bfOffbits;
i := Strm.Read( fDIBBits^, Size );
if i <> Size then
begin
//Exit;
{$IFDEF FILL_BROKEN_BITMAP}
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 );
//Size := Size * 3;
L := Strm.Size - Strm.Position;
if L > DWORD( Size ) then
L := Size;
Buffer := AllocMem( Size * 3 );
if Strm.Read(Buffer^,L) <> DWORD( L ) then ; //Exit;
if fDIBHeader.bmiHeader.biCompression=BI_RLE8 then
DecodeRLE8(@Self,Buffer,Size * 3)
else
DecodeRLE4(@Self,Buffer,Size * 3);
Strm.Position := FinalPos;
fDIBHeader.bmiHeader.biCompression := BI_RGB;
FreeMem(Buffer);
end;
Result := True;
end;
begin
Clear;
Pos := Strm.Position;
result := ReadBitmap;
if not result then
begin
Strm.Seek( Pos, spBegin );
Clear;
end;
end;
///////////////////////////
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TBitmap.ReleaseHandle: HBitmap;
var OldBits: Pointer;
begin
HandleType := bmDIB;
Result := GetHandle;
if Result = 0 then Exit; // only when bitmap is empty
if fDIBAutoFree then
begin
OldBits := fDIBBits;
fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED {or GMEM_ZEROINIT}, fDIBSize ) );
Move( OldBits^, fDIBBits^, fDIBSize );
fDIBAutoFree := FALSE;
end;
fHandle := 0;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SaveToFile(const Filename: KOLString);
var Strm: PStream;
begin
if Empty then Exit;
Strm := NewWritefileStream( Filename );
SaveToStream( Strm );
Strm.Free;
end;
{$ENDIF ASM_VERSION}
{$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 ASM_VERSION} //Pascal
procedure TBitmap.SaveToStream(Strm: PStream);
var BFH : TBitmapFileHeader;
Pos : Integer;
function WriteBitmap : Boolean;
var ColorsSize, BitsSize, Size : Integer;
begin
Result := False;
if Empty then Exit;
HandleType := bmDIB; // convert to DIB if DDB
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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SetHandle(const Value: HBitmap);
var B: tagBitmap;
Dib: TDIBSection;
begin
Clear;
if Value = 0 then Exit;
if (WinVer >= wvNT) and
(GetObject( Value, Sizeof( Dib ), @ Dib ) = Sizeof( Dib )) then
begin
fHandle := Value;
fHandleType := bmDIB;
fDIBHeader := PrepareBitmapHeader( Dib.dsBm.bmWidth, Dib.dsBm.bmHeight,
Dib.dsBm.bmBitsPixel );
Move( Dib.dsBitfields, fDIBHeader.bmiColors, 3 * 4 );
fWidth := Dib.dsBm.bmWidth;
fHeight := Dib.dsBm.bmHeight;
fDIBBits := Dib.dsBm.bmBits;
fDIBSize := Dib.dsBmih.biSizeImage;
fDIBAutoFree := true;
end
else
begin
if GetObject( Value, Sizeof( B ), @B ) = 0 then Exit;
fHandle := Value;
fWidth := B.bmWidth;
fHeight := B.bmHeight;
fHandleType := bmDDB;
end;
end;
{$ENDIF ASM_VERSION}
procedure TBitmap.SetWidth(const Value: Integer);
begin
if fWidth = Value then Exit;
fWidth := Value;
FormatChanged;
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SetPixelFormat(Value: TPixelFormat);
begin
if PixelFormat = Value then Exit;
if Empty then Exit;
if Value = pfDevice then
HandleType := bmDDB
else
begin
fNewPixelFormat := Value;
HandleType := bmDIB;
FormatChanged;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer;
begin
Result := ((Header.biBitCount * Header.biWidth + 31) shr 3) and $FFFFFFFC;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure FillBmpWithBkColor( Bmp: PBitmap; DC2: HDC; oldWidth, oldHeight: Integer );
var oldBmp: HBitmap;
R: TRect;
Br: HBrush;
begin
with Bmp^ do
if Color2RGB( fBkColor ) <> 0 then
if (oldWidth < fWidth) or (oldHeight < fHeight) then
if GetHandle <> 0 then
begin
oldBmp := SelectObject( DC2, fHandle );
ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
Br := CreateSolidBrush( Color2RGB( fBkColor ) );
R := MakeRect( oldWidth, oldHeight, fWidth, fHeight );
if oldWidth = fWidth then
R.Left := 0;
if oldHeight = fHeight then
R.Top := 0;
Windows.FillRect( DC2, R, Br );
DeleteObject( Br );
SelectObject( DC2, oldBmp );
end;
end;
{$ENDIF ASM_VERSION}
const BitCounts: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.FormatChanged;
// This method is used whenever Width, Height, PixelFormat or HandleType
// properties are changed.
// Old image will be drawn here to a new one (excluding cases when
// old width or height was 0, and / or new width or height is 0).
// To avoid inserting this code into executable, try not to change
// properties Width / Height of bitmat after it is created using
// NewBitmap( W, H ) function or after it is loaded from file, stream
// or resource.
var B: tagBitmap;
oldBmp, NewHandle: HBitmap;
DC0, DC2: HDC;
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 );
ASSERT( NewHandle <> 0, 'Can not create DDB' );
ReleaseDC( 0, DC0 );
oldBmp := SelectObject( DC2, NewHandle );
ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
Br := CreateSolidBrush( Color2RGB( fBkColor ) );
FillRect( DC2, MakeRect( 0, 0, fWidth, fHeight ), Br );
DeleteObject( Br );
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 ) );
ASSERT( NewBits <> nil, 'No memory' );
Hndl := GetHandle;
if Hndl = 0 then Exit;
N :=
GetDIBits( DC2, Hndl, 0, Min( fHeight, oldHeight ),
NewBits, NewHeader^, DIB_RGB_COLORS );
if N <> Min( fHeight, oldHeight ) then
begin
GlobalFree( DWORD( NewBits ) );
NewBits := nil;
NewHandle := CreateDIBSection( DC2, NewHeader^, DIB_RGB_COLORS, NewBits, 0, 0 );
NewDIBAutoFree := TRUE;
ASSERT( NewHandle <> 0, 'Can not create DIB secion for pf16bit bitmap' );
oldBmp := SelectObject( DC2, NewHandle );
ASSERT( oldBmp <> 0, 'Can not select pf16bit to DC' );
Draw( DC2, 0, 0 );
SelectObject( DC2, oldBmp );
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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetScanLine(Y: Integer): Pointer;
begin
ASSERT( (Y >= 0) {and (Y < fHeight)}, 'ScanLine index out of bounds' );
ASSERT( fDIBBits <> nil, 'No bits available' );
Result := nil;
if fDIBHeader = nil then Exit;
if fDIBHeader.bmiHeader.biHeight > 0 then
Y := fHeight - 1 - Y;
if fScanLineSize = 0 then
ScanLineSize;
Result := Pointer( Integer( fDIBBits ) + fScanLineSize * Y );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetScanLineSize: Integer;
begin
Result := 0;
if fDIBHeader = nil then Exit;
FScanLineSize := CalcScanLineSize( @fDIBHeader.bmiHeader );
Result := FScanLineSize;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.CanvasChanged( Sender : PObj );
begin
fBkColor := PCanvas( Sender ).Brush.Color;
ClearTransImage;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.Dormant;
begin
RemoveCanvas;
if fHandle <> 0 then
DeleteObject( ReleaseHandle );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SetBkColor(const Value: TColor);
begin
if fBkColor = Value then Exit;
fBkColor := Value;
fFillWithBkColor := FillBmpWithBkColor;
if Assigned( fApplyBkColor2Canvas ) then
fApplyBkColor2Canvas( @Self );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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} );
ASSERT( fHandle <> 0, 'Can not copy bitmap image' );
Result := fHandle <> 0;
if not Result then Clear;
end
else
begin
GetMem( fDIBHeader, Sizeof(TBitmapInfoHeader) + 256*sizeof(TRGBQuad) );
ASSERT( fDIBHeader <> nil, 'No memory' );
Move( SrcBmp.fDIBHeader^, fDIBHeader^, Sizeof(TBitmapInfoHeader) + 256*sizeof(TRGBQuad) );
fDIBSize := SrcBmp.fDIBSize;
fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED {or GMEM_ZEROINIT}, fDIBSize ) );
ASSERT( fDIBBits <> nil, 'No memory' );
Move( SrcBmp.fDIBBits^, fDIBBits^, fDIBSize );
Result := True;
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.RemoveCanvas;
begin
fDetachCanvas( @Self );
fCanvas.Free;
fCanvas := nil;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TBitmap.DIBPalNearestEntry(Color: TColor): Integer;
var I, Diff, D: Integer;
C : Integer;
begin
Color := TColor( Color2RGBQuad( Color ) );
Result := 0;
Diff := MaxInt;
for I := 0 to DIBPalEntryCount - 1 do
begin
C := Color xor PInteger( 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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetDIBPalEntries(Idx: Integer): TColor;
begin
Result := TColor(-1);
if fDIBBits = nil then Exit;
ASSERT( PixelFormat in [pf1bit..pf8bit], 'Format has no DIB palette entries available' );
ASSERT( (Idx >= 0) and (Idx < (1 shl fDIBHeader.bmiHeader.biBitCount)),
'DIB palette index out of bounds' );
Result := PDWORD( Integer( @fDIBHeader.bmiColors[ 0 ] )
+ Idx * Sizeof( TRGBQuad ) )^;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetDIBPalEntryCount: Integer;
begin
Result := 0;
if Empty then Exit;
case PixelFormat of
pf1bit: Result := 2;
pf4bit: Result := 16;
pf8bit: Result := 256;
else;
end;
end;
{$ENDIF ASM_VERSION}
procedure TBitmap.SetDIBPalEntries(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
Assert( fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS, 'Unsupported bitmap format' );
if (TColor( fDIBHeader.bmiColors[ 0 ] ) = $F800) and
(PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+4 )^ = $7E0) and
(PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+8 )^ = $1F) then
Result := pf16bit
else
if (TColor( fDIBHeader.bmiColors[ 0 ] ) = $7C00) and
(PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+4 )^ = $3E0) and
(PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+8 )^ = $1F) then
Result := pf15bit
else
Result := pfCustom;
end;
end;
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.ClearTransImage;
begin
fTransColor := clNone;
fTransMaskBmp.Free;
fTransMaskBmp := nil;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
{$IFDEF USE_OLDCONVERT2MASK}
procedure TBitmap.Convert2Mask(TranspColor: TColor);
var MonoHandle: HBitmap;
SaveMono, SaveFrom: THandle;
MonoDC, {DC0,} DCfrom: HDC;
SaveBkColor: TColorRef;
begin
if GetHandle = 0 then Exit;
fDetachCanvas( @Self );
///DC0 := GetDC( 0 );
MonoHandle := CreateBitmap( fWidth, fHeight, 1, 1, nil );
ASSERT( MonoHandle <> 0, 'Can not create monochrome bitmap' );
MonoDC := CreateCompatibleDC( 0 );
SaveMono := SelectObject( MonoDC, MonoHandle );
ASSERT( SaveMono <> 0, 'Can not select bitmap to DC' );
DCfrom := CreateCompatibleDC( 0 );
SaveFrom := SelectObject( DCfrom, fHandle );
ASSERT( SaveFrom <> 0, 'Can not select source bitmap to DC' );
TranspColor := Color2RGB( TranspColor );
SaveBkColor := Windows.SetBkColor( DCfrom, TranspColor );
BitBlt( MonoDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, SRCCOPY );
{$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
Windows.SetBkColor( DCfrom, SaveBkColor );
SelectObject( DCfrom, SaveFrom );
DeleteDC( DCfrom );
SelectObject( MonoDC, SaveMono );
DeleteDC( MonoDC );
///ReleaseDC( 0, DC0 );
ClearData;
fHandle := MonoHandle;
fHandleType := bmDDB;
end;
{$ELSE NOT USE_OLDCONVERT2MASK} //Pascal
procedure TBitmap.Convert2Mask(TranspColor: TColor);
var Y, X, i: Integer;
Src, Dst: PByte;
W: Word;
TmpMsk: PBitmap;
B, C: Byte;
TranspColor32: TColor;
begin
HandleType := bmDIB;
if PixelFormat < pf4bit then
PixelFormat := pf4bit;
if PixelFormat > pf32bit then
PixelFormat := pf32bit;
TranspColor := Color2RGB( TranspColor ) and $FFFFFF;
TranspColor32 := TColor( Color2RGBQuad( TranspColor ) );
TmpMsk := NewDIBBitmap( fWidth, fHeight, pf1bit );
TmpMsk.DIBPalEntries[ 1 ] := $FFFFFF;
for Y := 0 to fHeight-1 do
begin
Src := ScanLine[ Y ];
Dst := TmpMsk.ScanLine[ Y ];
B := 0; C := 8;
CASE PixelFormat OF
pf4bit:
begin
W := 16;
for i := 0 to 15 do
if DIBPalEntries[ i ] = TranspColor32 then
begin
W := i; break;
end;
for X := 0 to (fWidth div 2)-1 do
begin
B := B shl 1;
if Src^ shr 4 = W then inc( B );
B := B shl 1;
if Src^ and $0F = W then inc( B );
Inc( Src );
Dec( C, 2 );
if C = 0 then
begin
Dst^ := B;
Inc( Dst );
C := 8;
end;
end;
end;
pf8bit:
begin
W := 256;
for i := 0 to 255 do
if DIBPalEntries[ i ] = TranspColor32 then
begin
W := i; break;
end;
for X := 0 to fWidth-1 do
begin
B := B shl 1;
if Src^ = W then inc( B );
Inc( Src );
Dec( C );
if C = 0 then
begin
Dst^ := B;
Inc( Dst );
C := 8;
end;
end;
end;
pf15bit:
begin
W := Color2Color15( TranspColor );
for X := 0 to fWidth-1 do
begin
B := B shl 1;
if PWord( Src )^ = W then inc( B );
Inc( Src, 2 );
Dec( C );
if C = 0 then
begin
Dst^ := B;
Inc( Dst );
C := 8;
end;
end;
end;
pf16bit:
begin
W := Color2Color16( TranspColor );
for X := 0 to fWidth-1 do
begin
B := B shl 1;
if PWord( Src )^ = W then inc( B );
Inc( Src, 2 );
Dec( C );
if C = 0 then
begin
Dst^ := B;
Inc( Dst );
C := 8;
end;
end;
end;
pf24bit:
begin
for X := 0 to fWidth-1 do
begin
B := B shl 1;
if PInteger( Src )^ and $FFFFFF = TranspColor32 then inc( B );
Inc( Src, 3 );
Dec( C );
if C = 0 then
begin
Dst^ := B;
Inc( Dst );
C := 8;
end;
end;
end;
pf32bit:
begin
for X := 0 to fWidth-1 do
begin
B := B shl 1;
if PInteger( Src )^ and $FFFFFF = TranspColor32 then inc( B );
Inc( Src, 4 );
Dec( C );
if C = 0 then
begin
Dst^ := B;
Inc( Dst );
C := 8;
end;
end;
end;
END;
if (C > 0) and (C < 8) then
begin
while C > 0 do
begin
B := B shl 1;
dec( C );
end;
Dst^ := B;
end;
end;
Assign( TmpMsk );
TmpMsk.Free;
end;
{$ENDIF USE_OLDCONVERT2MASK} //Pascal
{$ENDIF ASM_VERSION}
procedure TBitmap.Invert;
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 ASM_VERSION} //Pascal
procedure _RotateBitmapMono( var DstBmp: PBitmap; SrcBmp: PBitmap );
var X, Y, Z, Shf, Wbytes, BytesPerDstLine: Integer;
Src, Dst, Dst1: PByte;
Tmp: Byte;
begin
DstBmp := NewDIBBitmap( SrcBmp.fHeight, (SrcBmp.fWidth + 7) and not 7, pf1bit );
Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 2 * Sizeof( TRGBQuad ) );
// Calculate ones:
Dst := DstBmp.ScanLine[ 0 ];
BytesPerDstLine := 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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure _RotateBitmap4bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
var X, Y, Shf, Wbytes, BytesPerDstLine: Integer;
Src, Dst, Dst1: PByte;
Tmp: Byte;
begin
DstBmp := NewDIBBitmap( SrcBmp.fHeight, (SrcBmp.fWidth + 1) and not 1, pf4bit );
Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 16 * Sizeof( TRGBQuad ) );
// Calculate ones:
Dst := DstBmp.ScanLine[ 0 ];
BytesPerDstLine := 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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure _RotateBitmap8bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
var X, Y, Wbytes, BytesPerDstLine: Integer;
Src, Dst, Dst1: PByte;
Tmp: Byte;
begin
DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );
Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 256 * Sizeof( TRGBQuad ) );
// Calculate ones:
Wbytes := SrcBmp.fWidth;
Dst := DstBmp.ScanLine[ 0 ];
BytesPerDstLine := 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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure _RotateBitmap16bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
var X, Y, Wwords, BytesPerDstLine: Integer;
Src, Dst, Dst1: PWord;
Tmp: Word;
begin
DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );
Wwords := SrcBmp.fWidth;
Dst := DstBmp.ScanLine[ 0 ];
BytesPerDstLine := 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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure _RotateBitmap2432bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
var X, Y, Wwords, BytesPerDstLine, IncW: Integer;
Src, Dst, Dst1: PDWord;
Tmp: DWord;
begin
DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );
// Calculate ones:
IncW := 4;
if DstBmp.PixelFormat = pf24bit then
IncW := 3;
Wwords := SrcBmp.fWidth;
Dst := DstBmp.ScanLine[ 0 ];
BytesPerDstLine := 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 ASM_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 ASM_VERSION} //Pascal
procedure _RotateBitmapRight( SrcBmp: PBitmap );
var DstBmp: PBitmap;
RotateProc: procedure( var DstBmp: PBitmap; SrcBmp: PBitmap );
begin
if SrcBmp.fHandleType <> bmDIB then Exit;
case SrcBmp.PixelFormat of
pf1bit: RotateProc := RotateProcs.proc_RotateBitmapMono;
pf4bit: RotateProc := RotateProcs.proc_RotateBitmap4bit;
pf8bit: RotateProc := RotateProcs.proc_RotateBitmap8bit;
pf15bit, pf16bit: RotateProc := RotateProcs.proc_RotateBitmap16bit;
else RotateProc := RotateProcs.proc_RotateBitmap2432bit;
end;
if not Assigned( RotateProc ) then Exit;
RotateProc( DstBmp, SrcBmp );
if DstBmp.fHeight > SrcBmp.fWidth then
begin
DstBmp.fDIBSize := DstBmp.fScanLineSize * SrcBmp.fWidth;
if DstBmp.fDIBHeader.bmiHeader.biHeight > 0 then
Move( DstBmp.ScanLine[ SrcBmp.fWidth - 1 ]^, DstBmp.ScanLine[ DstBmp.fHeight - 1 ]^,
DstBmp.fDIBSize );
DstBmp.fHeight := SrcBmp.fWidth;
DstBmp.fDIBHeader.bmiHeader.biHeight := DstBmp.fHeight;
end;
SrcBmp.ClearData;
SrcBmp.fDIBHeader := DstBmp.fDIBHeader;
DstBmp.fDIBHeader := nil;
SrcBmp.fDIBBits := DstBmp.fDIBBits;
DstBmp.fDIBBits := nil;
SrcBmp.fDIBAutoFree := DstBmp.fDIBAutoFree;
SrcBmp.fDIBSize := DstBmp.fDIBSize;
SrcBmp.fWidth := DstBmp.fWidth;
SrcBmp.fHeight := DstBmp.fHeight;
DstBmp.Free;
end;
{$ENDIF ASM_VERSION}
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 ASM_VERSION} //Pascal
function TBitmap.GetPixels(X, Y: Integer): TColor;
var DC: HDC;
Save: THandle;
begin
Result := clNone;
//if GetHandle = 0 then Exit;
if Empty then Exit;
fDetachCanvas( @Self );
DC := CreateCompatibleDC( 0 );
Save := SelectObject( DC, GetHandle );
ASSERT( Save <> 0, 'Can not select bitmap to DC' );
Result := Windows.GetPixel( DC, X, Y );
SelectObject( DC, Save );
DeleteDC( DC );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SetPixels(X, Y: Integer; const Value: TColor);
var DC: HDC;
Save: THandle;
begin
//if GetHandle = 0 then Exit;
if Empty then Exit;
fDetachCanvas( @Self );
DC := CreateCompatibleDC( 0 );
Save := SelectObject( DC, GetHandle );
ASSERT( Save <> 0, 'Can not select bitmap to DC' );
Windows.SetPixel( DC, X, Y, Color2RGB( Value ) );
SelectObject( DC, Save );
DeleteDC( DC );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function TBitmap.GetDIBPixels(X, Y: Integer): TColor;
begin
if not Assigned( fGetDIBPixels ) then
begin
if fHandleType = bmDIB then
begin
fScanLine0 := ScanLine[ 0 ];
fScanLineDelta := 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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure _SetDIBPixels1bit( Bmp: PBitmap; X, Y: Integer; Value: TColor );
var Pixel: Byte;
Pos: PByte;
Shf: Integer;
begin
Value := Color2RGB( Value );
if ((Value shr 16) and $FF) + ((Value shr 8) and $FF) + (Value and $FF)
< 255 * 3 div 2 then Pixel := 0 else Pixel := $80;
Pos := PByte( 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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure _SetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer; Value: TColor );
var Pixel: Byte;
Pos: PByte;
Shf: Integer;
begin
Pixel := Bmp.DIBPalNearestEntry( Value );
Pos := PByte( 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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure _SetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer; Value: TColor );
var RGB16: Word;
Pos: PWord;
begin
Value := Color2RGB( Value );
if Bmp.fPixelMask = 15 then
RGB16 := (Value shr 19) and $001F or (Value shr 6) and $03E0
or (Value shl 7) and $7C00
else
RGB16 := (Value shr 19) and $001F or (Value shr 5) and $07E0
or (Value shl 8) and $F800;
Pos := PWord( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta + X * 2 );
Pos^ := RGB16;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure _SetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer; Value: TColor );
var RGB: TRGBQuad;
Pos: PDWord;
begin
RGB := Color2RGBQuad( Value );
Pos := PDWORD( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta
+ X * Bmp.fBytesPerPixel );
Pos^ := Pos^ and $FF000000 or DWORD(RGB);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.SetDIBPixels(X, Y: Integer; const Value: TColor);
begin
if not Assigned( fSetDIBPixels ) then
begin
if fHandleType = bmDIB then
begin
fScanLine0 := ScanLine[ 0 ];
fScanLineDelta := 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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.FlipVertical;
var DC: HDC;
Save: THandle;
TmpScan: PByte;
Y: Integer;
begin
if fHandle <> 0 then
begin
fDetachCanvas( @Self );
DC := CreateCompatibleDC( 0 );
Save := SelectObject( DC, fHandle );
StretchBlt( DC, 0, fHeight - 1, fWidth, -fHeight, DC, 0, 0, fWidth, fHeight, SRCCOPY );
SelectObject( DC, Save );
DeleteDC( DC );
end
else
if fDIBBits <> nil then
begin
GetMem( TmpScan, ScanLineSize );
for Y := 0 to fHeight div 2-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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.FlipHorizontal;
var DC: HDC;
Save: THandle;
begin
if GetHandle <> 0 then
begin
fDetachCanvas( @Self );
DC := CreateCompatibleDC( 0 );
Save := SelectObject( DC, fHandle );
StretchBlt( DC, fWidth - 1, 0, -fWidth, fHeight, DC, 0, 0, fWidth, fHeight, SRCCOPY );
SelectObject( DC, Save );
DeleteDC( DC );
end;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TBitmap.CopyRect(const DstRect: TRect; SrcBmp: PBitmap;
const SrcRect: TRect);
var DCsrc, DCdst: HDC;
SaveSrc, SaveDst: THandle;
begin
if (GetHandle = 0) or (SrcBmp.GetHandle = 0) then Exit;
fDetachCanvas( @Self );
SrcBmp.fDetachCanvas( SrcBmp );
DCsrc := CreateCompatibleDC( 0 );
SaveSrc := SelectObject( DCsrc, SrcBmp.fHandle );
DCdst := DCsrc;
SaveDst := 0;
if SrcBmp <> @Self then
begin
DCdst := CreateCompatibleDC( 0 );
SaveDst := SelectObject( DCdst, fHandle );
end;
StretchBlt( DCdst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
DstRect.Bottom - DstRect.Top, DCsrc, SrcRect.Left, SrcRect.Top,
SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top,
SRCCOPY );
if SrcBmp <> @Self then
begin
SelectObject( DCdst, SaveDst );
DeleteDC( DCdst );
end;
SelectObject( DCsrc, SaveSrc );
DeleteDC( DCsrc );
end;
{$ENDIF ASM_VERSION}
function TBitmap.CopyToClipboard: 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;
//DIBPtr: PAnsiChar;
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.SaveToFile( GetStartDir + 'test_paste.bmp', 0, Strm.Size );
Strm.Free;
Result := not Empty;
end;
FINALLY
GlobalUnlock( Gbl );
END;
end;
end;
FINALLY
CloseClipboard;
END;
end;
///////////////////////////////////////////////////////////////////////
// I C O N
///////////////////////////////////////////////////////////////////////
{ -- icon -- }
function NewIcon: 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 ASM_VERSION} //Pascal
procedure TIcon.Clear;
begin
if fHandle <> 0 then
begin
if not FShareIcon then
DestroyIcon( fHandle );
fHandle := 0;
end;
fShareIcon := False;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_LOCAL}
{$UNDEF ASM_LOCAL}
{$ENDIF}
{$IFNDEF ICON_DIFF_WH}
{$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF}
{$ENDIF}
{$IFDEF ASM_LOCAL}
{$ELSE ASM_VERSION} //Pascal
function TIcon.Convert2Bitmap(TranColor: TColor): HBitmap;
var DC0, DC2: HDC;
Save: THandle;
Br: HBrush;
begin
Result := 0;
if Empty then Exit;
DC0 := GetDC( 0 );
DC2 := CreateCompatibleDC( DC0 );
{$IFDEF ICON_DIFF_WH}
Result := CreateCompatibleBitmap( DC0, fWidth, fHeight );
{$ELSE}
Result := CreateCompatibleBitmap( DC0, fSize, fSize );
{$ENDIF}
Save := SelectObject( DC2, Result );
Br := CreateSolidBrush( Color2RGB( TranColor ) );
{$IFDEF ICON_DIFF_WH}
FillRect( DC2, MakeRect( 0, 0, fWidth, fHeight ), Br );
{$ELSE}
FillRect( DC2, MakeRect( 0, 0, fSize, fSize ), Br );
{$ENDIF}
DeleteObject( Br );
Draw( DC2, 0, 0 );
SelectObject( DC2, Save );
DeleteDC( DC2 );
ReleaseDC( 0, DC0 );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
destructor TIcon.Destroy;
begin
Clear;
inherited;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TIcon.Draw(DC: HDC; X, Y: Integer);
begin
if Empty then Exit;
{$IFDEF ICON_DIFF_WH}
DrawIconEx( DC, X, Y, fHandle, fWidth, fHeight, 0, 0, DI_NORMAL );
{$ELSE}
DrawIconEx( DC, X, Y, fHandle, fSize, fSize, 0, 0, DI_NORMAL );
{$ENDIF}
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TIcon.StretchDraw(DC: HDC; Dest: TRect);
begin
if Empty then Exit;
DrawIconEx( DC, Dest.Left, Dest.Top, FHandle, Dest.Right - Dest.Left,
Dest.Bottom - Dest.Top, 0, 0, DI_NORMAL );
end;
{$ENDIF ASM_VERSION}
function TIcon.GetEmpty: 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 ASM_VERSION} //Pascal
procedure TIcon.SaveToFile(const FileName: KOLString);
begin
SaveIcons2File( [ @Self ], FileName );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
procedure TIcon.SaveToStream(Strm: PStream);
begin
SaveIcons2Stream( [ @Self ], Strm );
end;
{$ENDIF ASM_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 ASM_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 ASM_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 ASM_VERSION} //Pascal
function ColorBits( ColorsCount : Integer ) : Integer;
var I : Integer;
begin
for I := 1 to 6 do
begin
Result := PossibleColorBits[ I ];
if (1 shl Result) >= ColorsCount then break;
end;
end;
{$ENDIF ASM_VERSION}
function SaveIcons2StreamEx( const BmpHandles: array of HBitmap; Strm: PStream ): Boolean;
var I, Off : Integer;
IDI : TIconDirEntry;
BIH : TBitmapInfoHeader;
B: TagBitmap;
function RGBArraySize : Integer;
begin
Result := 0;
if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then
Result := (IDI.bColorCount + (IDI.bReserved shl 8)) * Sizeof( TRGBQuad );
end;
function ColorDataSize( W, H: Integer ) : Integer;
var N: Integer;
begin
if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then
N := (ColorBits( IDI.bColorCount + (IDI.bReserved shl 8) ) )
else
begin
N := IDI.wBitCount;
end;
Result := ((N * W + 31) div 32) * 4
* H;
end;
function MaskDataSize( W, H: Integer ) : Integer;
begin
Result := ((W + 31) div 32) * 4 * H;
end;
var BColor, BMask: HBitmap;
W, H: Integer;
ImgBmp, MskBmp: PBitmap;
IH : TIconHeader;
Colors : PList;
begin
Assert( (High(BmpHandles) >= 0) and (High(BmpHandles) and 1 <> 0),
'Incorrect parameters count in call to SaveIcons2StreamEx' );
Result := False;
IH.idReserved := 0;
IH.idType := 1;
IH.idCount := (High( BmpHandles )+1) div 2;
if Strm.Write( IH, Sizeof( IH ) ) <> Sizeof( IH ) then Exit;
Off := Sizeof( IH ) + IH.idCount * Sizeof( IDI );
Colors := NewList;
ImgBmp := NewBitmap( 0, 0 );
MskBmp := NewBitmap( 0, 0 );
TRY
for I := 0 to High( BmpHandles ) div 2 do
begin
BColor := BmpHandles[ I * 2 ];
BMask := BmpHandles[ I * 2 + 1 ];
if (BColor = 0) and (BMask = 0) then break;
Assert( BMask <> 0, 'Mask bitmap not provided for saving icons in SaveIcons2StreamEx' );
GetObject( BMask, Sizeof( B ), @ B );
W := B.bmWidth;
H := B.bmHeight;
if BColor <> 0 then
begin
GetObject( BColor, Sizeof( B ), @B );
Assert( (B.bmWidth = W) and (B.bmHeight = H),
'Mask bitmap size must much color bitmap size in SaveIcons2StreamEx' );
end;
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}
or
{$IFDEF USE_FLAGS} (G4_CreateHidden in fFlagsG4)
{$ELSE} fCreateHidden {$ENDIF} ))
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
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_VERSION}{$ELSE PAS_VERSION} // Pascal
procedure AlignChildrenProc(Sender: PObj);
function ToBeAlign( S: PControl ):Boolean;
begin
Result := (
{$IFDEF USE_FLAGS} (F3_Visible in S.fStyle.f3_Style)
{$ELSE} S.fVisible {$ENDIF}
or
{$IFDEF USE_FLAGS} (G3_IsForm in S.fFlagsG3) // !
{$ELSE} S.fCreateHidden {$ENDIF}
)
and ( {$IFDEF USE_FLAGS} (G3_IsForm in S.fFlagsG3)
{$ELSE} S.fIsForm {$ENDIF}
or (S.fParent=nil) or ToBeAlign(S.fParent)
);
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 ToBeAlign(S) then
AlignChildrenProc_(S);
end;
{$ENDIF ASM_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 {$IFDEF USE_FLAGS} G1_NotUpdate in fFlagsG1
{$ELSE} fNotUpdate {$ENDIF} 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 ASM_VERSION} //Pascal
function WndProcUpdate( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
begin
if Sender.fUpdateCount <> 0 then
begin
case Msg.message of
WM_PAINT:
begin
ValidateRect( Sender.Handle, nil );
Rslt := 0;
end;
WM_ERASEBKGND: Rslt := 1;
else begin
Result := FALSE;
Exit;
end;
end;
Result := TRUE;
end
else Result := FALSE;
end;
{$ENDIF ASM_VERSION}
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;
Assert( FromLine >= 0, 'Incorrect line index' );
I1 := Item2Pos( FromLine );
I2 := Item2Pos( ToLine+1 ) - I1;
SStart := SelStart;
SLength := SelLength;
SelStart := I1;
{if ToLine >= Count-1 then
I2 := MaxInt;}
SelLength := I2;
ReplaceSelection( '', TRUE );
if SStart >= I2 then
begin
SStart := SStart - (I2 - I1);
end
else
if SStart >= I1 then
begin
SLength := SLength - (I2 - SStart);
SStart := I1;
end
else
if SStart + SLength >= I2 then
begin
SLength := SLength - (I2 - I1);
end
else
if SStart + SLength >= I1 then
begin
SLength := I1 - SLength;
end;
SelStart := SStart;
SelLength := Max( 0, SLength );
end;
procedure TControl.SetTabOrder(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;
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;
{$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
CF := @DF.fRECharFormatRec;
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 := AnsiString(@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
CF := @DF.fRECharFormatRec;
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;
CF := @DF.fRECharFormatRec;
CF.dwEffects := $FFFFFFFF and Index;
if not Value then CF.dwEffects := 0;
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;
CF := Pointer( Integer( @DF.fRECharFormatRec ) + (HiWord(Index) and $7E) );
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( @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} //------- WideString not supported in D2
function TControl.RE_WSearchText(const Value: WideString; 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;
//NB := rnbPlain;
Exit;
end
else
if Ord( NB ) = 0 then
NB := High(NB) else
NB := Pred(NB);
_Self_.RE_NumBrackets := NB;
end
else
begin
NS := _Self_.RE_NumStyle;
if Ord( NS ) = 0 then
begin
NS := rnURoman; //rnULetter; //High( NS );
{ because rnLRoman, rnURoman, rnNoNumber are not shown
in RichEdit. }
_Self_.RE_NumBrackets := rnbPeriod;
end else
NS := Pred(NS);
_Self_.RE_NumStyle := NS;
if NS in [ rnLRoman, rnURoman, rnArabic ] then
_Self_.RE_NumStart := 1;
end;
Exit;
end;
Integer('W'): begin
Delta := _Self_.RE_BorderWidth[ beLeft ] + 4;
if Shft then Delta := -1;
for Side := Low(Side) to High(Side) do
begin
if Delta < 0 then
_Self_.RE_BorderStyle[ Side ] := _Self_.RE_BorderStyle[ Side ] + 1
else
begin
_Self_.RE_BorderWidth[ Side ] := Delta;
_Self_.RE_BorderSpace[ Side ] := Delta;
end;
end;
Exit;
end;
(* TABLES STUFF -- to try, uncomment it and press CTRL+T in RichEdit.
(and uncomment declaration for Tmp above).
Not finished, and seems no way to figure it out - even RichEdit20.dll
(i.e. Rich Edit v3.0) can not display tables properly formatted. :(((
Integer('T'): begin
if _Self_.RE_Table then
begin
//MsgOK( 'table' );
end;
Tmp := _Self_.REReadText( reRTF, True );
if StrIsStartingFrom( 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( @_Self_.DF.fRECharFormatRec ) );
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 ASM_VERSION} //Pascal
function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var I: Integer;
Proc: TWindowFunc;
begin
Result := False;
if Self_.fRefCount < 0 then Exit;
if (Self_.fDynHandlers = nil) or (Self_.fDynHandlers.fCount = 0) then Exit;
Self_.RefInc; // Prevent destroying Self_
for I := Self_.fDynHandlers.fCount div 2 - 1 downto 0 do
begin
Proc := Self_.fDynHandlers.{$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 ASM_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 ASM_VERSION} //Pascal
procedure TControl.AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean );
begin
//if fDynHandlers = nil then
// fDynHandlers := NewList;
if not IsProcAttached( Proc ) then
begin
fDynHandlers.Add( @Proc );
fDynHandlers.Add( Pointer( Integer( ExecuteAfterAppletTerminated ) ) );
end;
{$IFNDEF SMALLEST_CODE}
Global_AttachProcExtension(fDynHandlers);
{$ENDIF}
PP.fOnDynHandlers := EnumDynHandlers;
end;
{$ENDIF ASM_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 ASM_VERSION} //Pascal
function TControl.IsProcAttached(Proc: TWindowFunc): Boolean;
var I: Integer;
begin
I := fDynHandlers.IndexOf( @Proc );
Result := I >=0;
end;
{$ENDIF ASM_VERSION}
{$IFDEF nASM_VERSION}
function WndProcAutoPopupMenu( Control: PControl; var Msg: TMsg; var MsgRslt: Integer ): Boolean;
asm
CMP WORD PTR[EDX].TMsg.message, WM_CONTEXTMENU
JNZ @@ret_0
CMP DWORD PTR[EAX].TControl.fAutoPopupMenu, 0
JZ @@ret_0
PUSH ESI
PUSH EDI
PUSH EBX
XCHG ESI, EAX // ESI = Control
MOV EDI, EDX
MOVSX EAX, WORD PTR[EDX].TMsg.lParam+2
PUSH EAX // P.Y
MOVSX EAX, WORD PTR[EDX].TMsg.lParam
PUSH EAX // P.X
CMP DWORD PTR[EDX].TMsg.lParam, -1
JNZ @@auto_popup
MOV EAX, ESI
CALL TControl.GetCurIndex
CMP EAX, 0
JL @@coords_2screen
// EAX = I
MOVZX EBX, WORD PTR[ESI].TControl.fCommandActions.aItem2XY
CMP EBX, 0
JZ @@coords_2screen
CMP BX, EM_POSFROMCHAR
JNZ @@chk_LB_LV_TC
PUSH 1
MOV EAX, ESI
CALL TControl.GetSelStart
PUSH EAX
MOV EAX, ESI
CALL TControl.GetSelLength
ADD DWORD PTR[ESP], EAX
PUSH EBX
PUSH ESI
CALL TControl.Perform
MOVSX EBX, AX
SHR EAX, 16
MOVSX EAX, AX
POP ECX
POP ECX
PUSH EAX
PUSH EBX
JMP @@check_bounds
@@chk_LB_LV_TC:
CMP BX, LB_GETITEMRECT
JZ @@LB_LV_TC
CMP BX, LVM_GETITEMRECT
JZ @@LB_LV_TC
CMP BX, TCM_GETITEMRECT
JNZ @@chk_TVM
@@LB_LV_TC: // EAX = I
PUSH ECX
PUSH LVIR_BOUNDS
PUSH ESP // @R
PUSH EAX // I
JMP @@get_2
@@chk_TVM:
CMP BX, TVM_GETITEMRECT
JNZ @@check_bounds
MOV EDX, TVGN_CARET
MOV EAX, ESI
CALL TControl.TVGetItemIdx
PUSH ECX
PUSH EAX
PUSH ESP // @R
PUSH 1 // 1
@@get_2:
PUSH EBX // M
PUSH ESI // Control
CALL TControl.Perform
POP EAX
POP ECX
POP ECX
PUSH EAX
@@check_bounds:
POP EBX // P.X
POP EDI // P.Y
SUB ESP, 16
MOV EDX, ESP
MOV EAX, ESI
CALL TControl.ClientRect
POP EAX // R.Left == 0
POP EAX // R.Top == 0
POP EAX // R.Right
CMP EBX, EAX
JLE @@1
XCHG EBX, EAX
@@1:POP EAX // R.Bottom
CMP EDI, EAX
JLE @@2
XCHG EDI, EAX
@@2:PUSH EDI // P.Y
PUSH EBX // P.X
@@coords_2screen:
MOV EDX, ESP
MOV EAX, ESI
MOV ECX, EDX
CALL TControl.Client2Screen
@@auto_popup:
POP EDX // P.X
POP ECX // P.Y
MOV EAX, [ESI].TControl.fAutoPopupMenu
CALL TMenu.Popup
POP EBX
POP EDI
POP ESI
OR EAX, -1
RET
@@ret_0:
XOR EAX, EAX
end;
{$ELSE ASM_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 ASM_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
begin
// if Form.DF.fPressedMnemonic <> 0 then
// Form.DF.fPressedMnemonic := Form.DF.fPressedMnemonic or $80000000;
end
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
if Assigned( EV.fOnSelChange ) then
EV.fOnSelChange( @Self )
else
{$IFDEF NIL_EVENTS}
if Assigned( EV.fOnChange ) then
{$ENDIF}
EV.fOnChange( @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;
//if Idx >= $4000 then Idx := $4000;
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; // calling REGetOverwite 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; // check is necessary for Win95 !
Result := FunTrack( lpEventTrack );
end;
{$IFDEF ASM_VERSION}
function WndProcMouseEnterLeave( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
asm
PUSH ESI
XCHG ESI, EAX
MOV AX, word ptr [EDX].TMsg.message
CMP AX, WM_MOUSELEAVE
JE @@MOUSELEAVE
SUB AX, WM_MOUSEFIRST
CMP AX, WM_MOUSELEAVE-WM_MOUSEFIRST
JA @@retFalse
{$IFDEF USE_FLAGS}
TEST [ESI].TControl.fFlagsG3, 1 shl G3_MouseInCtl
SETNZ AL
{$ELSE}
MOV AL, [ESI].TControl.fMouseInControl
{$ENDIF}
PUSH EAX
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [ESI].TControl.EV
MOV ECX, [EAX].TEvents.fOnTestMouseOver.TMethod.Code
{$ELSE}
MOV ECX, [ESI].TControl.EV.fOnTestMouseOver.TMethod.Code
{$ENDIF}
JECXZ @@1
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [EAX].TEvents.fOnTestMouseOver.TMethod.Data
{$ELSE}
MOV EAX, [ESI].TControl.EV.fOnTestMouseOver.TMethod.Data
{$ENDIF}
MOV EDX, ESI
CALL ECX
JMP @@2
@@1:
PUSH ECX
PUSH ECX
PUSH ESP
CALL GetCursorPos
MOV EAX, ESI
MOV EDX, ESP
MOV ECX, EDX
CALL TControl.Screen2Client
MOV ECX, ESP // @P
SUB ESP, 16
MOV EDX, ESP // @ClientRect
MOV EAX, ESI
PUSH EDX
PUSH ECX
CALL TControl.ClientRect
POP EAX
POP EDX
CALL PointInRect
ADD ESP, 16+8
@@2:
POP EDX
CMP AL, DL
JE @@retFalse
//MouseWasInControl <> Yes
PUSH EAX
MOV EAX, ESI
CALL TControl.Invalidate
POP EAX
TEST AL, AL
JZ @@3
{$IFDEF USE_FLAGS}
OR [ESI].TControl.fFlagsG3, 1 shl G3_MouseInCtl
{$ELSE}
MOV [ESI].TControl.fMouseInControl, 1
{$ENDIF}
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [ESI].TControl.EV
MOV ECX, [EAX].TEvents.fOnMouseEnter.TMethod.Code
{$ELSE}
MOV ECX, [ESI].TControl.EV.fOnMouseEnter.TMethod.Code
{$ENDIF}
JECXZ @@2_1
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [EAX].TEvents.fOnMouseEnter.TMethod.Data
{$ELSE}
MOV EAX, [ESI].TControl.EV.fOnMouseEnter.TMethod.Data
{$ENDIF}
MOV EDX, ESI
CALL ECX
@@2_1:
PUSH ECX
PUSH [ESI].TControl.fHandle
PUSH TME_LEAVE
PUSH 16
MOV EAX, ESP
CALL DoTrackMouseEvent
JMP @@4
@@3:
{$IFDEF USE_FLAGS}
AND byte ptr [ESI].TControl.fFlagsG3, $7F // not(1 shl G3_MouseInCtl)
{$ELSE}
MOV [ESI].TControl.fMouseInControl, 0
{$ENDIF}
PUSH ECX
PUSH [ESI].TControl.fHandle
PUSH TME_LEAVE or TME_CANCEL
PUSH 16
MOV EAX, ESP
CALL DoTrackMouseEvent
@@3_X:
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [ESI].TControl.EV
MOV ECX, [EAX].TEvents.fOnMouseLeave.TMethod.Code
{$ELSE}
MOV ECX, [ESI].TControl.EV.fOnMouseLeave.TMethod.Code
{$ENDIF}
JECXZ @@3_1
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [EAX].TEvents.fOnMouseLeave.TMethod.Data
{$ELSE}
MOV EAX, [ESI].TControl.EV.fOnMouseLeave.TMethod.Data
{$ENDIF}
MOV EDX, ESI
CALL ECX
@@3_1:
@@4:
ADD ESP, 16
MOV EAX, ESI
CALL TControl.Invalidate
JMP @@retFalse
@@MOUSELEAVE:
{$IFDEF USE_FLAGS}
BTR dword ptr [ESI].TControl.fFlagsG3, G3_MouseInCtl
JNC @@retFalse
{$ELSE}
BTR DWORD PTR [ESI].TControl.fMouseInControl, 1
JNC @@retFalse
{$ENDIF}
{$IFDEF GRAPHCTL_HOTTRACK}
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [ESI].TControl.EV
MOV ECX, [EAX].TEvents.fMouseLeaveProc.TMethod.Code
{$ELSE}
MOV ECX, [ESI].TControl.EV.fMouseLeaveProc.TMethod.Code
{$ENDIF}
{$IFDEF NIL_EVENTS}
JECXZ @@4_1
{$ENDIF}
{$IFDEF EVENTS_DYNAMIC}
MOV EAX, [EAX].TEvents.fMouseLeaveProc.TMethod.Data
{$ELSE}
MOV EAX, [ESI].TControl.EV.fMouseLeaveProc.TMethod.Data
{$ENDIF}
CALL ECX
{$ENDIF}
SUB ESP, 16
JMP @@3_X
@@retFalse:
XOR EAX, EAX
POP ESI
end;
{$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; //Erase( FALSE );
end;
end;
end;
Result := False;
end;
{$ENDIF ASM_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 := 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
begin
N := TVRoot;
end;
while N <> 0 do
begin
a := TVItemChild[N];
if a > 0 then
TVSort(a);
Perform(TVM_SORTCHILDREN, 0, N);
N := TVItemNext[N];
end;
if b then //moved by Tr"]f
Perform(TVM_SORTCHILDREN, 0, 0); //+ by YS
end;
procedure TControl.TVDelete(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: WideString;
var gbl: THandle;
str: PWideChar;
begin
Result := '';
if OpenClipboard( 0 ) then
begin
if IsClipboardFormatAvailable( CF_UNICODETEXT ) then
begin
gbl := GetClipboardData( CF_UNICODETEXT );
if gbl <> 0 then
begin
str := GlobalLock( gbl );
if str <> nil then
begin
Result := str;
GlobalUnlock( gbl );
end;
end;
end;
CloseClipboard;
end;
end;
{$ENDIF}
function Text2Clipboard( 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: WideString ): 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 ASM_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 := GetTopWindow( Wnd );
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 in [ 'a'..'z' ] then
C1 := AnsiChar( Ord( C1 ) - $20 );
if C2 in [ 'a'..'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 EnumWorkerW( W: HWnd; PW: PHWnd ): Bool; stdcall;
//var ClassBuf: array[ 0..31 ] of Char;
begin
//GetClassName( W, ClassBuf, 31 );
//if ClassBuf = 'WorkerW' then
begin
PW^ := findwindowex( W, 0, SHELLDLL_DefView_str, nil );
if PW^ <> 0 then
begin
Result := FALSE;
Exit;
end;
end;
Result := TRUE;
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
EnumWindows( @EnumWorkerW, Integer(@W1) );}
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;
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 );
if CreateProcess( nil, PKOLChar( '"' + AppPath + '" ' + CmdLine ),
nil, nil, TRUE, Flags, nil, DfltDir, Startup,
ProcInf ) then
begin
if ProcID <> nil then
ProcID^ := ProcInf.hProcess
else
CloseHandle( ProcInf.hProcess );
CloseHandle( ProcInf.hThread );
Restore_Saved_StdInOut;
Result := TRUE;
end
else
begin
Restore_Saved_StdInOut;
Close_Handles;
Exit;
end;
end;
function ExecuteConsoleAppIORedirect( 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} // asm version by MTsv DN (v 2.90)
{$ELSE ASM_VERSION}
function WinVer : TWindowsVersion;
var MajorVersion, MinorVersion: Byte;
dwVersion: Integer;
begin
if SaveWinVer <> $FF then Result := TWindowsVersion( SaveWinVer )
else
begin
dwVersion := GetVersion;
MajorVersion := LoByte( dwVersion );
MinorVersion := HiByte( LoWord( dwVersion ) );
if dwVersion >= 0 then
begin
Result := wvNT;
if (MajorVersion >= 6) then 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 ASM_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;
function TControl.DefaultBtnProc(var Msg: TMsg;
var Rslt: Integer): Boolean;
var Btn: PControl;
F, dfltBtn, cnclBtn: PControl;
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)) and
((Msg.wParam = VK_RETURN) or (Msg.wParam = VK_ESCAPE)) then
begin
dfltBtn := Pointer( F.PropInt[ @DFLT_BTN ] ); // .DF.fDefaultBtnCtl;
cnclBtn := Pointer( F.PropInt[ @CNCL_BTN ] ); //.DF.fCancelBtnCtl;
if (Msg.wParam = VK_RETURN) and
(dfltBtn <> nil) and
dfltBtn.ToBeVisible and
dfltBtn.Enabled 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 = dfltBtn)
) then
Btn := dfltBtn
else
if (Msg.wParam = VK_ESCAPE) and
(cnclBtn <> nil) and
cnclBtn.ToBeVisible and
cnclBtn.Enabled then
Btn := cnclBtn
else
if (Msg.wParam = VK_RETURN) and
{$IFDEF USE_FLAGS} ( (G6_AllBtnReturnClick in F.fFlagsG6)
or(G6_AllBtnReturnClick in fFlagsG6))
{$ELSE} (F.fAllBtnReturnClick or fAllBtnReturnClick) {$ENDIF}
and (F.ActiveControl <> nil) and
(F.ActiveControl.ToBeVisible) and
{$IFDEF USE_FLAGS} (G5_IsButton in F.ActiveControl.fFlagsG5)
{$ELSE} (F.ActiveControl.IsButton) {$ENDIF}
and (F.ActiveControl.Count = 0) then
Btn := F.ActiveControl;
if Btn <> nil then
begin
if Msg.message = WM_KEYDOWN then
begin
{$IFDEF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY}
{$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;
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 bath !
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
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 := nil;
end;
C := nil;
if Value then C := @ Self;
if Index = 13 then
begin
F.PropInt[ @DFLT_BTN ] := Integer( C ); // .DF.fDefaultBtnCtl := C;
{$IFDEF NO_DEFAULT_BUTTON_BOLD}
{$ELSE}
if Value then
Style := Style or BS_DEFPUSHBUTTON
else
Style := Style and not BS_DEFPUSHBUTTON;
{$ENDIF}
end
else if Index = 27 then
F.PropInt[ @CNCL_BTN ] := Integer( C ); // .DF.fCancelBtnCtl := C;
end;
end;
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
SetDefaultBtn( 0, TRUE );
F := ParentForm;
if F <> nil then
{$IFDEF USE_FLAGS} include( F.fFlagsG6, G6_AllBtnReturnClick );
{$ELSE} F.fAllBtnReturnClick := TRUE; {$ENDIF}
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 Assigned( Sender.EV.FOnDropFiles ) 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 + 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;
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;
{fMouseStartPos.x := MSP.X;
fMouseStartPos.y := MSP.Y;
fDragStartPos.x := StartBounds.Left;
fDragStartPos.y := StartBounds.Top;}
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
begin
Result := FALSE;
Exit;
end;
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.fOnChange := FontChanged; //
FontChanged( fFont ); //
end; //
fColor := AParent.fColor; //
fBrush := fBrush.Assign( AParent.fBrush ); //
if fBrush <> nil then //
begin //
fBrush.fOnChange := BrushChanged; //
BrushChanged( fBrush ); //
end; //
end; //
end; //
//
constructor TControl.CreateApplet(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} //
constructor TControl.CreateGradientPanel(AParent: PControl; AColor1, //
AColor2: TColor); //
asm //cmd //opd //
XOR EDX, EDX //
PUSH EDX //
CALL CreateLabel //
MOV ECX, AColor1 //
MOV [EAX].fColor1, ECX //
MOV ECX, AColor2 //
MOV [EAX].fColor2, ECX //
MOV EDX, [EAX].fBoundsRect.Left //
ADD EDX, 40 //
MOV [EAX].fBoundsRect.Right, EDX //
MOV EDX, [EAX].fBoundsRect.Top //
ADD EDX, 40 //
MOV [EAX].fBoundsRect.Bottom, EDX //
PUSH EAX //
MOV EDX, offset[ WndProcGradient ] //
CALL AttachProc //
POP EAX //
end; //
{$ELSE ASM_VERSION} //Pascal //
constructor TControl.CreateGradientPanel(AParent: PControl; AColor1, //
AColor2: TColor); //
begin //
CreateLabel( AParent, '' ); //
AttachProc( WndProcGradient ); //
fColor2 := AColor2; //
fColor1 := AColor1; //
with fBoundsRect do //
begin //
Right := Left + 40; //
Bottom := Top + 40; //
end; //
end; //
{$ENDIF ASM_VERSION} //
//
constructor TControl.CreateGradientPanelEx(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 );
//ImageList_SetBkColor( FHandle, CLR_NONE );
//
AOwner := POwner; //
FControl := AOwner; //
fNext := PImageList( AOwner.fImageList ); //
if AOwner.fImageList <> nil then //
PImageList( AOwner.fImageList ).fPrev := @Self; //
AOwner.fImageList := @Self; //
end; //
//
constructor TThread.ThreadCreate; //
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, @ WideString( 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 );
if Assigned( C.EV.fOnPaint ) then
C.EV.fOnPaint( C, DC )
else
C.EV.fPaintProc( 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
//if not Result then
begin
WasOnPaint := Self_.EV.fOnPaint;
Self_.EV.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;
//Self_.fOnPaint2 := save_Paint2;
if not Result then
{Result :=} WndProcPaint( Self_, Msg, Rslt );
Self_.EV.fOnPaint := WasOnPaint;
end;
Result := TRUE;
end
else
if (Msg.message >= WM_MOUSEFIRST) and (Msg.message <= WM_MOUSELAST) then
begin
Pt.X := SmallInt( LoWord( Msg.lParam ) );
Pt.Y := SmallInt( HiWord( Msg.lParam ) );
for i := 0 to Self_.ChildCount-1 do
begin
if (i = 0) and (Self_.fPushedBtn <> nil) then
C := Self_.fPushedBtn
else
C := Self_.Children[ i ];
if (C = Self_.fPushedBtn) OR
{$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.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.fFlagsG2, G2_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.fFlagsG2, G2_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_.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.fOnChange := Result.FontChanged;
Result.FontChanged( Result.fFont );
end;
end;
Result.fBoundsRect.Right := Result.fBoundsRect.Left + 64;
Result.fBoundsRect.Bottom := Result.fBoundsRect.Top + 22;
{$IFDEF GRAPHCTL_XPSTYLES}
if WinVer < wvXP then
DoNotDrawGraphCtlsUsingXPStyles := TRUE;
{$ENDIF}
end;
function NewGraphLabel( AParent: PControl; const ACaption: 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;
if AParent <> nil then
begin
//AParent.fRadioLast := Result.fMenu;
AParent.PropInt[ RADIO_LAST ] := Result.fMenu;
//if AParent.fRadio1st = 0 then
if AParent.PropInt[ RADIO_1ST ] = 0 then
begin
//AParent.fRadio1st := Result.fMenu;
AParent.PropInt[ RADIO_1ST ] := Result.fMenu;
Result.SetRadioChecked;
end;
end;
{$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.fFlagsG2, G2_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( EV.fOnPrepaint ) 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 );
//SaveImg( Canvas, R, 'bm09.bmp' );
//sv1 := FALSE;
end;
procedure TControl.GraphicCheckBoxPaint(DC: HDC);
var R, R1: TRect;
Flag: DWORD;
W, H: Integer;
{$IFDEF GRAPHCTL_XPSTYLES}
Theme: THandle;
{$ENDIF}
begin
R := DoGraphCtlPrepaint;
{$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 );
//{$IFNDEF GRAPHCTL_XPSTYLES}
R1 := R;
//{$ENDIF}
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( fFlagsG2, G2_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} G2_Focused in fFlagsG2
{$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;
//else Flag1 := Flag1 or DT_LEFT;
END;
CASE fVerticalAlign OF
vaCenter: Flag1 := Flag1 or DT_VCENTER;
vaBottom: Flag1 := Flag1 or DT_BOTTOM;
//else Flag1 := Flag1 or DT_TOP;
END;
DrawFormattedTextXP( Theme, @ Self, DC, R1, 1 {EP_EDITTEXT}, Flag,
Flag1, 0 );
end;
fCloseThemeData( Theme );
end
else
{$ENDIF}
begin
if not Assigned( 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
begin
DF.fEditCtl.EV.fLeave( DF.fEditCtl );
end;
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} (G2_Focused in fFlagsG2)
{$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
begin
rgn := 0;
end;
if rgn <> 0 then
begin
rgnsav := CreateRectRgn( 0, 0, 0, 0 );
GetClipRgn( DC, rgnsav );
ExtSelectClipRgn( DC, rgn, RGN_DIFF );
DeleteObject( rgn );
end;
fDrawThemeBackground( Theme, DC, 4 {BP_GROUPBOX}, Flag, @R, @R );
if rgnsav <> 0 then
begin
SelectClipRgn( DC, rgnsav );
DeleteObject( rgnsav );
end;
fCloseThemeData( Theme );
end
else
{$ENDIF}
begin
bk_erased := FALSE;
R1 := R;
R1.Top := 0;
R1.Bottom := ClientRect.Top;
Inc( R1.Left, 16 );
Dec( R1.Right, 16 );
fVerticalAlign := vaCenter;
BeginPath( DC );
Canvas.TextOut( R1.Left, R1.Top, fCaption );
EndPath( DC );
Canvas.TextOut( R1.Left, R1.Top, fCaption );
rgntxt := PathToRegion( DC );
if rgntxt = 0 then // - !
begin
R1.Right := R1.Left + Canvas.TextWidth( fCaption );
R1.Bottom := R1.Top + Canvas.TextHeight( fCaption );
rgntxt := CreateRectRgnIndirect( R1 );
end;
GetRgnBox( rgntxt, R0 );
rgn2 := CreateRectRgnIndirect( R0 );
rgnsav := CreateRectRgn( 0, 0, 0, 0 );
GetClipRgn( DC, rgnsav );
ExtSelectClipRgn( DC, rgn2, RGN_DIFF );
DeleteObject( rgn2 );
BeginPath( DC );
DrawEdge( DC, R, BDR_RAISEDINNER or BDR_SUNKENOUTER, BF_RECT );
EndPath( DC );
rgn := PathToRegion( DC );
if rgn = 0 then DoEraseBkgnd;
DrawEdge( DC, R, BDR_RAISEDINNER or BDR_SUNKENOUTER, BF_RECT );
SelectClipRgn( DC, rgnsav );
DeleteObject( rgnsav );
if rgn <> 0 then
begin
ExtSelectClipRgn( DC, rgn, RGN_DIFF );
DeleteObject( rgn );
end;
ExtSelectClipRgn( DC, rgntxt, RGN_DIFF );
DeleteObject( rgntxt );
if not bk_erased then DoEraseBkgnd;
end;
FINALLY
SelectClipRgn( DC, rgnsavall );
DeleteObject( rgnsavall );
END;
end;
{$ENDIF USE_GRAPHCTLS}
{$IFDEF ASM_VERSION}
{$ELSE PASCAL}
function TControl.MakeWordWrap: PControl;
begin
{$IFDEF USE_FLAGS} include( fFlagsG1, G1_WordWrap );
{$ELSE} fWordWrap := TRUE; {$ENDIF}
Style := fStyle.Value and not SS_LEFTNOWORDWRAP;
Result := @ Self;
end;
{$ENDIF ASM_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 //Shft: Integer;
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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE}
function TControl.FormGetColorParam: Integer;
begin
Result := FormGetIntParam;
Result := (Result shr 1) or (Result shl 31);
end;
{$ENDIF ASM_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 ASM_VERSION}
procedure TControl.FormCreateParameters(
alphabet: PFormInitFuncArray;
params: PAnsiChar );
//var i: Integer;
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 //c: Char;
//i,
N: Integer;
Ctrl: PPcontrol;
begin
//i := 0;
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 );
//inc( i );
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 ASM_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 ASM_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 ASM_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 ASM_VERSION}
function FormNewPaintbox( Form: PControl ): PControl;
begin
Result := NewPaintbox( Form.DF.FormCurrentParent );
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 ASM_VERSION}
{$IFDEF USE_RICHEDIT}
{$IFDEF ASM_VERSION}
function FormNewRichEdit( Form: PControl ): PControl;
asm
CALL FormPrepareIntParamCreateCtrl
CALL NewRichEdit
end;
{$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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE}
function FormNewCheckbox( Form: PControl ): PControl;
begin
Form.FormGetStrParam;
Result := NewCheckbox( Form.DF.FormCurrentParent, Form.FormString );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE}
function FormNewRadiobox( Form: PControl ): PControl;
begin
Form.FormGetStrParam;
Result := NewRadiobox( Form.DF.FormCurrentParent, Form.FormString );
end;
{$ENDIF ASM_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 ASM_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 FormNewToolbar( Form: PControl ): PControl;
type PToolbarOptions = ^TToolbarOptions;
type TAnsiStringArray = array[0..65535] of String;
PAnsiStringArray = ^TAnsiStringArray;
var a, o, m, b, N, N2, i: Integer;
map: array[0..1] of Integer;
butt1: PKOLStrList;
butt2: array[0..255] of PKOLChar;
imgs: array of Integer;
begin
a := Form.FormGetIntParam;
o := Form.FormGetIntParam;
m := Form.FormGetIntParam;
CASE m OF
1: begin
Form.FormGetStrParam;
map[0] := Form.FormGetIntParam;
map[0] := Color2RGB( clBtnFace );
b := LoadMappedBitmapEx( Form, hInstance, PKOLChar( Form.FormString ), map );
end;
2: begin
Form.FormGetStrParam;
b := LoadBmp( hInstance, PKOLChar( Form.FormString ), Form );
end;
else
b := m;
END;
N := Form.FormGetIntParam; // N must be < 256
butt1 := NewKOLStrList;
for i := 0 to N-1 do
begin
Form.FormGetStrParam;
butt1.Add( Form.FormString );
butt2[i] := butt1.ItemPtrs[i];
end;
butt2[N] := nil;
N2 := Form.FormGetIntParam; // N2 must be < 256
SetLength( imgs, N2 );
for i := 0 to N2-1 do
imgs[i] := Form.FormGetIntParam;
Result := NewToolbar( Form.DF.FormCurrentParent,
TControlAlign( a ),
PToolbarOptions( @ o )^,
b,
butt2,
imgs );
Free_And_Nil(butt1);
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}
//!!! asm version returns in EAX Control,
// and integer parameter in EDX and ECX (EDX=ECX) !!!
//--- this is enough to call method of Control with a single int param ---
function ParentForm_IntParamAsm(Control: PControl): Integer;
asm
PUSH EAX
CALL TControl.ParentForm
CALL TControl.FormGetIntParam
XCHG EDX, EAX
MOV ECX, EDX
POP EAX
end;
function ParentForm_ColorParamAsm(Control: PControl): Integer;
asm
CALL ParentForm_IntParamAsm
ROR EDX, 1
end;
{$ENDIF ASM_VERSION}
function ParentForm_PCharParam(Control: PControl): PKOLChar;
var Form: PControl;
begin
Form := Control.ParentForm;
Form.FormGetStrParam;
Result := PKOLChar( KOLString( Form.FormString ) );
end;
function ParentForm_IntParamPas(Form: PControl): Integer;
begin
Result := Form.ParentForm.FormGetIntParam;
end;
function ParentForm_ColorParamPas(Form: PControl): Integer;
begin
Result := Form.ParentForm.FormGetColorParam;
end;
{$IFDEF ASM_VERSION}
// only to call from asm -- returns EAX=Parent Form, EDX=ECX=PChar param
function ParentForm_PCharParamAsm(Control: PControl): PChar;
asm
PUSH EAX
CALL ParentForm_PCharParam
XCHG EDX, EAX
MOV ECX, EDX
POP EAX
end;
{$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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetAlign( Form: PControl );
begin
Form.SetAlign( TControlAlign( ParentForm_IntParamPas(Form) ) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF USE_NAMES}
procedure FormSetName( Form: PControl );
var C: PControl;
begin
C := Form;
Form := Form.ParentForm;
Form.FormGetStrParam;
C.SetName( Form, Form.FormString );
end;
{$ENDIF USE_NAMES}
{$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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormInitMenu( Form: PControl );
begin
Form.Perform( WM_INITMENU, 0, 0 );
end;
{$ENDIF ASM_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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetStyle( Form: PControl );
begin
Form.Style := Form.Style or DWORD( ParentForm_IntParamPas(Form));
end;
{$ENDIF ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetHasCaptionFalse( Form: PControl );
begin
Form.HasCaption := FALSE;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormResetCtl3D( Form: PControl );
begin
Form.Ctl3D := FALSE;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormIconLoad_hInstance( Form: PControl );
begin
Form.IconLoad( hInstance,
MAKEINTRESOURCE( ParentForm_IntParamPas(Form) ) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormIconLoadCursor_0( Form: PControl );
begin
Form.IconLoadCursor( 0, MakeIntResource( ParentForm_IntParamPas(Form) ) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetIconNeg1( Form: PControl );
begin
Form.Icon := THandle( -1 );
end;
{$ENDIF ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormCursorLoad_0( Form: PControl );
begin
Form.CursorLoad( 0, MAKEINTRESOURCE( ParentForm_IntParamPas(Form) ) );
end;
{$ENDIF ASM_VERSION}
procedure FormCursorLoad_hInstance( Form: PControl );
var C: PControl;
begin
C := Form;
Form := Form.ParentForm;
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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetBrushStyle( Form: PControl );
begin
Form.Brush.BrushStyle := TBrushStyle( ParentForm_IntParamPas(Form) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetBrushBitmap( Form: PControl );
var C: PControl;
begin
C := Form;
Form := Form.ParentForm;
{$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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetFontColor( Form: PControl );
begin
Form.Font.Color := ParentForm_ColorParamPas(Form);
end;
{$ENDIF ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetFontHeight( Form: PControl );
begin
Form.Font.FontHeight := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetFontWidth( Form: PControl );
begin
Form.Font.FontWidth := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
procedure ParentForm_StrParam( Form: PControl );
begin
Form := Form.ParentForm;
Form.FormGetStrParam;
end;
procedure FormSetFontName( Form: PControl );
begin
ParentForm_StrParam(Form);
Form.Font.FontName := Form.ParentForm.FormString;
end;
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetFontOrientation( Form: PControl );
begin
Form.Font.FontOrientation := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetFontCharset( Form: PControl );
begin
Form.Font.FontCharset := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetFontPitch( Form: PControl );
begin
Form.Font.FontPitch := TFontPitch( ParentForm_IntParamPas(Form) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetBorder( Form: PControl );
begin
Form.Border := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetMarginTop( Form: PControl );
begin
Form.MarginTop := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetMarginBottom( Form: PControl );
begin
Form.MarginBottom := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetMarginLeft( Form: PControl );
begin
Form.MarginLeft := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetMarginRight( Form: PControl );
begin
Form.MarginRight := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetSimpleStatusText( Form: PControl );
begin
Form.SimpleStatusText := ParentForm_PCharParam(Form);
end;
{$ENDIF ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormRemoveCloseIcon( Form: PControl );
begin
DeleteMenu( GetSystemMenu( Form.GetWindowHandle, False ),
SC_CLOSE, MF_BYCOMMAND );
end;
{$ENDIF ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetMaxWidth( Form: PControl );
begin
Form.MaxWidth := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetMinHeight( Form: PControl );
begin
Form.MinHeight := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetMaxHeight( Form: PControl );
begin
Form.MaxHeight := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetTextShiftY( Form: PControl );
begin
Form.TextShiftY := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetColor2( Form: PControl );
begin
Form.Color2 := ParentForm_ColorParamPas( Form );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetTextAlign( Form: PControl );
begin
Form.TextAlign := TTextAlign( ParentForm_IntParamPas(Form) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetTextVAlign( Form: PControl );
begin
Form.VerticalAlign := TVerticalAlign( ParentForm_IntParamPas(Form) );
end;
{$ENDIF ASM_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 ASM_VERSION}
procedure FormSetHintText( Form: PControl );
begin
{$IFDEF USE_MHTOOLTIP}
ParentForm_StrParam(Form);
Form.Hint.Text := Form.ParentForm.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.ParentForm;
Form.FormGetStrParam;
Ctl.Caption := Form.FormString;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetGradienStyle( Form: PControl );
begin
Form.GradientStyle := TGradientStyle( ParentForm_IntParamPas(Form) );
end;
{$ENDIF ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetRE_AutoFontSizeAdjustFalse( Form: PControl );
begin
Form.RE_AutoFontSizeAdjust := FALSE;
end;
{$ENDIF PASCAL}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetRE_DualFontTrue( Form: PControl );
begin
Form.RE_DualFont := TRUE;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetRE_UIFontsTrue( Form: PControl );
begin
Form.RE_UIFonts := TRUE;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetRE_IMECancelCompleteTrue( Form: PControl );
begin
Form.RE_IMECancelComplete := TRUE;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetRE_IMEAlwaysSendNotifyTrue( Form: PControl );
begin
Form.RE_IMEAlwaysSendNotify := TRUE;
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetMaxTextSize( Form: PControl );
begin
Form.MaxTextSize := DWORD( ParentForm_IntParamPas(Form) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetRE_AutoKeyboardTrue( Form: PControl );
begin
Form.RE_AutoKeyboard := TRUE;
end;
{$ENDIF ASM_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 ASM_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.ParentForm.FormString;
end;
end;
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetCount( Form: PControl );
begin
Form.Count := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetDroppedWidth( Form: PControl );
begin
Form.DroppedWidth := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetButtonBitmap( Form: PControl );
begin
Form.SetButtonBitmap( LoadBitmap( hInstance,
ParentForm_PCharParam(Form) ) );
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetMaxProgress( Form: PControl );
begin
Form.MaxProgress := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetProgress( Form: PControl );
begin
Form.Progress := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_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.ParentForm.FormString, taLeft, w );
end;
end;
{$ENDIF ASM_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 ASM_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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetTVIndent( Form: PControl );
begin
Form.TVIndent := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
procedure FormSetTBBtnImgWidth( Form: PControl );
begin
Form.TBBtnImgWidth := ParentForm_IntParamPas( Form );
end;
procedure FormTBAddBitmap( Form: PControl );
var m: Boolean;
map: array[ 0..1 ] of TColor;
b: Integer;
C: PControl;
begin
C := Form;
Form := Form.ParentForm;
Form.FormGetStrParam;
m := Form.FormGetIntParam <> 0;
if m then
begin
map[0] := Form.FormGetColorParam;
map[1] := Color2RGB( clBtnFace );
b := LoadMappedBitmapEx( Form, hInstance, PKOLChar( KOLString( Form.FormString )), map );
end
else
begin
b := LoadBmp( hInstance, PKOLChar(KOLString(Form.FormString)), Form );
end;
C.TBAddBitmap( b );
end;
procedure FormSetTBButtonSize( Form: PControl );
//var HW: Integer;
begin
//HW := Form.Perform( TB_GETBUTTONSIZE, 0, 0 );
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.ParentForm;
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}
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.ParentForm.FormString;
end;
{$ENDIF ASM_VERSION}
{$IFDEF noASM_VERSION}
procedure FormSetDateTimeColor( Form: PControl );
asm
CALL ParentForm_ColorParamAsm
PUSH EDX
CALL ParentForm_IntParamAsm
POP ECX
CALL TControl.SetDateTimePickerColor
end;
{$ELSE PASCAL}
procedure FormSetDateTimeColor( Form: PControl );
var i: Integer;
C: TColor;
begin
C := ParentForm_ColorParamPas( Form );
i := ParentForm_IntParamPas( Form );
Form.DateTimePickerColors[TDateTimePickerColor(i)] := C;
end;
{$ENDIF ASM_VERSION}
{$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 ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetCurIdx( Form: PControl );
begin
Form.CurIndex := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetSBMin( Form: PControl );
begin
Form.SBMin := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetSBMax( Form: PControl );
begin
Form.SBMax := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetSBPosition( Form: PControl );
begin
Form.SBPosition := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetSBPageSize( Form: PControl );
begin
Form.SBPageSize := ParentForm_IntParamPas(Form);
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormLastCreatedChildAsNewCurrentParent( Form: PControl );
var C: PControl;
begin
C := Form;
Form := Form.ParentForm;
Form.DF.FormCurrentParent := C;
end;
{$ENDIF ASM_VERSION}
procedure FormSetUpperParent( Form: PControl );
begin
Form := Form.ParentForm;
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.ParentForm;
i := Form.FormGetIntParam;
Form.DF.FormCurrentParent := C.Pages[i];
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PASCAL}
procedure FormSetCurCtl( Form: PControl );
var i: Integer;
C: PControl;
begin
Form := Form.ParentForm;
i := Form.FormGetIntParam;
C := PPControl(Integer( Form.DF.FormAddress ) + i * 4)^;
if C = nil then
C := Form;
Form.DF.FormLastCreatedChild := C;
end;
{$ENDIF ASM_VERSION}
procedure FormSetParent( Form: PControl );
var C: PControl;
begin
C := Form;
Form := Form.ParentForm;
Form.DF.FormCurrentParent := C;
end;
{$IFDEF ASM_VERSION}
procedure FormSetEvent( Form: PControl );
asm
PUSH EDI
MOV EDI, EAX
PUSH ESI
CALL TControl.ParentForm
MOV ESI, EAX
PUSH [ESI].TControl.DF.FormObj
CALL ParentForm_IntParamAsm
MOV ESI, [EAX].TControl.DF.FormAlphabet
PUSH dword ptr [ESI+EDX*4]
CALL ParentForm_IntParamAsm
XCHG EAX, EDI
CALL dword ptr [ESI+EDX*4]
POP ESI
POP EDI
end;
{$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.ParentForm;
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}
procedure FormSetIndexedEvent( Form: PControl );
asm
PUSH EDI
MOV EDI, EAX
PUSH ESI
CALL TControl.ParentForm
MOV ESI, EAX
PUSH [ESI].TControl.DF.FormObj
CALL ParentForm_IntParamAsm
MOV ESI, [EAX].TControl.DF.FormAlphabet
PUSH dword ptr [ESI+EDX*4]
CALL ParentForm_IntParamAsm // idx
PUSH EDX
CALL ParentForm_IntParamAsm
XCHG EAX, EDI
MOV ECX, dword ptr [ESI+EDX*4]
POP EDX
CALL ECX
POP ESI
POP EDI
end;
{$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.ParentForm;
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}
// {$DEFINE ASM_VERSION}
// {$DEFINE ASM_UNICODE}
{$I KOL_ASM.inc} {$ENDIF ASM_VERSION}
{$IFDEF LIN}
{$DEFINE implementation} {$I KOL_Linux.inc} {$UNDEF implementation}
{$ENDIF LIN}
{ -- }
{$IFDEF USE_CUSTOMEXTENSIONS}
{$I CUSTOM_CODE_EXTENSION.inc} // See comments in TControl
{$ENDIF USE_CUSTOMEXTENSIONS}
{$IFNDEF NOT_UNLOAD_RICHEDITLIB}
{$IFDEF UNLOAD_RICHEDITLIB}
{$DEFINE INIT_FINIT}
{$ENDIF}
{$ENDIF}
{$IFDEF USE_NAMES}
{$DEFINE INIT_FINIT}
{$ENDIF}
{$IFDEF GRAPHCTL_XPSTYLES}
{$DEFINE INIT_FINIT}
{$ENDIF}
{$IFDEF EVENTS_DYNAMIC}
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;
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
FreeMem( DF.fRECharFormatRec );
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_MDIClient: PControl;
var i: Integer;
begin
Result := nil;
for i := 0 to ChildCount-1 do
begin
Result := Children[i];
if Result.fControlClassName = 'MDICLIENT' then break;
Result := nil;
end;
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 ] ];
TMethod( EV.MethodEvents[idx] ).Data := nil;
end;
{ TCommandActionsObj }
{$IFDEF COMMANDACTIONS_OBJ}
{$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 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.
Reference in New Issue View Git Blame Copy Permalink