paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
aa771f6036
lazarus-ccr/components/orpheus/ovcbase.pas
macpgmr ed64ad4b80 Fixed mouse wheel crashes. 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1449 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2011-01-15 20:59:53 +00:00

2759 lines
74 KiB
ObjectPascal
Raw Blame 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, LongInt(Self));
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, LongInt(Sender));
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, LongInt(Sender));
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, LongInt(Sender));
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, LongInt(EF));
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, LongInt(EF));
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.
Reference in New Issue View Git Blame Copy Permalink