1
0
Files
applications
bindings
components
Comba_Animation
aboutcomponent
acs
beepfp
callite
chelper
chemtext
cmdline
cmdlinecfg
colorpalette
cryptini
csvdocument
epiktimer
everettrandom
examplecomponent
extrasyn
fpexif
fpsound
fpspreadsheet
fractions
freetypepascal
geckoport
gradcontrols
grid_semaphor
industrialstuff
iosdesigner
iphonelazext
jujiboutils
jvcllaz
kcontrols
lazautoupdate
lazbarcodes
lazmapviewer
lclextensions
longtimer
manualdock
mbColorLib
mplayer
multithreadprocs
nvidia-widgets
onguard
orpheus
tests
ORBLUEDOT.bmp
ORBTNCAL.bmp
ORBTNCLC.bmp
ORCOLUMNMOVECURSOR.cur
ORLEFTARROW.bmp
ORLEFTARROWS.bmp
ORREDDOT.bmp
ORREVERT.bmp
ORRIGHTARROW.bmp
ORRIGHTARROWS.bmp
ORROWMOVECURSOR.cur
ORTCCHECKGLYPHS.bmp
ORTCCOMBOARROW.bmp
ORTODAY.bmp
OrphStatus.html
README.txt
TO32FLEXEDIT.bmp
TO32TCFLEXEDIT.bmp
TOVCCALENDAR.bmp
TOVCCONTROLLER.bmp
TOVCDATEEDIT.bmp
TOVCLABEL.bmp
TOVCROTATEDLABEL.bmp
TOVCSIMPLEFIELD.bmp
TOVCSPINNER.bmp
TOVCTABLE.bmp
TOVCTCBITMAP.bmp
TOVCTCCHECKBOX.bmp
TOVCTCCOLHEAD.bmp
TOVCTCCOMBOBOX.bmp
TOVCTCGLYPH.bmp
TOVCTCICON.bmp
TOVCTCMEMO.bmp
TOVCTCROWHEAD.bmp
TOVCTCSIMPLEFIELD.bmp
TOVCTCSTRING.bmp
TOVCURL.bmp
TOVCVIRTUALLISTBOX.bmp
alltests-carbon.sh
alltests-gtk.sh
alltests-linux.sh
alltests-win.bat
makebaseres.bat
makeregres.bat
mymin.pas
mymisc.pas
myovcreg.pas
myovctbpe1.lfm
myovctbpe1.lrs
myovctbpe1.pas
myovctbpe2.lfm
myovctbpe2.lrs
myovctbpe2.pas
o32bordr.pas
o32editf.pas
o32flxed.pas
o32intdeq.pas
o32intlst.pas
o32ovldr.pas
o32pvldr.pas
o32rxngn.pas
o32rxvld.pas
o32sr.inc
o32sr.pas
o32tcflx.pas
o32vldtr.pas
o32vlop1.pas
o32vlreg.pas
o32vpool.pas
orpheus.lpk
orpheus.pas
ovc.inc
ovcabot0.lfm
ovcabot0.lrs
ovcabot0.pas
ovcbase.lrs
ovcbase.pas
ovcbase.res
ovcbcalc.pas
ovcbordr.pas
ovccal.pas
ovccalc.pas
ovccaret.pas
ovcclrcb.pas
ovccmbx.pas
ovccmd.pas
ovccolor.pas
ovcconst.pas
ovcdata.pas
ovcdate.pas
ovcdrag.pas
ovcedcal.pas
ovcedclc.pas
ovceditf.pas
ovcedpop.pas
ovcedtim.pas
ovcef.pas
ovcexcpt.pas
ovcintl.pas
ovclabel.pas
ovclbl0.lfm
ovclbl0.lrs
ovclbl0.pas
ovclbl1.lfm
ovclbl1.lrs
ovclbl1.pas
ovclbl2.pas
ovcmisc.pas
ovcnf.pas
ovcpb.pas
ovcreg.lrs
ovcrlbl.pas
ovcsc.pas
ovcsf.pas
ovcspary.pas
ovcstr.pas
ovctable.pas
ovctbclr.pas
ovctbcls.pas
ovctbpe1.pas
ovctbpe2.pas
ovctbrws.pas
ovctcary.pas
ovctcbef.pas
ovctcbmp.pas
ovctcbox.pas
ovctccbx.pas
ovctcedt.pas
ovctcell.pas
ovctcgly.pas
ovctchdr.pas
ovctcico.pas
ovctcmmn.pas
ovctcsim.pas
ovctcstr.pas
ovctgpns.pas
ovctgres.pas
ovctsell.pas
ovcurl.pas
ovcuser.pas
ovcver.pas
ovcvlb.pas
playsoundpackage
poweredby
powerpdf
rgbgraphics
richmemo
richview
rtfview
rx
scrolltext
smnetgradient
spktoolbar
splashabout
svn
systools
tdi
thtmlport
tparadoxdataset
tvplanit
xdev_toolkit
zlibar
zmsql
examples
image_sources
lclbindings
wst
lazarus-ccr/components/orpheus/ovcbase.pas

2759 lines
74 KiB
ObjectPascal
Raw Normal View History

{*********************************************************}
{* OVCBASE.PAS 4.06 *}
{*********************************************************}
{* ***** BEGIN LICENSE BLOCK ***** *}
{* Version: MPL 1.1 *}
{* *}
{* The contents of this file are subject to the Mozilla Public License *}
{* Version 1.1 (the "License"); you may not use this file except in *}
{* compliance with the License. You may obtain a copy of the License at *}
{* http://www.mozilla.org/MPL/ *}
{* *}
{* Software distributed under the License is distributed on an "AS IS" basis, *}
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *}
{* for the specific language governing rights and limitations under the *}
{* License. *}
{* *}
{* The Original Code is TurboPower Orpheus *}
{* *}
{* The Initial Developer of the Original Code is TurboPower Software *}
{* *}
{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *}
{* TurboPower Software Inc. All Rights Reserved. *}
{* *}
{* Contributor(s): *}
{* *}
{* ***** END LICENSE BLOCK ***** *}
{$I OVC.INC}
{$B-} {Complete Boolean Evaluation}
{$I+} {Input/Output-Checking}
{$P+} {Open Parameters}
{$T-} {Typed @ Operator}
{.$W-} {Windows Stack Frame}
{$X+} {Extended Syntax}
{$IFNDEF VERSION3}
!! Error - not for Delphi versions 1 and 2 or C++ Builder version 1
{$ENDIF}
{$IFNDEF LCL}
{$R OVCBASE.RES}
{$ENDIF}
unit ovcbase;
{-Base unit for Orpheus visual components}
interface
uses
{$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, MyMisc, {$ENDIF}
Classes, Controls, Dialogs, Forms, StdCtrls, SysUtils,
OvcCmd, OvcData, OvcMisc, OvcConst, OvcExcpt, {$IFNDEF LCL} OvcTimer, {$ENDIF} OvcDate;
type
TOvcLabelPosition = (lpTopLeft, lpBottomLeft); {attached label types}
TOvcAttachEvent = procedure(Sender : TObject; Value : Boolean)
of object;
TOvcAttachedLabel = class(TLabel)
protected {private}
FControl : TWinControl;
protected
procedure SavePosition;
procedure Loaded;
override;
public
constructor Create(AOwner : TComponent);
override;
constructor CreateEx(AOwner : TComponent; AControl : TWinControl);
virtual;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
override;
published
property Control : TWinControl
read FControl write FControl;
end;
TO32ContainerList = class(TList)
FOwner: TComponent;
public
constructor Create(AOwner: TComponent); virtual;
destructor Destroy; override;
end;
TOvcLabelInfo = class(TPersistent)
protected {private}
{property variables}
FOffsetX : Integer;
FOffsetY : Integer;
{event variables}
FOnChange : TNotifyEvent;
FOnAttach : TOvcAttachEvent;
{internal methods}
procedure DoOnAttach;
procedure DoOnChange;
function IsVisible : Boolean;
{property methods}
procedure SetOffsetX(Value : Integer);
procedure SetOffsetY(Value : Integer);
procedure SetVisible(Value : Boolean);
public
ALabel : TOvcAttachedLabel;
FVisible : Boolean;
property OnAttach : TOvcAttachEvent
read FOnAttach write FOnAttach;
property OnChange : TNotifyEvent
read FOnChange write FOnChange;
procedure SetOffsets(X, Y : Integer);
published
property OffsetX: Integer
read FOffsetX write SetOffsetX stored IsVisible;
property OffsetY: Integer
read FOffsetY write SetOffsetY stored IsVisible;
property Visible : Boolean
read FVisible write SetVisible
default False;
end;
{event method types}
TMouseWheelEvent = procedure(Sender : TObject; Shift : TShiftState;
Delta, XPos, YPos : Word) of object;
TDataErrorEvent =
procedure(Sender : TObject; ErrorCode : Word; const ErrorMsg : string)
of object;
TPostEditEvent =
procedure(Sender : TObject; GainingControl : TWinControl)
of object;
TPreEditEvent =
procedure(Sender : TObject; LosingControl : TWinControl)
of object;
TDelayNotifyEvent =
procedure(Sender : TObject; NotifyCode : Word)
of object;
TIsSpecialControlEvent =
procedure(Sender : TObject; Control : TWinControl;
var Special : Boolean)
of object;
TGetEpochEvent =
procedure (Sender : TObject; var Epoch : Integer)
of object;
{options which will be the same for all fields attached to the same controller}
TOvcBaseEFOption = (
efoAutoAdvanceChar,
efoAutoAdvanceLeftRight,
efoAutoAdvanceUpDown,
efoAutoSelect,
efoBeepOnError,
efoInsertPushes);
TOvcBaseEFOptions = set of TOvcBaseEFOption;
type
TOvcCollectionStreamer = class;
TOvcCollection = class;
TO32Collection = class;
{implements the About property and collection streaming}
TOvcComponent = class(TComponent)
protected {private}
FCollectionStreamer : TOvcCollectionStreamer;
FInternal : Boolean; {flag to suppress name generation
on collection items}
function GetAbout : string;
procedure SetAbout(const Value : string);
protected
{OrCollection streaming hooks:}
procedure GetChildren(Proc: TGetChildProc; Root : TComponent); override;
function GetChildOwner: TComponent; override;
procedure Loaded; override;
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
property CollectionStreamer : TOvcCollectionStreamer
read FCollectionStreamer
write FCollectionStreamer;
property Internal : Boolean read FInternal write FInternal;
published
{properties}
property About : string
read GetAbout
write SetAbout
stored False;
end;
{implements the About property}
TO32Component = class(TComponent)
protected {private}
FInternal : Boolean; {flag to suppress name generation
on collection items}
function GetAbout : string;
procedure SetAbout(const Value : string);
public
constructor Create(AOwner: TComponent); override;
property Internal : Boolean read FInternal write FInternal;
published
{properties}
property About : string read GetAbout write SetAbout stored False;
end;
TOvcController = class(TOvcComponent)
protected {private}
FBaseEFOptions : TOvcBaseEFOptions; {options common to all entry fields}
FEntryCommands : TOvcCommandProcessor; {command processor}
FEpoch : Integer; {combined epoch year and century}
FErrorPending : Boolean; {an error is pending for an ef}
FErrorText : string; {text of last error}
{ - HWnd changed to TOvcHWnd for BCB Compatibility }
FHandle : TOvcHWnd{hWnd}; {our window handle}
FInsertMode : Boolean; {global insert mode flag}
{$IFNDEF LCL} //Currently not implemented
FTimerPool : TOvcTimerPool; {general timer pool}
{$ENDIF}
{events}
FOnDelayNotify : TDelayNotifyEvent;
FOnError : TDataErrorEvent;
FOnGetEpoch : TGetEpochEvent;
FOnIsSpecialControl : TIsSpecialControlEvent;
FOnPostEdit : TPostEditEvent;
FOnPreEdit : TPreEditEvent;
{$IFNDEF LCL}
FOnTimerTrigger : TTriggerEvent;
{$ENDIF}
{property methods}
function GetEpoch : Integer;
{ - HWnd changed to TOvcHWnd for BCB Compatibility }
function GetHandle : TOvcHWnd{hWnd};
procedure SetEpoch(Value : Integer);
{internal methods}
procedure cWndProc(var Msg : TMessage);
{-window procedure}
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
procedure DestroyHandle;
{$IFDEF LCL}
function PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL;
{$ENDIF}
{wrappers for event handlers}
procedure DoOnPostEdit(Sender : TObject; GainingControl : TWinControl);
{-call the method assigned to the OnPostEdit event}
procedure DoOnPreEdit(Sender : TObject; LosingControl : TWinControl);
{-call the method assigned to the OnPreEdit event}
procedure DoOnTimerTrigger(Sender : TObject; Handle : Integer;
Interval : Cardinal; ElapsedTime : LongInt);
procedure DelayNotify(Sender : TObject; NotifyCode : Word);
{-start the chain of events that will fire the OnDelayNotify event}
procedure DoOnError(Sender : TObject; ErrorCode : Word; const ErrorMsg : string);
{-call the method assigned to the OnError event}
{ - HWnd changed to TOvcHWnd for BCB Compatibility }
function IsSpecialButton(H : TOvcHWnd{hWnd}) : Boolean;
dynamic;
{-return true if H is btnCancel, btnHelp, or btnRestore}
procedure MarkAsUninitialized(Uninitialized : Boolean);
{-mark all entry fields on form as uninitialized}
function ValidateEntryFields : TComponent;
{-ask each entry field to validate its contents. Return nil
if no error, else return pointer to field with error}
function ValidateEntryFieldsEx(ReportError, ChangeFocus : Boolean) : TComponent;
{-ask each entry field to validate its contents. Return nil
if no error, else return pointer to field with error.
Conditionally move focus and report error}
function ValidateTheseEntryFields(const Fields : array of TComponent) : TComponent;
{-ask the specified entry fields to validate their contents. Return nil
if no error, else return pointer to field with error}
property ErrorPending : Boolean
read FErrorPending write FErrorPending;
property ErrorText : string
read FErrorText write FErrorText;
{ - HWnd changed to TOvcHWnd for BCB Compatibility }
property Handle : TOvcHWnd{hWnd}
read GetHandle;
property InsertMode : Boolean
read FInsertMode write FInsertMode;
{$IFNDEF LCL}
property TimerPool : TOvcTimerPool
read FTimerPool;
{$ENDIF}
published
{properties}
property EntryCommands : TOvcCommandProcessor
read FEntryCommands write FEntryCommands stored True;
property EntryOptions : TOvcBaseEFOptions
read FBaseEFOptions write FBaseEFOptions
default [efoAutoSelect, efoBeepOnError, efoInsertPushes];
property Epoch : Integer
read GetEpoch write SetEpoch;
{events}
property OnError : TDataErrorEvent
read FOnError write FOnError;
property OnGetEpoch : TGetEpochEvent
read FOnGetEpoch write FOnGetEpoch;
property OnDelayNotify : TDelayNotifyEvent
read FOnDelayNotify write FOnDelayNotify;
property OnIsSpecialControl : TIsSpecialControlEvent
read FOnIsSpecialControl write FOnIsSpecialControl;
property OnPostEdit : TPostEditEvent
read FOnPostEdit write FOnPostEdit;
property OnPreEdit : TPreEditEvent
read FOnPreEdit write FOnPreEdit;
{$IFNDEF LCL}
property OnTimerTrigger : TTriggerEvent
read FOnTimerTrigger write FOnTimerTrigger;
{$ENDIF}
end;
TOvcGraphicControl = class(TGraphicControl)
protected {private}
FCollectionStreamer : TOvcCollectionStreamer;
{property methods}
function GetAbout : string;
procedure SetAbout(const Value : string);
protected
{Collection streaming hooks:}
procedure GetChildren(Proc: TGetChildProc; Root : TComponent); override;
function GetChildOwner: TComponent; override;
procedure Loaded; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property CollectionStreamer : TOvcCollectionStreamer
read FCollectionStreamer write FCollectionStreamer;
published
property About : string
read GetAbout write SetAbout stored False;
end;
{Replacement for the TOvcCustomControl except with standard VCL streaming}
TO32CustomControl = class(TCustomControl)
protected {private}
{property variables}
FAfterEnter : TNotifyEvent;
FAfterExit : TNotifyEvent;
FOnMouseWheel : TMouseWheelEvent;
FLabelInfo : TOvcLabelInfo;
FInternal : Boolean; {flag to suppress name generation
on collection items}
{property methods}
function GetAttachedLabel : TOvcAttachedLabel;
function GetAbout : string;
procedure SetAbout(const Value : string);
{internal methods}
procedure LabelAttach(Sender : TObject; Value : Boolean);
procedure LabelChange(Sender : TObject);
procedure PositionLabel;
{private message methods}
procedure OMAssignLabel(var Msg : TMessage);
message OM_ASSIGNLABEL;
procedure OMPositionLabel(var Msg : TMessage);
message OM_POSITIONLABEL;
procedure OMRecordLabelPosition(var Msg : TMessage);
message OM_RECORDLABELPOSITION;
procedure OMAfterEnter(var Msg : TMessage);
message OM_AFTERENTER;
procedure OMAfterExit(var Msg : TMessage);
message OM_AFTEREXIT;
{VCL message methods}
procedure CMVisibleChanged(var Msg : TMessage);
message CM_VISIBLECHANGED;
{windows message methods}
procedure WMKillFocus(var Msg : TWMKillFocus);
message WM_KILLFOCUS;
procedure WMMouseWheel(var Msg : TMessage);
message WM_MOUSEWHEEL;
procedure WMSetFocus(var Msg : TWMSetFocus);
message WM_SETFOCUS;
protected
DefaultLabelPosition : TOvcLabelPosition;
procedure DoOnMouseWheel(Shift : TShiftState;
Delta, XPos, YPos : SmallInt);
dynamic;
procedure CreateWnd;
override;
procedure Notification(AComponent : TComponent; Operation : TOperation);
override;
property AfterEnter : TNotifyEvent
read FAfterEnter write FAfterEnter;
property AfterExit : TNotifyEvent
read FAfterExit write FAfterExit;
property OnMouseWheel : TMouseWheelEvent
read FOnMouseWheel write FOnMouseWheel;
property LabelInfo : TOvcLabelInfo
read FLabelInfo write FLabelInfo;
public
property Internal : Boolean read FInternal write FInternal;
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
override;
property AttachedLabel : TOvcAttachedLabel
read GetAttachedLabel;
published
property About : string
read GetAbout write SetAbout stored False;
end;
{End - TO32CustomControl}
TOvcCustomControl = class(TCustomControl)
protected {private}
{property variables}
FAfterEnter : TNotifyEvent;
FAfterExit : TNotifyEvent;
FCollectionStreamer : TOvcCollectionStreamer;
FOnMouseWheel : TMouseWheelEvent;
FLabelInfo : TOvcLabelInfo;
FInternal : Boolean; {flag to suppress name generation
on collection items}
{property methods}
function GetAttachedLabel : TOvcAttachedLabel;
function GetAbout : string;
procedure SetAbout(const Value : string);
{internal methods}
procedure LabelAttach(Sender : TObject; Value : Boolean);
procedure LabelChange(Sender : TObject);
procedure PositionLabel;
{private message methods}
procedure OMAssignLabel(var Msg : TMessage);
message OM_ASSIGNLABEL;
procedure OMPositionLabel(var Msg : TMessage);
message OM_POSITIONLABEL;
procedure OMRecordLabelPosition(var Msg : TMessage);
message OM_RECORDLABELPOSITION;
procedure OMAfterEnter(var Msg : TMessage);
message OM_AFTERENTER;
procedure OMAfterExit(var Msg : TMessage);
message OM_AFTEREXIT;
{VCL message methods}
procedure CMVisibleChanged(var Msg : TMessage);
message CM_VISIBLECHANGED;
{windows message methods}
procedure WMKillFocus(var Msg : TWMKillFocus);
message WM_KILLFOCUS;
procedure WMMouseWheel(var Msg : TMessage);
message WM_MOUSEWHEEL;
procedure WMSetFocus(var Msg : TWMSetFocus);
message WM_SETFOCUS;
protected
{descendants can set the value of this variable after calling inherited }
{create to set the default location and point-of-reference (POR) for the}
{attached label. if dlpTopLeft, the default location and POR will be at }
{the top left of the control. if dlpBottomLeft, the default location and}
{POR will be at the bottom left}
DefaultLabelPosition : TOvcLabelPosition;
procedure DoOnMouseWheel(Shift : TShiftState;
Delta, XPos, YPos : SmallInt);
dynamic;
procedure CreateWnd;
override;
procedure Notification(AComponent : TComponent; Operation : TOperation);
override;
{Collection streaming hooks:}
procedure GetChildren(Proc: TGetChildProc; Root : TComponent); override;
function GetChildOwner: TComponent; override;
procedure Loaded; override;
property AfterEnter : TNotifyEvent
read FAfterEnter write FAfterEnter;
property AfterExit : TNotifyEvent
read FAfterExit write FAfterExit;
property OnMouseWheel : TMouseWheelEvent
read FOnMouseWheel write FOnMouseWheel;
property LabelInfo : TOvcLabelInfo
read FLabelInfo write FLabelInfo;
public
property Internal : Boolean read FInternal write FInternal;
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
override;
property AttachedLabel : TOvcAttachedLabel
read GetAttachedLabel;
property CollectionStreamer : TOvcCollectionStreamer
read FCollectionStreamer write FCollectionStreamer;
published
property About : string
read GetAbout write SetAbout stored False;
end;
TOvcCollectible = class(TOvcComponent)
protected {private}
FCollection : TOvcCollection;
InChanged : Boolean;
function GetIndex : Integer;
procedure SetCollection(Value : TOvcCollection);
procedure SetIndex(Value : Integer); virtual;
protected
procedure Changed; dynamic;
function GenerateName : string;
dynamic;
function GetBaseName : string;
dynamic;
function GetDisplayText : string;
virtual;
procedure SetName(const NewName : TComponentName);
override;
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
property Collection : TOvcCollection
read FCollection;
property DisplayText : string
read GetDisplayText;
property Index : Integer
read GetIndex
write SetIndex;
property Name;
end;
TO32CollectionItem = class(TCollectionItem)
protected {private}
FName: String;
FDisplayText: String;
function GetAbout: String;
procedure SetAbout(const Value: String);
procedure SetName(Value: String); virtual;
public
property DisplayText : string read FDisplayText write FDisplayText;
property Name: String read FName write SetName;
published
property About : String read GetAbout write SetAbout;
end;
TOvcCollectibleControl = class(TOvcCustomControl)
protected {private}
FCollection : TOvcCollection;
FInternal : Boolean; {flag to suppress name generation
on collection items}
InChanged : Boolean;
function GetIndex : Integer;
procedure SetCollection(Value : TOvcCollection);
procedure SetIndex(Value : Integer);
protected
procedure Changed; dynamic;
function GenerateName : string;
dynamic;
function GetBaseName : string;
dynamic;
function GetDisplayText : string;
virtual;
procedure SetName(const NewName : TComponentName);
override;
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
property Internal : Boolean read FInternal write FInternal;
property Collection : TOvcCollection
read FCollection;
property DisplayText : string
read GetDisplayText;
property Index : Integer
read GetIndex
write SetIndex;
property Name;
end;
TOvcCollectibleClass = class of TComponent;
TO32CollectibleClass = class of TPersistent;
TOvcItemSelectedEvent =
procedure(Sender : TObject; Index : Integer) of object;
TOvcGetEditorCaption =
procedure(var Caption : string) of object;
TO32GetEditorCaption =
procedure(var Caption : string) of object;
TOvcCollection = class(TPersistent)
protected {private}
{property variables}
FItemClass : TOvcCollectibleClass;
FItemEditor : TForm;
FItems : TList;
FOwner : TComponent;
FReadOnly : Boolean;
FStored : Boolean;
FStreamer : TOvcCollectionStreamer;
{event variables}
FOnChanged : TNotifyEvent;
FOnItemSelected : TOvcItemSelectedEvent;
FOnGetEditorCaption : TOvcGetEditorCaption;
{Internal variables}
InLoaded : Boolean;
IsLoaded : Boolean;
InChanged : Boolean;
protected
function GetCount : Integer;
function GetItem(Index: Integer): TComponent;
procedure SetItem(Index: Integer; Value: TComponent);
procedure Changed;
virtual;
procedure Loaded;
public
constructor Create(AOwner : TComponent; ItemClass : TOvcCollectibleClass);
destructor Destroy;
override;
property ItemEditor : TForm
read FItemEditor write FItemEditor;
function Add : TComponent;
procedure Clear; virtual;
procedure Delete(Index : Integer);
procedure DoOnItemSelected(Index : Integer);
function GetEditorCaption : string;
function ItemByName(const Name : string) : TComponent;
function Insert(Index : Integer) : TComponent;
function ParentForm : TForm;
property Count: Integer
read GetCount;
property ItemClass : TOvcCollectibleClass
read FItemClass;
property Item[Index: Integer] : TComponent
read GetItem write SetItem; default;
property OnGetEditorCaption : TOvcGetEditorCaption
read FOnGetEditorCaption write FOnGetEditorCaption;
property Owner : TComponent
read FOwner;
property ReadOnly : Boolean
read FReadOnly write FReadOnly default False;
property Stored : Boolean
read FStored write FStored default True;
property OnChanged : TNotifyEvent
read FOnChanged write FOnChanged;
property OnItemSelected : TOvcItemSelectedEvent
read FOnItemSelected write FOnItemSelected;
end;
TO32Collection = class(TCollection)
protected {private}
{property variables}
FItemEditor : TForm;
FReadOnly : Boolean;
FOwner: TPersistent;
{event variables}
FOnChanged : TNotifyEvent;
FOnItemSelected : TOvcItemSelectedEvent;
FOnGetEditorCaption : TO32GetEditorCaption;
{Internal variables}
InLoaded : Boolean;
IsLoaded : Boolean;
InChanged : Boolean;
protected
function GetCount : Integer;
procedure Loaded;
public
constructor Create(AOwner : TPersistent;
ItemClass : TCollectionItemClass); virtual;
destructor Destroy; override;
property ItemEditor : TForm read FItemEditor write FItemEditor;
function Add : TO32CollectionItem; dynamic;
{$IFNDEF VERSION4}
function Insert(Index: Integer): TO32CollectionItem; dynamic;
{$ENDIF}
function GetItem(Index: Integer): TO32CollectionItem;
function GetOwner: TPersistent; override;
procedure SetItem(Index: Integer; Value: TO32CollectionItem);
procedure DoOnItemSelected(Index : Integer);
function GetEditorCaption : string;
function ItemByName(const Name : string) : TO32CollectionItem;
function ParentForm : TForm;
property Count: Integer
read GetCount;
property Item[Index: Integer] : TO32CollectionItem
read GetItem write SetItem; default;
property OnGetEditorCaption : TO32GetEditorCaption
read FOnGetEditorCaption write FOnGetEditorCaption;
property ReadOnly : Boolean
read FReadOnly write FReadOnly default False;
property OnChanged : TNotifyEvent
read FOnChanged write FOnChanged;
property OnItemSelected : TOvcItemSelectedEvent
read FOnItemSelected write FOnItemSelected;
end;
TOvcCollectionStreamer = class
protected {private}
FCollectionList : TList;
FOwner : TComponent;
protected
procedure Loaded;
procedure GetChildren(Proc: TGetChildProc; Root : TComponent);
public
constructor Create(AOwner : TComponent);
destructor Destroy;
override;
procedure Clear;
function CollectionFromType(Component : TComponent) : TOvcCollection;
property Owner : TComponent
read FOwner;
end;
type
{base class for Orpheus components. Provides controller access}
TOvcCustomControlEx = class(TOvcCustomControl)
protected {private}
FController : TOvcController;
function ControllerAssigned : Boolean;
function GetController: TOvcController;
procedure SetController(Value : TOvcController); virtual;
protected
procedure CreateWnd;
override;
procedure Notification(AComponent : TComponent; Operation : TOperation);
override;
public
property Controller : TOvcController
read GetController
write SetController;
end;
function FindController(Form : TWinControl) : TOvcController;
{-search for an existing controller component}
function GetImmediateParentForm(Control : TControl) : TWinControl;
{-return first form found while searching Parent}
procedure ResolveController(AForm : TWinControl; var AController : TOvcController);
{-find or create a controller on this form}
function DefaultController : TOvcController;
implementation
{.$DEFINE Logging}
uses
OvcVer,
TypInfo,
ExtCtrls,
{$IFNDEF LCL}
Consts,
{$ELSE}
LclStrConsts,
{$ENDIF}
OvcEF
{$IFDEF Logging}
,LogAPI
{$ENDIF}
;
type
TLocalEF = class(TOvcBaseEntryField);
var
FDefaultController : TOvcController = nil;
{===== TO32ContainerList =============================================}
constructor TO32ContainerList.Create(AOwner: TComponent);
begin
inherited Create;
FOwner := TComponent(AOwner);
end;
{=====}
destructor TO32ContainerList.Destroy;
var
I: Integer;
begin
for I := 0 to Count - 1 do
TPanel(Items[I]).Free;
inherited;
end;
{*** TOvcLabelInfo ***}
procedure TOvcLabelInfo.DoOnAttach;
begin
if Assigned(FOnAttach) then
FOnAttach(Self, FVisible);
end;
procedure TOvcLabelInfo.DoOnChange;
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
function TOvcLabelInfo.IsVisible : Boolean;
begin
Result := FVisible;
end;
procedure TOvcLabelInfo.SetOffsets(X, Y : Integer);
begin
if (X <> FOffsetX) or (Y <> FOffsetY) then begin
FOffsetX := X;
FOffsetY := Y;
DoOnChange;
end;
end;
procedure TOvcLabelInfo.SetOffsetX(Value : Integer);
begin
if Value <> FOffsetX then begin
FOffsetX := Value;
DoOnChange;
end;
end;
procedure TOvcLabelInfo.SetOffsetY(Value : Integer);
begin
if Value <> FOffsetY then begin
FOffsetY := Value;
DoOnChange;
end;
end;
procedure TOvcLabelInfo.SetVisible(Value : Boolean);
begin
if Value <> FVisible then begin
FVisible := Value;
DoOnAttach;
end;
end;
{*** TOvcAttachedLabel ***}
constructor TOvcAttachedLabel.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{set new defaults}
AutoSize := True;
ParentFont := True;
Transparent := False;
end;
constructor TOvcAttachedLabel.CreateEx(AOwner : TComponent; AControl : TWinControl);
begin
FControl := AControl;
Create(AOwner);
{set attached control property}
FocusControl := FControl;
end;
procedure TOvcAttachedLabel.Loaded;
begin
inherited Loaded;
SavePosition;
end;
procedure TOvcAttachedLabel.SavePosition;
var
PF : TWinControl;
I : Integer;
begin
if (csLoading in ComponentState) or (csDestroying in ComponentState) then
Exit;
{see if our associated control is on the form - save position}
PF := GetImmediateParentForm(Self);
if Assigned(PF) then begin
for I := 0 to Pred(PF.ComponentCount) do begin
if PF.Components[I] = FControl then begin
SendMessage(FControl.Handle, OM_ASSIGNLABEL, 0, LPARAM(Self)); //64
PostMessage(FControl.Handle, OM_RECORDLABELPOSITION, 0, 0);
Break;
end;
end;
end;
end;
procedure TOvcAttachedLabel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
SavePosition;
{ The following line causes the IDE to mark the form dirty, requiring it }
{ to be saved. Not sure what this was supposed to do, but commenting it }
{ out seems to solve the problem. }
{Application.ProcessMessages;}
end;
function FindController(Form : TWinControl) : TOvcController;
{-search for an existing controller component}
var
I : Integer;
begin
Result := nil;
for I := 0 to Form.ComponentCount-1 do begin
if Form.Components[I] is TOvcController then begin
Result := TOvcController(Form.Components[I]);
Break;
end;
end;
end;
function GetImmediateParentForm(Control : TControl) : TWinControl;
{return first form found while searching Parent}
var
ParentCtrl : TControl;
begin
ParentCtrl := Control.Parent;
{$IFDEF VERSION5}
while Assigned(ParentCtrl) and
not ((ParentCtrl is TCustomForm) or
(ParentCtrl is TCustomFrame)) do
{$ELSE}
while Assigned(ParentCtrl) and (not (ParentCtrl is TCustomForm)) do
{$ENDIF}
ParentCtrl := ParentCtrl.Parent;
Result := TWinControl(ParentCtrl);
end;
procedure ResolveController(AForm : TWinControl; var AController : TOvcController);
{-find or create a controller on this form}
begin
if not Assigned(AController) then begin
{search for an existing controller. If not found,}
{create the controller as a child of the form}
{and assign it as our controller}
AController := FindController(AForm);
(*
if not Assigned(AController) then begin
AController := TOvcController.Create(AForm);
try
AController.Name := 'OvcController1';
except
AController.Free;
AController := nil;
raise;
end;
end;
*)
end;
end;
{*** TOvcComponent ***}
constructor TOvcComponent.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TOvcComponent.Destroy;
begin
FCollectionStreamer.Free;
FCollectionStreamer := nil;
inherited Destroy;
end;
function TOvcComponent.GetAbout : string;
begin
Result := OrVersionStr;
end;
procedure TOvcComponent.SetAbout(const Value : string);
begin
end;
{Logic for streaming collections of sub-components}
function TOvcComponent.GetChildOwner: TComponent;
begin
if assigned(FCollectionStreamer) then
Result := FCollectionStreamer.Owner
else
Result := inherited GetChildOwner;
end;
procedure TOvcComponent.GetChildren(Proc: TGetChildProc; Root : TComponent);
begin
if assigned(FCollectionStreamer) then
CollectionStreamer.GetChildren(Proc, Root)
else
inherited GetChildren(Proc,Root);
end;
procedure TOvcComponent.Loaded;
begin
if assigned(FCollectionStreamer) then
FCollectionStreamer.Loaded;
inherited Loaded;
end;
{*** TO32Component ***}
constructor TO32Component.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
function TO32Component.GetAbout : string;
begin
Result := OrVersionStr;
end;
procedure TO32Component.SetAbout(const Value : string);
begin
end;
{*** TOvcCollectible ***}
constructor TOvcCollectible.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
if (AOwner is TOvcComponent) then begin
if TOvcComponent(AOwner).CollectionStreamer = nil then
raise Exception.Create(GetOrphStr(SCNoCollection));
SetCollection(TOvcComponent(AOwner).CollectionStreamer.CollectionFromType(Self));
end else
if (AOwner is TOvcCustomControl) then begin
if TOvcCustomControl(AOwner).CollectionStreamer = nil then
raise Exception.Create(GetOrphStr(SCNoCollection));
SetCollection(TOvcCustomControl(AOwner).CollectionStreamer.CollectionFromType(Self));
end else
raise Exception.Create(GetOrphStr(SCNotOvcDescendant));
if (csDesigning in ComponentState)
and (AOwner <> nil) then
if ((AOwner is TOvcComponent) and not TOvcComponent(AOwner).FInternal)
or ((AOwner is TOvcCollectibleControl) and not TOvcCollectibleControl(AOwner).FInternal)
or ((AOwner is TOvcCustomControl) and not TOvcCustomControl(AOwner).FInternal) then
{$IFDEF VERSION5}
if not (csLoading in AOwner.ComponentState) then
{$ELSE}
if not (csLoading in AOwner.ComponentState) then
{$ENDIF}
Name := GenerateName;
end;
destructor TOvcCollectible.Destroy;
var
OldCollection : TOvcCollection;
begin
OldCollection := Collection;
SetCollection(nil);
inherited Destroy;
{mark dirty}
if (csDesigning in ComponentState)
and (OldCollection <> nil)
and not (csDestroying in
OldCollection.Owner.ComponentState) then begin
OldCollection.Changed;
end;
end;
function TOvcCollectible.GenerateName : string;
var
PF : TWinControl;
I : Integer;
S : string;
function SearchSubComponents(C : TComponent; const S : string) : TComponent;
var
I : Integer;
begin
Result := C;
if CompareText(S, Result.Name) = 0 then
Exit;
for I := 0 to C.ComponentCount-1 do begin
Result := SearchSubComponents(C.Components[I], S);
if Result <> nil then
Exit;
end;
Result := nil;
end;
function FindComponentName(const S : string) : TComponent;
begin
Result := SearchSubComponents(PF, S);
end;
begin
I := 1;
S := GetBaseName;
Result := Format('%s%d', [S, I]);
PF := Collection.ParentForm;
if not Assigned(PF) then
Exit;
while FindComponentName(Result) <> nil do begin
Inc(I);
Result := Format('%s%d', [S, I]);
end;
end;
procedure TOvcCollectible.SetName(const NewName : TComponentName);
begin
inherited SetName(NewName);
if not (csLoading in ComponentState) then
{$IFDEF VERSION5}
if (csInLine in ComponentState) then
Changed;
{$ENDIF}
if (Collection <> nil)
and (Collection.ItemEditor <> nil) then
SendMessage(Collection.ItemEditor.Handle, OM_PROPCHANGE, 0, 0);
end;
function TOvcCollectible.GetBaseName : string;
begin
Result := 'CollectionItem';
end;
function TOvcCollectible.GetDisplayText : string;
begin
Result := ClassName;
end;
procedure TOvcCollectible.Changed;
begin
if InChanged then exit;
InChanged := True;
try
{$IFDEF Logging}
LogMsg('TOvcCollectible.Changed');
LogBoolean('assigned(FCollection)', assigned(FCollection));
LogBoolean('(csInline in ComponentState)', (csInline in ComponentState));
LogBoolean('csAncestor in Owner.ComponentState', csAncestor in Owner.ComponentState);
{$ENDIF}
if assigned(FCollection) then
{$IFDEF Version5}
if not (csInline in ComponentState) then
{$ENDIF}
FCollection.Changed;
finally
InChanged := False;
end;
end;
function TOvcCollectible.GetIndex : Integer;
begin
if assigned(FCollection) then
Result := FCollection.FItems.IndexOf(Self)
else
Result := -1;
end;
procedure TOvcCollectible.SetIndex(Value : Integer);
begin
if Value <> Index then begin
if assigned(FCollection) then begin
FCollection.FItems.Remove(Self);
FCollection.FItems.Insert(Value,Self);
end;
Changed;
end;
end;
procedure TOvcCollectible.SetCollection(Value : TOvcCollection);
begin
if Collection <> Value then begin
if Collection <> nil then
Collection.FItems.Remove(Self);
if Value <> nil then begin
if not (Self is Value.ItemClass) then
raise Exception.Create(GetOrphStr(SCItemIncompatible));
Value.FItems.Add(Self);
end;
FCollection := Value;
end;
end;
{===== TO32CollectionItem ============================================}
function TO32CollectionItem.GetAbout: String;
begin
Result := OrVersionStr;
end;
procedure TO32CollectionItem.SetAbout(const Value: String);
begin
end;
procedure TO32CollectionItem.SetName(Value: String);
begin
FName := Value;
end;
{=====}
{*** TOvcCollectibleControl ***}
constructor TOvcCollectibleControl.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
if (AOwner is TOvcComponent) then begin
if TOvcComponent(AOwner).CollectionStreamer = nil then
raise Exception.Create(GetOrphStr(SCNoCollection));
SetCollection(TOvcComponent(AOwner).CollectionStreamer.CollectionFromType(Self));
end else
if (AOwner is TOvcCustomControl) then begin
if TOvcCustomControl(AOwner).CollectionStreamer = nil then
raise Exception.Create(GetOrphStr(SCNoCollection));
SetCollection(TOvcCustomControl(AOwner).CollectionStreamer.CollectionFromType(Self));
end else
raise Exception.Create(GetOrphStr(SCNotOvcDescendant));
if (csDesigning in ComponentState)
and (AOwner <> nil) then
if ((AOwner is TOvcComponent) and not TOvcComponent(AOwner).FInternal)
or ((AOwner is TOvcCollectibleControl) and not TOvcCollectibleControl(AOwner).FInternal)
or ((AOwner is TOvcCustomControl) and not TOvcCustomControl(AOwner).FInternal) then
if not (csLoading in AOwner.ComponentState)
{$IFDEF Version5}
and not (csInLine in AOwner.ComponentState)
{$ENDIF}
then Name := GenerateName;
end;
destructor TOvcCollectibleControl.Destroy;
var
OldCollection : TOvcCollection;
begin
OldCollection := Collection;
SetCollection(nil);
inherited Destroy;
{mark dirty}
if (csDesigning in ComponentState)
and (OldCollection <> nil)
and not (csDestroying in
OldCollection.Owner.ComponentState) then begin
OldCollection.Changed;
end;
end;
function TOvcCollectibleControl.GenerateName : string;
var
PF : TWinControl;
I : Integer;
S : string;
function SearchSubComponents(C : TComponent; const S : string) : TComponent;
var
I : Integer;
begin
Result := C;
if CompareText(S, Result.Name) = 0 then
Exit;
for I := 0 to C.ComponentCount-1 do begin
Result := SearchSubComponents(C.Components[I], S);
if Result <> nil then
Exit;
end;
Result := nil;
end;
function FindComponentName(const S : string) : TComponent;
begin
Result := SearchSubComponents(PF, S);
end;
begin
I := 1;
S := GetBaseName;
Result := Format('%s%d', [S, I]);
PF := Collection.ParentForm;
if not Assigned(PF) then
Exit;
while FindComponentName(Result) <> nil do begin
Inc(I);
Result := Format('%s%d', [S, I]);
end;
end;
procedure TOvcCollectibleControl.SetName(const NewName : TComponentName);
begin
inherited SetName(NewName);
if not (csLoading in ComponentState) then
{$IFDEF Version5}
if not (csInLine in ComponentState) then
{$ENDIF}
Changed;
end;
function TOvcCollectibleControl.GetBaseName : string;
begin
Result := 'CollectionItem';
end;
function TOvcCollectibleControl.GetDisplayText : string;
begin
Result := ClassName;
end;
procedure TOvcCollectibleControl.Changed;
begin
if InChanged then exit;
InChanged := True;
try
if assigned(FCollection) then
{$IFDEF Version5}
if not (csInline in ComponentState) then
{$ENDIF}
FCollection.Changed;
finally
InChanged := False;
end;
end;
function TOvcCollectibleControl.GetIndex : Integer;
begin
if Collection <> nil then
Result := Collection.FItems.IndexOf(Self)
else
Result := -1;
end;
procedure TOvcCollectibleControl.SetIndex(Value : Integer);
begin
if Value <> Index then begin
if Collection <> nil then begin
Collection.FItems.Remove(Self);
Collection.FItems.Insert(Value,Self);
end;
Changed;
end;
end;
procedure TOvcCollectibleControl.SetCollection(Value : TOvcCollection);
begin
if Collection <> Value then begin
if Collection <> nil then
Collection.FItems.Remove(Self);
if Value <> nil then begin
if not (Self is Value.ItemClass) then
raise Exception.Create(GetOrphStr(SCItemIncompatible));
Value.FItems.Add(Self);
end;
FCollection := Value;
end;
end;
{*** TOvcController ***}
constructor TOvcController.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{create the command processor}
FEntryCommands := TOvcCommandProcessor.Create;
FBaseEFOptions := [efoAutoSelect, efoBeepOnError, efoInsertPushes];
FEpoch := DefaultEpoch;
FErrorPending := False;
FInsertMode := True;
{$IFNDEF LCL}
{create the general use timer pool}
FTimerPool := TOvcTimerPool.Create(Self);
FTimerPool.OnAllTriggers := DoOnTimerTrigger;
{$ENDIF}
end;
procedure TOvcController.cWndProc(var Msg : TMessage);
{-window procedure}
var
C : TWinControl;
begin
C := TWinControl(Msg.lParam);
try
with Msg do begin
case Msg of
OM_SETFOCUS :
begin
C.Show;
if C.CanFocus then
C.SetFocus;
end;
OM_PREEDIT :
if Assigned(FOnPreEdit) then
FOnPreEdit(TWinControl(lParam), FindControl(wParam));
OM_POSTEDIT :
if Assigned(FOnPostEdit) then
FOnPostEdit(TWinControl(lParam), FindControl(wParam));
OM_DELAYNOTIFY :
if Assigned(FOnDelayNotify) then
FOnDelayNotify(TObject(lParam), wParam);
else
Result := DefWindowProc(Handle, Msg, wParam, lParam);
end;
end;
except
Application.HandleException(Self);
end;
end;
{$IFDEF LCL}
function TOvcController.PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL;
var
AMsg : TMessage;
begin
if hWnd = Handle then
begin
AMsg.Msg := Msg;
AMsg.WParam := wParam;
AMsg.LParam := lParam;
cWndProc(AMsg);
end
else
{$IFDEF MSWINDOWS}
Result := MyMisc.PostMessage(hWnd, Msg, wParam, lParam);
{$ELSE}
Result := LclIntf.PostMessage(hWnd, Msg, wParam, lParam);
{$ENDIF}
end;
{$ENDIF}
procedure TOvcController.DelayNotify(Sender : TObject; NotifyCode : Word);
begin
if Assigned(FOnDelayNotify) then
PostMessage(Handle, OM_DELAYNOTIFY, NotifyCode, LPARAM(Sender)); //64
end;
destructor TOvcController.Destroy;
begin
{destroy the command processor}
FEntryCommands.Free;
FEntryCommands := nil;
{$IFNDEF LCL}
FTimerPool.Free;
FTimerPool := nil;
{$ENDIF}
{destroy window handle, if created}
DestroyHandle;
inherited Destroy;
end;
procedure TOvcController.DestroyHandle;
begin
{$IFNDEF LCL}
if FHandle <> 0 then
{$IFDEF VERSION6}
Classes.DeallocateHWnd(FHandle);
{$ELSE}
DeallocateHWnd(FHandle);
{$ENDIF}
{$ENDIF}
FHandle := 0;
end;
procedure TOvcController.DoOnError(Sender : TObject; ErrorCode : Word;
const ErrorMsg : string);
begin
if Assigned(FOnError) then
FOnError(Sender, ErrorCode, ErrorMsg)
else
MessageDlg(ErrorMsg, mtError, [mbOK], 0);
end;
procedure TOvcController.DoOnPostEdit(Sender : TObject; GainingControl : TWinControl);
var
H : hWnd;
begin
if Assigned(GainingControl) then
H := GainingControl.Handle
else
H := 0;
PostMessage(Handle, OM_POSTEDIT, H, LPARAM(Sender)); //64
end;
procedure TOvcController.DoOnPreEdit(Sender : TObject; LosingControl : TWinControl);
var
H : hWnd;
begin
if Assigned(LosingControl) then
H := LosingControl.Handle
else
H := 0;
PostMessage(Handle, OM_PREEDIT, H, LPARAM(Sender)); //64
end;
procedure TOvcController.DoOnTimerTrigger(Sender : TObject; Handle : Integer;
Interval : Cardinal; ElapsedTime : LongInt);
begin
{$IFNDEF LCL}
if Assigned(FOnTimerTrigger) then
FOnTimerTrigger(Sender, Handle, Interval, ElapsedTime);
{$ENDIF}
end;
function TOvcController.GetEpoch : Integer;
begin
Result := FEpoch;
if Assigned(FOnGetEpoch) then
FOnGetEpoch(Self, Result);
end;
{ - HWnd changed to TOvcHWnd for BCB Compatibility }
function TOvcController.GetHandle : TOvcHWnd{hWnd};
begin
// AllocateHWnd not available in LCL to create non-visual window that
// responds to messages sent to controller. But shouldn't be needed
// with controller's PostMessage method that intercepts messages.
{$IFNDEF LCL}
if FHandle = 0 then
{$IFDEF VERSION6}
FHandle := Classes.AllocateHWnd(cWndProc);
{$ELSE}
FHandle := AllocateHWnd(cWndProc);
{$ENDIF}
{$ENDIF}
Result := FHandle;
end;
{ - HWnd changed to TOvcHWnd for BCB Compatibility }
function TOvcController.IsSpecialButton(H : TOvcHWnd{hWnd}) : Boolean;
begin
Result := False;
if Assigned(FOnIsSpecialControl) then
FOnIsSpecialControl(Self, FindControl(H), Result);
end;
procedure TOvcController.MarkAsUninitialized(Uninitialized : Boolean);
{-mark all entry fields on form as uninitialized}
var
I : Integer;
procedure MarkField(C : TComponent);
var
J : Integer;
begin
{first, see if this component is an entry field}
if C is TOvcBaseEntryField then
TOvcBaseEntryField(C).Uninitialized := Uninitialized;
{recurse through all child components}
for J := 0 to C.ComponentCount-1 do
MarkField(C.Components[J]);
end;
begin
{$IFDEF VERSION5}
if (Owner is TCustomForm) or (Owner is TCustomFrame) then
with TWinControl(Owner) do
{$ELSE}
if Owner is TForm then
with TForm(Owner) do
{$ENDIF}
for I := 0 to ComponentCount-1 do
MarkField(Components[I]);
end;
procedure TOvcController.SetEpoch(Value : Integer);
begin
if Value <> FEpoch then
if (Value >= MinYear) and (Value <= MaxYear) then
FEpoch := Value;
end;
function TOvcController.ValidateEntryFields : TComponent;
begin
{if error, report it and send focus to field with error}
Result := ValidateEntryFieldsEx(True, True);
end;
function TOvcController.ValidateEntryFieldsEx(ReportError, ChangeFocus : Boolean) : TComponent;
var
I : Integer;
procedure ValidateEF(C : TComponent);
var
J : Integer;
EF : TLocalEF absolute C;
begin
{see if this component is an entry field}
if (C is TOvcBaseEntryField) then begin
{don't validate invisible or disabled fields}
if not EF.Visible or not EF.Enabled then
Exit;
{ask entry field to validate itself}
if (EF.ValidateContents(False) <> 0) then begin
{remember only the first invalid field found}
if not Assigned(Result) then
Result := EF;
{tell the entry field to report the error}
if ReportError and not ErrorPending then
PostMessage(EF.Handle, OM_REPORTERROR, EF.LastError, 0);
{ask the controller to give the focus back to this field}
if ChangeFocus and not ErrorPending then begin
PostMessage(Handle, OM_SETFOCUS, 0, LPARAM(EF)); //64
ErrorPending := True;
end;
{exit if we are reporting the error or changing the focus}
if (ReportError or ChangeFocus) then
Exit;
end;
end;
{recurse through all child components}
for J := 0 to C.ComponentCount-1 do begin
ValidateEf(C.Components[J]);
{exit if we've already found an error and should stop}
if Assigned(Result) and (ReportError or ChangeFocus) then
Break;
end;
end;
begin
Result := nil;
{$IFDEF VERSION5}
if ((Owner is TCustomForm) or (Owner is TCustomFrame)) then
with TWinControl(Owner) do
{$ELSE}
if Owner is TForm then
with TForm(Owner) do
{$ENDIF}
for I := 0 to ComponentCount-1 do begin
ValidateEf(Components[I]);
{stop checking if reporting the error or changing focus}
if Assigned(Result) and (ReportError or ChangeFocus) then
Break ;
end;
end;
function TOvcController.ValidateTheseEntryFields(const Fields : array of TComponent) : TComponent;
{-ask the specified entry fields to validate their contents. Return nil
if no error, else return pointer to field with error}
var
I : Integer;
EF : TLocalEF;
begin
Result := nil;
for I := Low(Fields) to High(Fields) do begin
if Fields[I] is TOvcBaseEntryField then begin
EF := TLocalEF(Fields[I]);
{ask entry field to validate itself}
if (EF.ValidateContents(False) <> 0) then begin
Result := EF;
{tell the entry field to report the error}
if not ErrorPending then
PostMessage(EF.Handle, OM_REPORTERROR, EF.LastError, 0);
{ask the controller to give the focus back to this field}
if not ErrorPending then begin
PostMessage(Handle, OM_SETFOCUS, 0, LPARAM(EF)); //64
ErrorPending := True;
end;
Exit;
end;
end;
end;
end;
{*** TOvcGraphicControl ***}
constructor TOvcGraphicControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TOvcGraphicControl.Destroy;
begin
FCollectionStreamer.Free;
FCollectionStreamer := nil;
inherited Destroy;
end;
procedure TOvcGraphicControl.Loaded;
begin
if Assigned(FCollectionStreamer) then
FCollectionStreamer.Loaded;
inherited Loaded;
end;
{Logic for streaming collections of sub-components}
function TOvcGraphicControl.GetChildOwner: TComponent;
begin
if Assigned(FCollectionStreamer) then
Result := FCollectionStreamer.Owner
else
Result := inherited GetChildOwner;
end;
procedure TOvcGraphicControl.GetChildren(Proc: TGetChildProc; Root : TComponent);
begin
if Assigned(FCollectionStreamer) then
CollectionStreamer.GetChildren(Proc, Root)
else
inherited GetChildren(Proc, Root);
end;
function TOvcGraphicControl.GetAbout : string;
begin
Result := OrVersionStr;
end;
procedure TOvcGraphicControl.SetAbout(const Value : string);
begin
end;
{*** TO32CustomControl ***}
procedure TO32CustomControl.CMVisibleChanged(var Msg : TMessage);
begin
inherited;
if csLoading in ComponentState then
Exit;
if LabelInfo.Visible then
AttachedLabel.Visible := Visible;
end;
constructor TO32CustomControl.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
DefaultLabelPosition := lpTopLeft;
FLabelInfo := TOvcLabelInfo.Create;
FLabelInfo.OnChange := LabelChange;
FLabelInfo.OnAttach := LabelAttach;
end;
procedure TO32CustomControl.CreateWnd;
begin
inherited CreateWnd;
end;
destructor TO32CustomControl.Destroy;
begin
FLabelInfo.Visible := False;
FLabelInfo.Free;
FLabelInfo := nil;
inherited Destroy;
end;
procedure TO32CustomControl.DoOnMouseWheel(Shift : TShiftState;
Delta, XPos, YPos : SmallInt);
// Another TurboPower bug? Their TMouseWheelEvent expects Word
// params, yet passing SmallInts here. Delta is negative when
// scroll down, which will raise exception if a descendent class
// with a TMouseWheelEvent handler has range checking turned on.
// Note that their TMouseWheelEvent redefines LCL's.
begin
if Assigned(FOnMouseWheel) then
FOnMouseWheel(Self, Shift, Delta, XPos, YPos);
end;
function TO32CustomControl.GetAttachedLabel : TOvcAttachedLabel;
begin
if not FLabelInfo.Visible then
raise Exception.Create(GetOrphStr(SCLabelNotAttached));
Result := FLabelInfo.ALabel;
end;
function TO32CustomControl.GetAbout : string;
begin
Result := OrVersionStr;
end;
procedure TO32CustomControl.LabelAttach(Sender : TObject; Value : Boolean);
var
{$IFDEF VERSION5}
PF : TWinControl;
{$ELSE}
PF : TForm;
{$ENDIF}
S : string;
begin
if (csLoading in ComponentState) then
Exit;
{$IFDEF VERSION5}
PF := GetImmediateParentForm(Self);
{$ELSE}
PF := TForm(GetParentForm(Self));
{$ENDIF}
if Value then begin
if Assigned(PF) then begin
FLabelInfo.ALabel.Free;
FLabelInfo.ALabel := TOvcAttachedLabel.CreateEx(PF, Self);
FLabelInfo.ALabel.Parent := Parent;
S := GenerateComponentName(PF, Name + 'Label');
FLabelInfo.ALabel.Name := S;
FLabelInfo.ALabel.Caption := S;
FLabelInfo.SetOffsets(0, 0);
PositionLabel;
FLabelInfo.ALabel.BringToFront;
{force auto size}
FLabelInfo.ALabel.AutoSize := True;
end;
end else begin
if Assigned(PF) then begin
FLabelInfo.ALabel.Free;
FLabelInfo.ALabel := nil;
end;
end;
end;
procedure TO32CustomControl.LabelChange(Sender : TObject);
begin
if not (csLoading in ComponentState) then
PositionLabel;
end;
procedure TO32CustomControl.Notification(AComponent : TComponent; Operation : TOperation);
var
{$IFDEF VERSION5}
PF : TWinControl;
{$ELSE}
PF : TForm;
{$ENDIF}
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
if Assigned(FLabelInfo) and (AComponent = FLabelInfo.ALabel) then begin
{$IFDEF VERSION5}
PF := GetImmediateParentForm(Self);
{$ELSE}
PF := TForm(GetParentForm(Self));
{$ENDIF}
if Assigned(PF) and not (csDestroying in PF.ComponentState) then begin
FLabelInfo.FVisible := False;
FLabelInfo.ALabel := nil;
end;
end;
end;
procedure TO32CustomControl.OMAfterEnter(var Msg : TMessage);
begin
if Assigned(FAfterEnter) then
FAfterEnter(Self);
end;
procedure TO32CustomControl.OMAfterExit(var Msg : TMessage);
begin
if Assigned(FAfterExit) then
FAfterExit(Self);
end;
procedure TO32CustomControl.OMAssignLabel(var Msg : TMessage);
begin
FLabelInfo.ALabel := TOvcAttachedLabel(Msg.lParam);
end;
procedure TO32CustomControl.OMPositionLabel(var Msg : TMessage);
const
DX : Integer = 0;
DY : Integer = 0;
begin
if FLabelInfo.Visible and
Assigned(FLabelInfo.ALabel) and
(FLabelInfo.ALabel.Parent <> nil) and
not (csLoading in ComponentState) then begin
if DefaultLabelPosition = lpTopLeft then begin
DX := FLabelInfo.ALabel.Left - Left;
DY := FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top;
end else begin
DX := FLabelInfo.ALabel.Left - Left;
DY := FLabelInfo.ALabel.Top - Top - Height;
end;
if (DX <> FLabelInfo.OffsetX) or (DY <> FLabelInfo.OffsetY) then
PositionLabel;
end;
end;
procedure TO32CustomControl.OMRecordLabelPosition(var Msg : TMessage);
begin
if Assigned(FLabelInfo.ALabel) and
(FLabelInfo.ALabel.Parent <> nil) then begin
{if the label was cut and then pasted, this will complete the re-attachment}
FLabelInfo.FVisible := True;
if DefaultLabelPosition = lpTopLeft then
FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left,
FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top)
else
FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left,
FLabelInfo.ALabel.Top - Top - Height);
end;
end;
procedure TO32CustomControl.PositionLabel;
begin
if FLabelInfo.Visible and Assigned(FLabelInfo.ALabel) and
(FLabelInfo.ALabel.Parent <> nil) and
not (csLoading in ComponentState) then begin
if DefaultLabelPosition = lpTopLeft then begin
FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX,
FLabelInfo.OffsetY - FLabelInfo.ALabel.Height + Top,
FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height);
end else begin
FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX,
FLabelInfo.OffsetY + Top + Height,
FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height);
end;
end;
end;
procedure TO32CustomControl.SetBounds(ALeft, ATop, AWidth, AHeight : Integer);
begin
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
if HandleAllocated then
PostMessage(Handle, OM_POSITIONLABEL, 0, 0);
end;
procedure TO32CustomControl.SetAbout(const Value : string);
begin
end;
procedure TO32CustomControl.WMKillFocus(var Msg : TWMKillFocus);
begin
inherited;
PostMessage(Handle, OM_AFTEREXIT, 0, 0);
end;
procedure TO32CustomControl.WMMouseWheel(var Msg : TMessage);
// TurboPower bug: They should have used TWMMouseWheel instead of
// TMessage. Delta is negative on scroll down, but extracting it
// from wParam with HIWORD returns a Word, which causes an
// exception when passed as SmallInt to DoOnMouseWheel when
// range checking turned on. Fix is to cast delta as SmallInt.
begin
with Msg do
DoOnMouseWheel(KeysToShiftState(LOWORD(wParam)) {fwKeys},
SmallInt(HIWORD(wParam)) {zDelta}, //bug fix
LOWORD(lParam) {xPos}, HIWORD(lParam) {yPos});
end;
procedure TO32CustomControl.WMSetFocus(var Msg : TWMSetFocus);
begin
inherited;
PostMessage(Handle, OM_AFTERENTER, 0, 0);
end;
{*** End - TO32CustomCOntrol ***}
{*** TOvcCustomControl ***}
procedure TOvcCustomControl.CMVisibleChanged(var Msg : TMessage);
begin
inherited;
if csLoading in ComponentState then
Exit;
if LabelInfo.Visible then
AttachedLabel.Visible := Visible;
end;
constructor TOvcCustomControl.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
DefaultLabelPosition := lpTopLeft;
FLabelInfo := TOvcLabelInfo.Create;
FLabelInfo.OnChange := LabelChange;
FLabelInfo.OnAttach := LabelAttach;
end;
procedure TOvcCustomControl.CreateWnd;
begin
inherited CreateWnd;
end;
destructor TOvcCustomControl.Destroy;
begin
FLabelInfo.Visible := False;
FLabelInfo.Free;
FLabelInfo := nil;
FCollectionStreamer.Free;
FCollectionStreamer := nil;
inherited Destroy;
end;
procedure TOvcCustomControl.DoOnMouseWheel(Shift : TShiftState;
Delta, XPos, YPos : SmallInt);
begin
if Assigned(FOnMouseWheel) then
FOnMouseWheel(Self, Shift, Delta, XPos, YPos);
end;
function TOvcCustomControl.GetAttachedLabel : TOvcAttachedLabel;
begin
if not FLabelInfo.Visible then
raise Exception.Create(GetOrphStr(SCLabelNotAttached));
Result := FLabelInfo.ALabel;
end;
function TOvcCustomControl.GetAbout : string;
begin
Result := OrVersionStr;
end;
procedure TOvcCustomControl.LabelAttach(Sender : TObject; Value : Boolean);
var
{$IFDEF VERSION5}
PF : TWinControl;
{$ELSE}
PF : TForm;
{$ENDIF}
S : string;
begin
if (csLoading in ComponentState) then
Exit;
{$IFDEF VERSION5}
PF := GetImmediateParentForm(Self);
{$ELSE}
PF := TForm(GetParentForm(Self));
{$ENDIF}
if Value then begin
if Assigned(PF) then begin
FLabelInfo.ALabel.Free;
FLabelInfo.ALabel := TOvcAttachedLabel.CreateEx(PF, Self);
FLabelInfo.ALabel.Parent := Parent;
S := GenerateComponentName(PF, Name + 'Label');
FLabelInfo.ALabel.Name := S;
FLabelInfo.ALabel.Caption := S;
FLabelInfo.SetOffsets(0, 0);
PositionLabel;
FLabelInfo.ALabel.BringToFront;
{force auto size}
FLabelInfo.ALabel.AutoSize := True;
end;
end else begin
if Assigned(PF) then begin
FLabelInfo.ALabel.Free;
FLabelInfo.ALabel := nil;
end;
end;
end;
procedure TOvcCustomControl.LabelChange(Sender : TObject);
begin
if not (csLoading in ComponentState) then
PositionLabel;
end;
procedure TOvcCustomControl.Notification(AComponent : TComponent; Operation : TOperation);
var
{$IFDEF VERSION5}
PF : TWinControl;
{$ELSE}
PF : TForm;
{$ENDIF}
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
if Assigned(FLabelInfo) and (AComponent = FLabelInfo.ALabel) then begin
{$IFDEF VERSION5}
PF := GetImmediateParentForm(Self);
{$ELSE}
PF := TForm(GetParentForm(Self));
{$ENDIF}
if Assigned(PF) and not (csDestroying in PF.ComponentState) then begin
FLabelInfo.FVisible := False;
FLabelInfo.ALabel := nil;
end;
end;
end;
procedure TOvcCustomControl.OMAfterEnter(var Msg : TMessage);
begin
if Assigned(FAfterEnter) then
FAfterEnter(Self);
end;
procedure TOvcCustomControl.OMAfterExit(var Msg : TMessage);
begin
if Assigned(FAfterExit) then
FAfterExit(Self);
end;
procedure TOvcCustomControl.OMAssignLabel(var Msg : TMessage);
begin
FLabelInfo.ALabel := TOvcAttachedLabel(Msg.lParam);
end;
procedure TOvcCustomControl.OMPositionLabel(var Msg : TMessage);
const
DX : Integer = 0;
DY : Integer = 0;
begin
if FLabelInfo.Visible and
Assigned(FLabelInfo.ALabel) and
(FLabelInfo.ALabel.Parent <> nil) and
not (csLoading in ComponentState) then begin
if DefaultLabelPosition = lpTopLeft then begin
DX := FLabelInfo.ALabel.Left - Left;
DY := FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top;
end else begin
DX := FLabelInfo.ALabel.Left - Left;
DY := FLabelInfo.ALabel.Top - Top - Height;
end;
if (DX <> FLabelInfo.OffsetX) or (DY <> FLabelInfo.OffsetY) then
PositionLabel;
end;
end;
procedure TOvcCustomControl.OMRecordLabelPosition(var Msg : TMessage);
begin
if Assigned(FLabelInfo.ALabel) and
(FLabelInfo.ALabel.Parent <> nil) then begin
{if the label was cut and then pasted, this will complete the re-attachment}
FLabelInfo.FVisible := True;
if DefaultLabelPosition = lpTopLeft then
FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left,
FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top)
else
FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left,
FLabelInfo.ALabel.Top - Top - Height);
end;
end;
procedure TOvcCustomControl.PositionLabel;
begin
if FLabelInfo.Visible and Assigned(FLabelInfo.ALabel) and
(FLabelInfo.ALabel.Parent <> nil) and
not (csLoading in ComponentState) then begin
if DefaultLabelPosition = lpTopLeft then begin
FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX,
FLabelInfo.OffsetY - FLabelInfo.ALabel.Height + Top,
FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height);
end else begin
FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX,
FLabelInfo.OffsetY + Top + Height,
FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height);
end;
end;
end;
procedure TOvcCustomControl.SetBounds(ALeft, ATop, AWidth, AHeight : Integer);
begin
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
if HandleAllocated then
PostMessage(Handle, OM_POSITIONLABEL, 0, 0);
end;
procedure TOvcCustomControl.SetAbout(const Value : string);
begin
end;
procedure TOvcCustomControl.WMKillFocus(var Msg : TWMKillFocus);
begin
inherited;
PostMessage(Handle, OM_AFTEREXIT, 0, 0);
end;
procedure TOvcCustomControl.WMMouseWheel(var Msg : TMessage);
// See TurboPower bug comments above.
begin
with Msg do
DoOnMouseWheel(KeysToShiftState(LOWORD(wParam)) {fwKeys},
SmallInt(HIWORD(wParam)) {zDelta}, //bug fix
LOWORD(lParam) {xPos}, HIWORD(lParam) {yPos});
end;
procedure TOvcCustomControl.WMSetFocus(var Msg : TWMSetFocus);
begin
inherited;
PostMessage(Handle, OM_AFTERENTER, 0, 0);
end;
{Logic for streaming collections of sub-components}
function TOvcCustomControl.GetChildOwner: TComponent;
begin
if Assigned(FCollectionStreamer) then
Result := FCollectionStreamer.Owner
else
Result := inherited GetChildOwner;
end;
procedure TOvcCustomControl.GetChildren(Proc: TGetChildProc; Root : TComponent);
begin
if Assigned(FCollectionStreamer) then
CollectionStreamer.GetChildren(Proc, Root)
else
inherited GetChildren(Proc, Root);
end;
procedure TOvcCustomControl.Loaded;
begin
if Assigned(FCollectionStreamer) then
FCollectionStreamer.Loaded;
inherited Loaded;
end;
{*** TOvcCustomControlEx ***}
function TOvcCustomControlEx.ControllerAssigned : Boolean;
begin
Result := Assigned(FController);
end;
procedure TOvcCustomControlEx.CreateWnd;
var
OurForm : TWinControl;
begin
OurForm := GetImmediateParentForm(Self);
{do this only when the component is first dropped on the form, not during loading}
if (csDesigning in ComponentState) and not (csLoading in ComponentState) then
ResolveController(OurForm, FController);
if not Assigned(FController) and not (csLoading in ComponentState) then begin
{try to find a controller on this form that we can use}
FController := FindController(OurForm);
{if not found and we are not designing, use default controller}
if not Assigned(FController) and not (csDesigning in ComponentState) then
FController := DefaultController;
end;
inherited CreateWnd;
end;
function TOvcCustomControlEx.GetController: TOvcController;
begin
if FController = nil then
Result := DefaultController
else
Result := FController;
end;
procedure TOvcCustomControlEx.Notification(AComponent : TComponent; Operation : TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then begin
if (AComponent = FController) then
FController := nil;
end else if (Operation = opInsert) and (FController = nil) and
(AComponent is TOvcController) then
FController := TOvcController(AComponent);
end;
procedure TOvcCustomControlEx.SetController(Value : TOvcController);
begin
if not (TObject(Value) is TOvcController) then
Value := nil;
FController := Value;
if Value <> nil then
Value.FreeNotification(Self);
end;
function TOvcCollection.Add : TComponent;
begin
if not Assigned(FItemClass) then
raise Exception.Create(GetOrphStr(SCClassNotSet));
Result := FItemClass.Create(Owner);
Changed;
if ItemEditor <> nil then
SendMessage(ItemEditor.Handle, OM_PROPCHANGE, 0, 0);
end;
procedure TOvcCollection.Changed;
var
Parent : TForm;
begin
{$IFDEF Logging}
LogMsg('TOvcCollection.Changed');
LogBoolean('InChanged', InChanged);
{$ENDIF}
if InChanged then exit;
InChanged := True;
try
Parent := ParentForm;
if Parent <> nil then begin
{$IFDEF Logging}
LogString('Parent.ClassName', Parent.ClassName);
LogBoolean('(csLoading in Parent.ComponentState)', (csLoading in Parent.ComponentState));
{$ENDIF}
if not (csLoading in Parent.ComponentState)
and (csDesigning in Parent.ComponentState) then begin
{$IFDEF Logging}
LogBoolean('TForm(Parent).Designer <> nil', TForm(Parent).Designer <> nil);
LogBoolean('InLoaded', InLoaded);
LogBoolean('IsLoaded', IsLoaded);
LogBoolean('(csAncestor in Owner.ComponentState)', (csAncestor in Owner.ComponentState));
LogBoolean('Stored', Stored);
{$ENDIF}
{$IFDEF VERSION5}
if (TForm(Parent).Designer <> nil)
{$ELSE}
if (Parent.Designer <> nil)
{$ENDIF}
and not InLoaded
and IsLoaded
and not (csAncestor in Owner.ComponentState)
and Stored then
{$IFDEF VERSION5}
TForm(Parent).Designer.Modified;
{$ELSE}
Parent.Designer.Modified;
{$ENDIF}
if (ItemEditor <> nil)
and not (csAncestor in Owner.ComponentState)
then
SendMessage(ItemEditor.Handle, OM_PROPCHANGE, 0, 0);
end;
if Assigned(FOnChanged) then
FOnChanged(Self);
end;
finally
InChanged := False;
end;
end;
procedure TOvcCollection.Clear;
{$IFDEF Version5}
var
i : Integer;
{$ENDIF}
begin
{$IFDEF Version5}
for i := Count - 1 downto 0 do
if not (csAncestor in Item[i].ComponentState) then
Item[i].Free;
{$ELSE}
while Count > 0 do
Item[0].Free;
{$ENDIF}
if ItemEditor <> nil then
SendMessage(ItemEditor.Handle, OM_PROPCHANGE, 0, 0);
end;
constructor TOvcCollection.Create(AOwner : TComponent;
ItemClass : TOvcCollectibleClass);
begin
inherited Create;
FStored := True;
FItemClass := ItemClass;
FItems := TList.Create;
FOwner := AOwner;
if (AOwner is TOvcComponent) then
begin
if TOvcComponent(AOwner).CollectionStreamer = nil then
TOvcComponent(AOwner).CollectionStreamer := TOvcCollectionStreamer.Create(AOwner);
FStreamer := TOvcComponent(AOwner).CollectionStreamer;
FStreamer.FCollectionList.Add(Self);
end
else
if (AOwner is TOvcCustomControl) then
begin
if TOvcCustomControl(AOwner).CollectionStreamer = nil then
TOvcCustomControl(AOwner).CollectionStreamer := TOvcCollectionStreamer.Create(AOwner);
FStreamer := TOvcCustomControl(AOwner).CollectionStreamer;
FStreamer.FCollectionList.Add(Self);
end
else
raise Exception.Create(GetOrphStr(SCNotOvcDescendant));
end;
procedure TOvcCollection.Delete(Index : Integer);
begin
if (Index > -1) and (Index < Count) then
Item[Index].Free;
Changed;
end;
destructor TOvcCollection.Destroy;
begin
ItemEditor.Free;
if (Owner is TOvcComponent) then
TOvcComponent(Owner).CollectionStreamer.FCollectionList.Remove(Self)
else
TOvcCustomControl(Owner).CollectionStreamer.FCollectionList.Remove(Self);
Clear;
FItems.Free;
inherited Destroy;
end;
procedure TOvcCollection.DoOnItemSelected(Index : Integer);
begin
if Assigned(FOnItemSelected) then
FOnItemSelected(Self, Index);
end;
function TOvcCollection.GetCount : Integer;
begin
Result := FItems.Count;
end;
function TOvcCollection.GetEditorCaption : string;
begin
Result := 'Editing ' + ClassName;
if Assigned(FOnGetEditorCaption) then
FOnGetEditorCaption(Result);
end;
function TOvcCollection.GetItem(Index : Integer) : TComponent;
begin
Result := TComponent(FItems[Index]);
end;
function TOvcCollection.Insert(Index : Integer) : TComponent;
begin
if (Index < 0) or (Index > Count) then
Index := Count;
Result := Add;
if Result is TOvcCollectible then
TOvcCollectible(Item[Count-1]).Index := Index
else
if Result is TOvcCollectibleControl then
TOvcCollectibleControl(Item[Count-1]).Index := Index
else
Result := nil;
end;
function TOvcCollection.ItemByName(const Name : string) : TComponent;
var
i : Integer;
begin
for i := 0 to pred(Count) do
if Item[i].Name = Name then begin
Result := Item[i];
exit;
end;
Result := nil;
end;
procedure TOvcCollection.Loaded;
begin
InLoaded := True;
try
Changed;
finally
InLoaded := False;
end;
IsLoaded := True;
end;
function TOvcCollection.ParentForm : TForm;
var
Temp : TObject;
begin
Temp := Owner;
while (Temp <> nil) and not (Temp is TForm) do
Temp := TComponent(Temp).Owner;
Result := TForm(Temp);
end;
procedure TOvcCollection.SetItem(Index : Integer; Value : TComponent);
begin
TOvcCollectible(FItems[Index]).Assign(Value);
end;
procedure TOvcCollectionStreamer.Clear;
var
I : Integer;
begin
for I := 0 to pred(FCollectionList.Count) do
TOvcCollection(FCollectionList[I]).Clear;
end;
{===== TO32Collection ================================================}
constructor TO32Collection.Create(AOwner : TPersistent;
ItemClass : TCollectionItemClass);
begin
FOwner := AOwner;
Inherited Create(ItemClass);
end;
destructor TO32Collection.Destroy;
begin
ItemEditor.Free;
Clear;
inherited Destroy;
end;
procedure TO32Collection.DoOnItemSelected(Index : Integer);
begin
if Assigned(FOnItemSelected) then
FOnItemSelected(Self, Index);
end;
function TO32Collection.GetCount : Integer;
begin
Result := inherited Count;
end;
function TO32Collection.GetEditorCaption : string;
begin
Result := 'Editing ' + ClassName;
if Assigned(FOnGetEditorCaption) then
FOnGetEditorCaption(Result);
end;
function TO32Collection.Add : TO32CollectionItem;
begin
Result := TO32CollectionItem(inherited Add);
if ItemEditor <> nil then
SendMessage(ItemEditor.Handle, OM_PROPCHANGE, 0, 0);
end;
{$IFNDEF VERSION4}
function TO32Collection.Insert(Index: Integer): TO32CollectionItem;
var
I: Integer;
begin
result := Add;
for I := Index to Count - 2 do
Items[I].Index := I + 1;
Items[Count - 1].Index := Index;
end;
{$ENDIF}
function TO32Collection.GetItem(Index : Integer) : TO32CollectionItem;
begin
Result := TO32CollectionItem(inherited GetItem(Index));
end;
function TO32Collection.GetOwner: TPersistent;
begin
result := FOwner;
end;
procedure TO32Collection.SetItem(Index : Integer; Value : TO32CollectionItem);
begin
inherited SetItem(Index, Value);
end;
function TO32Collection.ItemByName(const Name : string) : TO32CollectionItem;
var
i : Integer;
begin
for i := 0 to pred(Count) do
if Item[i].Name = Name then begin
Result := Item[i];
exit;
end;
Result := nil;
end;
procedure TO32Collection.Loaded;
begin
InLoaded := True;
try
Changed;
finally
InLoaded := False;
end;
IsLoaded := True;
end;
function TO32Collection.ParentForm : TForm;
var
Temp : TObject;
begin
Temp := GetOwner;
while (Temp <> nil) and not (Temp is TForm) do
Temp := TComponent(Temp).Owner;
Result := TForm(Temp);
end;
{End - TO32Collection }
{===== TOvcCollectionStreamer ========================================}
function TOvcCollectionStreamer.CollectionFromType(Component : TComponent) : TOvcCollection;
var
I : Integer;
begin
for I := 0 to pred(FCollectionList.Count) do
if Component is TOvcCollection(FCollectionList[I]).ItemClass then begin
Result := TOvcCollection(FCollectionList[I]);
exit;
end;
raise Exception.Create(GetOrphStr(SCCollectionNotFound));
end;
constructor TOvcCollectionStreamer.Create(AOwner : TComponent);
begin
inherited Create;
FOwner := AOwner;
FCollectionList := TList.Create;
end;
destructor TOvcCollectionStreamer.Destroy;
begin
FCollectionList.Free;
FCollectionList := nil;
inherited Destroy;
end;
procedure TOvcCollectionStreamer.GetChildren(Proc: TGetChildProc; Root : TComponent);
var
I,J: Integer;
begin
for I := 0 to pred(FCollectionList.Count) do
with TOvcCollection(FCollectionList[I]) do
if Stored then
for J := 0 to Count - 1 do
Proc(Item[J]);
end;
procedure TOvcCollectionStreamer.Loaded;
var
I : Integer;
begin
for I := 0 to pred(FCollectionList.Count) do
TOvcCollection(FCollectionList[I]).Loaded;
end;
function DefaultController : TOvcController;
begin
if FDefaultController = nil then
FDefaultController := TOvcController.Create(nil);
Result := FDefaultController;
end;
initialization
{register the attached label class}
if Classes.GetClass(TOvcAttachedLabel.ClassName) = nil then
Classes.RegisterClass(TOvcAttachedLabel);
{$IFDEF LCL}
{$I ovcbase.lrs}
{$ENDIF}
finalization
FDefaultController.Free;
FDefaultController := nil;
end.