{ ***************************************************************************** See the file COPYING.modifiedLGPL.txt, included in this distribution, for details about the license. ***************************************************************************** Author: Mattias Gaertner Abstract: This units defines the property editors used by the object inspector. A Property Editor is the interface between a row of the object inspector and a property in the RTTI. For more information see the big comment part below. } unit PropEdits; {$mode objfpc}{$H+} // This unit contains a lot of base type conversions. Disable range checking. {$R-} {$ModeSwitch advancedrecords} {$IF FPC_FULLVERSION>30300} {$Define HasExtRtti} {$ENDIF} interface uses // RTL / FCL Classes, TypInfo, SysUtils, types, RtlConsts, variants, Contnrs, strutils, FGL, Math, System.UITypes, // LCL LCLType, LCLIntf, LCLProc, Forms, Controls, ButtonPanel, Graphics, StdCtrls, Buttons, Menus, ExtCtrls, ComCtrls, Dialogs, EditBtn, Grids, ValEdit, FileCtrl, PropertyStorage, Themes, // LazControls CheckBoxThemed, // LazUtils FileUtil, StringHashList, LazMethodList, LazLoggerBase, LazUtilities, GraphType, FPCAdds, // for StrToQWord in older fpc versions // IdeIntf ObjInspStrConsts, PropEditUtils, TextTools, // Forms with .lfm files FrmSelectProps, StringsPropEditDlg, KeyValPropEditDlg, CollectionPropEditForm, FileFilterPropEditor, PagesPropEditDlg, IDEWindowIntf; const MaxIdentLength: Byte = 63; CheckBoxThemedLeftOffs = 3; {$IFDEF LCLCarbon} // LineFeed symbol (UTF8) to maintain linefeeds in multiline text for Carbon TEdit. // In Carbon, linefeeds get stripped from TEdit text, so we replace it temporary with // this symbol which displays correctly a LF symbol in the Object Inspector as well. LineFeedSymbolUTF8 = #226#144#138; {$ENDIF} type TPersistentSelectionList = PropEditUtils.TPersistentSelectionList; // For backwards compatibility only. Use TGetStrProc directly. TGetStringProc = Classes.TGetStrProc; { TPropertyEditor Edits a property of a component, or list of components, selected into the Object Inspector. The property editor is created based on the type of the property being edited as determined by the types registered by RegisterPropertyEditor. The Object Inspector uses a TPropertyEditor for all modification to a property. GetName and GetValue are called to display the name and value of the property. SetValue is called whenever the user requests to change the value. Edit is called when the user double-clicks the property in the Object Inspector. GetValues is called when the drop-down list of a property is displayed. GetProperties is called when the property is expanded to show sub-properties. AllEqual is called to decide whether or not to display the value of the property when more than one component is selected. The following are methods that can be overridden to change the behavior of the property editor: Activate Called whenever the property becomes selected in the object inspector. This is potentially useful to allow certain property attributes to to only be determined whenever the property is selected in the object inspector. Only paSubProperties and paMultiSelect,returned from GetAttributes,need to be accurate before this method is called. Deactivate Called whenevr the property becomes unselected in the object inspector. AllEqual Called whenever there is more than one component selected. If this method returns true,GetValue is called,otherwise blank is displayed in the Object Inspector. This is called only when GetAttributes returns paMultiSelect. AutoFill Called to determine whether the values returned by GetValues can be selected incrementally in the Object Inspector. This is called only when GetAttributes returns paValueList. Edit Called when the '...' button is pressed or the property is double-clicked. This can,for example,bring up a dialog to allow the editing the component in some more meaningful fashion than by text (e.g. the Font property). GetAttributes Returns the information for use in the Object Inspector to be able to show the appropriate tools. GetAttributes returns a set of type TPropertyAttributes: paValueList: The property editor can return an enumerated list of values for the property. If GetValues calls Proc with values then this attribute should be set. This will cause the drop-down button to appear to the right of the property in the Object Inspector. paSortList: Object Inspector to sort the list returned by GetValues. paPickList: Usable together with paValueList. The text field is readonly. The user can still select values from drop list. Unless paReadOnly. paSubProperties:The property editor has sub-properties that will be displayed indented and below the current property in standard outline format. If GetProperties will generate property objects then this attribute should be set. paDynamicSubProps:The sub properties can change. All designer tools (e.g. property editors, component editors) that change the list should call UpdateListPropertyEditors, so that the object inspector will reread the subproperties. paDialog: Indicates that the Edit method will bring up a dialog. This will cause the '...' button to be displayed to the right of the property in the Object Inspector. paMultiSelect: Allows the property to be displayed when more than one component is selected. Some properties are not appropriate for multi-selection (e.g. the Name property). paAutoUpdate: Causes the SetValue method to be called on each change made to the editor instead of after the change has been approved (e.g. the Caption property). paReadOnly: Value is not allowed to change. But if paDialog is set a Dialog can change the value. This disables only the edit and combobox in the object inspector. paRevertable: Allows the property to be reverted to the original value. Things that shouldn't be reverted are nested properties (e.g. Fonts) and elements of a composite property such as set element values. paFullWidthName:Tells the object inspector that the value does not need to be rendered and as such the name should be rendered the full width of the inspector. paVolatileSubProperties: Any change of property value causes any shown subproperties to be recollected. paDisableSubProperties: All subproperties are readonly (not even via Dialog). paReference: property contains a reference to something else. When used in conjunction with paSubProperties the referenced object should be displayed as sub properties to this property. paNotNestable: Indicates that the property is not safe to show when showing the properties of an expanded reference. GetComponent Returns the Index'th component being edited by this property editor. This is used to retrieve the components. A property editor can only refer to multiple components when paMultiSelect is returned from GetAttributes. GetEditLimit Returns the number of character the user is allowed to enter for the value. The inplace editor of the object inspector will be have its text limited set to the return value. By default this limit is 255. GetName Returns the name of the property. By default the value is retrieved from the type information with all underbars replaced by spaces. This should only be overridden if the name of the property is not the name that should appear in the Object Inspector. GetProperties Should be overridden to call PropertyProc for every sub-property (or nested property) of the property begin edited and passing a new TPropertyEditor for each sub-property. By default, PropertyProc is not called and no sub-properties are assumed. TClassPropertyEditor will pass a new property editor for each published property in a class. TSetPropertyEditor passes a new editor for each element in the set. GetPropType Returns the type information pointer for the property(s) being edited. GetValue Returns the string value of the property. By default this returns '(unknown)'. This should be overridden to return the appropriate value. GetValues Called when paValueList is returned in GetAttributes. Should call Proc for every value that is acceptable for this property. TEnumPropertyEditor will pass every element in the enumeration. Initialize Called after the property editor has been created but before it is used. Many times property editors are created and because they are not a common property across the entire selection they are thrown away. Initialize is called after it is determined the property editor is going to be used by the object inspector and not just thrown away. SetValue(Value) Called to set the value of the property. The property editor should be able to translate the string and call one of the SetXxxValue methods. If the string is not in the correct format or not an allowed value,the property editor should generate an exception describing the problem. Set value can ignore all changes and allow all editing of the property be accomplished through the Edit method (e.g. the Picture property). ListMeasureWidth(Value,Canvas,AWidth) This is called during the width calculation phase of the drop down list preparation. ListMeasureHeight(Value,Canvas,AHeight) This is called during the item/value height calculation phase of the drop down list's render. This is very similar to TListBox's OnMeasureItem, just slightly different parameters. ListDrawValue(Value,Canvas,Rect,Selected) This is called during the item/value render phase of the drop down list's render. This is very similar to TListBox's OnDrawItem, just slightly different parameters. PropMeasureHeight(Value,Canvas,AHeight) This is called during the item/property height calculation phase of the object inspectors rows render. This is very similar to TListBox's OnMeasureItem, just slightly different parameters. PropDrawName(Canvas,Rect,Selected) Called during the render of the name column of the property list. Its functionality is very similar to TListBox's OnDrawItem,but once again it has slightly different parameters. PropDrawValue(Canvas,Rect,Selected) Called during the render of the value column of the property list. Its functionality is similar to PropDrawName. If multiple items are selected and their values don't match this procedure will be passed an empty value. Properties and methods useful in creating new TPropertyEditor classes: Name property Returns the name of the property returned by GetName PrivateEditory property This is the configuration directory of lazarus. If the property editor needs auxiliary or state files (templates, examples, etc) they should be stored in this editory. Value property The current value,as a string,of the property as returned by GetValue. Modified Called to indicate the value of the property has been modified. Called automatically by the SetXxxValue methods. If you call a TProperty SetXxxValue method directly,you *must* call Modified as well. GetXxxValue Gets the value of the first property in the Properties property. Calls the appropriate TProperty GetXxxValue method to retrieve the value. SetXxxValue Sets the value of all the properties in the Properties property. Calls the approprate TProperty SetXxxxValue methods to set the value. GetVisualValue This function will return the displayable value of the property. If only one item is selected or all the multi-selected items have the same property value then this function will return the actual property value. Otherwise this function will return an empty string.} TPropertyAttribute=( paValueList, paPickList, paSubProperties, paDynamicSubProps, paDialog, paMultiSelect, paAutoUpdate, paSortList, paReadOnly, paRevertable, paFullWidthName, paVolatileSubProperties, paDisableSubProperties, paReference, paNotNestable, paCustomDrawn ); TPropertyAttributes = set of TPropertyAttribute; TPropertyEditor = class; { TInstProp } TInstProp = record Instance: TPersistent; // can be nil, e.g. record field PropInfo: PPropInfo; // can be nil, e.g. record field Field: Pointer; // for record field FieldName: PShortString; FieldTypeInfo: PTypeInfo; // ToDo: add list of parent instances, e.g. Label1.Font.Color: Font needs Label1 function GetTypeInfo: PTypeInfo; function GetKind: TTypeKind; function GetOrd: int64; procedure SetOrd(const Value: int64); function GetEnum: string; procedure SetEnum(const Value: string); function GetSet(Brackets: boolean): string; procedure SetSet(const Value: string); function GetString: AnsiString; procedure SetString(const Value: string); function GetWideString: WideString; procedure SetWideString(const Value: WideString); function GetUnicodeString: UnicodeString; procedure SetUnicodeString(const Value: UnicodeString); function GetRawByteString: RawByteString; procedure SetRawByteString(const Value: RawByteString); function GetFloat: Extended; procedure SetFloat(const Value: Extended); function GetObject(MinClass: TClass = nil): TObject; procedure SetObject(const Value: TObject); function GetPointerValue: Pointer; procedure SetPointerValue(const Value: Pointer); function GetMethod: TMethod; procedure SetMethod(const Value: TMethod); function GetInterface: IInterface; procedure SetInterface(const Value: IInterface); function GetVariant: Variant; procedure SetVariant(const Value: Variant); end; PInstProp = ^TInstProp; TInstPropList = array[0..999999] of TInstProp; PInstPropList = ^TInstPropList; TGetPropEditProc = procedure(Prop: TPropertyEditor) of object; TPropEditDrawStateType = (pedsSelected, pedsFocused, pedsInEdit, pedsInComboList); TPropEditDrawState = set of TPropEditDrawStateType; TPropEditHint = ( pehNone, pehTree, pehName, pehValue, pehEditButton ); TPropertyEditorHook = class; { TPropertyEditor } TPropertyEditor = class private FOnSubPropertiesChanged: TNotifyEvent; FPropertyHook: TPropertyEditorHook; FOwnerComponent: TComponent; FPropCount: Integer; FPropList: PInstPropList; protected // Draw Checkbox for Boolean and Set element editors. {$IFDEF UseOINormalCheckBox} function DrawCheckbox(ACanvas: TCanvas; const ARect: TRect; IsTrue: Boolean): TRect; {$ENDIF} function DrawCheckValue(ACanvas: TCanvas; const ARect: TRect; {%H-}AState: TPropEditDrawState; {%H-}IsTrue: Boolean): TRect; procedure DrawValue(const AValue: string; ACanvas:TCanvas; const ARect:TRect; {%H-}AState:TPropEditDrawState); function GetPrivateDirectory: ansistring; public constructor Create(Hook:TPropertyEditorHook; APropCount:Integer); virtual; destructor Destroy; override; procedure Activate; virtual; procedure Deactivate; virtual; function AllEqual: Boolean; virtual; function AutoFill: Boolean; virtual; // Called when clicking on OI property button or double clicking on value. procedure Edit; virtual; // Needed for method Contraints.OnChange etc. procedure Edit(AOwnerComponent: TComponent); procedure ShowValue; virtual; // called when Ctrl-Click on value function GetAttributes: TPropertyAttributes; virtual; function IsReadOnly: boolean; virtual; // For Delphi compatibility it is called GetComponent instead of GetPersistent function GetComponent(Index: Integer): TPersistent; function GetUnitName(Index: Integer = 0): string; function GetPropTypeUnitName(Index: Integer = 0): string; function GetPropertyPath(Index: integer = 0): string;// e.g. 'TForm1.Color' function GetEditLimit: Integer; virtual; function GetName: shortstring; virtual; procedure GetProperties({%H-}Proc: TGetPropEditProc); virtual; function GetPropType: PTypeInfo; function GetPropInfo: PPropInfo; function GetInstProp: PInstProp; function GetEnumValueAt(Index: Integer): string; function GetFloatValue: Extended; function GetFloatValueAt(Index: Integer): Extended; function GetInt64Value: Int64; function GetInt64ValueAt(Index: Integer): Int64; function GetIntfValue: IInterface; function GetIntfValueAt(Index: Integer): IInterface; function GetMethodValue: TMethod; function GetMethodValueAt(Index: Integer): TMethod; function GetOrdValue: Longint; function GetOrdValueAt(Index: Integer): Longint; function GetObjectValue: TObject; function GetObjectValue(MinClass: TClass): TObject; function GetObjectValueAt(Index: Integer): TObject; function GetObjectValueAt(Index: Integer; MinClass: TClass): TObject; function GetDefaultOrdValue: Longint; function GetSetValue(Brackets: boolean): AnsiString; function GetSetValueAt(Index: Integer; Brackets: boolean): AnsiString; function GetStrValue: AnsiString; function GetStrValueAt(Index: Integer): AnsiString; function GetVarValue: Variant; function GetVarValueAt(Index: Integer):Variant; function GetWideStrValue: WideString; function GetWideStrValueAt(Index: Integer): WideString; function GetUnicodeStrValue: UnicodeString; function GetUnicodeStrValueAt(Index: Integer): UnicodeString; function GetValue: ansistring; virtual; function GetHint({%H-}HintType: TPropEditHint; {%H-}x, {%H-}y: integer): string; virtual; function HasDefaultValue: Boolean; function GetDefaultValue: ansistring; virtual; function CallStoredFunction: Boolean; virtual; function GetVisualValue: ansistring; virtual; procedure GetValues({%H-}Proc: TGetStrProc); virtual; procedure Initialize; virtual; procedure Revert; virtual; procedure RevertToInherited; virtual; procedure SetValue(const {%H-}NewValue: ansistring); virtual; procedure SetPropEntry(Index: Integer; AnInstance: TPersistent; APropInfo: PPropInfo); virtual; procedure SetRecordFieldEntry(Index: Integer; AnInstance: Pointer; aName: PShortString; AFieldInfo: PTypeInfo); virtual; procedure SetFloatValue(const NewValue: Extended); procedure SetMethodValue(const NewValue: TMethod); procedure SetInt64Value(const NewValue: Int64); procedure SetIntfValue(const NewValue: IInterface); procedure SetOrdValue(const NewValue: Longint); procedure SetPtrValue(const NewValue: Pointer); procedure SetStrValue(const NewValue: AnsiString); procedure SetWideStrValue(const NewValue: WideString); procedure SetUnicodeStrValue(const NewValue: UnicodeString); procedure SetVarValue(const NewValue: Variant); procedure Modified(Index: integer = 0); function ValueAvailable: Boolean; procedure ListMeasureWidth(const {%H-}AValue: ansistring; {%H-}Index: Integer; {%H-}ACanvas: TCanvas; var {%H-}AWidth: Integer); virtual; procedure ListMeasureHeight(const AValue: ansistring; {%H-}Index: Integer; ACanvas: TCanvas; var AHeight: Integer); virtual; procedure ListDrawValue(const AValue: ansistring; {%H-}Index: Integer; ACanvas: TCanvas; const ARect: TRect; {%H-}AState: TPropEditDrawState); virtual; procedure PropMeasureHeight(const {%H-}NewValue: ansistring; {%H-}ACanvas: TCanvas; var {%H-}AHeight: Integer); virtual; procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; {%H-}AState: TPropEditDrawState); virtual; procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; {%H-}AState: TPropEditDrawState); virtual; procedure UpdateSubProperties; virtual; function SubPropertiesNeedsUpdate: boolean; virtual; function ValueIsStreamed: boolean; virtual; // if value is stored, usually because it differs from default value function IsRevertableToInherited: boolean; virtual; // These are used for the popup menu in OI function GetVerbCount: Integer; virtual; function GetVerb(Index: Integer): string; virtual; procedure PrepareItem({%H-}Index: Integer; const {%H-}AnItem: TMenuItem); virtual; procedure ExecuteVerb({%H-}Index: Integer); virtual; public property PropertyHook: TPropertyEditorHook read FPropertyHook; property PrivateDirectory: ansistring read GetPrivateDirectory; property PropCount: Integer read FPropCount; property FirstValue: ansistring read GetValue write SetValue; property OnSubPropertiesChanged: TNotifyEvent read FOnSubPropertiesChanged write FOnSubPropertiesChanged; end; TPropertyEditorClass = class of TPropertyEditor; TPropertyEditorList = specialize TFPGObjectList; { THiddenPropertyEditor A property editor to hide a published property. If you can't unpublish it, hide it. } THiddenPropertyEditor = class(TPropertyEditor) end; { TOrdinalPropertyEditor The base class of all ordinal property editors. It establishes that ordinal properties are all equal if the GetOrdValue all return the same value and provide methods to retrieve the default value. } TOrdinalPropertyEditor = class(TPropertyEditor) public function AllEqual: Boolean; override; function GetEditLimit: Integer; override; function GetValue: ansistring; override; function GetDefaultValue: ansistring; override; function OrdValueToVisualValue(OrdValue: longint): string; virtual; end; { TIntegerPropertyEditor Default editor for all Longint properties and all subtypes of the Longint type (i.e. Integer, Word, 1..10, etc.). Restricts the value entered into the property to the range of the sub-type. } TIntegerPropertyEditor = class(TOrdinalPropertyEditor) public function OrdValueToVisualValue(OrdValue: longint): string; override; procedure SetValue(const NewValue: ansistring); override; end; { TCharPropertyEditor Default editor for all Char properties and sub-types of Char (i.e. Char, 'A'..'Z', etc.). } TCharPropertyEditor = class(TOrdinalPropertyEditor) public function OrdValueToVisualValue(OrdValue: longint): string; override; procedure SetValue(const NewValue: ansistring); override; end; { TEnumPropertyEditor The default property editor for all enumerated properties (e.g. TShape = (sCircle, sTriangle, sSquare), etc.). } TEnumPropertyEditor = class(TOrdinalPropertyEditor) private FInvalid: Boolean; public function GetAttributes: TPropertyAttributes; override; function OrdValueToVisualValue(OrdValue: longint): string; override; function GetVisualValue: ansistring; override; procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const NewValue: ansistring); override; end; type { TBoolPropertyEditor Default property editor for all boolean properties } TBoolPropertyEditor = class(TEnumPropertyEditor) public function OrdValueToVisualValue(OrdValue: longint): string; override; function GetVisualValue: ansistring; override; procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const NewValue: ansistring); override; procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState); override; end; { TInt64PropertyEditor Default editor for all Int64 properties and all subtypes of Int64. } TInt64PropertyEditor = class(TPropertyEditor) public function AllEqual: Boolean; override; function GetEditLimit: Integer; override; function GetValue: ansistring; override; procedure SetValue(const NewValue: ansistring); override; end; { TQWordPropertyEditor Default editor for all QWord properties } TQWordPropertyEditor = class(TInt64PropertyEditor) public function GetValue: ansistring; override; procedure SetValue(const NewValue: ansistring); override; end; { TFloatPropertyEditor The default property editor for all floating point types (e.g. Float, Single, Double, etc.) } TFloatPropertyEditor = class(TPropertyEditor) protected function FloatInRange(AValue: Extended; AType: TFloatType): Boolean; public function AllEqual: Boolean; override; function FormatValue(const AValue: Extended): ansistring; function GetDefaultValue: ansistring; override; function GetValue: ansistring; override; procedure SetValue(const NewValue: ansistring); override; end; { TStringPropertyEditor The default property editor for all strings and sub types (e.g. string, string[20], etc.). } TStringPropertyEditor = class(TPropertyEditor) public function AllEqual: Boolean; override; function GetEditLimit: Integer; override; function GetValue: ansistring; override; procedure SetValue(const NewValue: ansistring); override; end; { TPasswordStringPropertyEditor The default property editor for string passwords} TPasswordStringPropertyEditor = class(TStringPropertyEditor) public function GetPassword: string; virtual; procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState); override; end; { TWideStringPropertyEditor The default property editor for widestrings} TWideStringPropertyEditor = class(TPropertyEditor) public function AllEqual: Boolean; override; function GetValue: ansistring; override; procedure SetValue(const NewValue: ansistring); override; end; { TPasswordWideStringPropertyEditor The default property editor for widestring passwords} TPasswordWideStringPropertyEditor = class(TWideStringPropertyEditor) public function GetPassword: WideString; virtual; procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState); override; end; { TUnicodeStringPropertyEditor The default property editor for unicodestrings} TUnicodeStringPropertyEditor = class(TPropertyEditor) public function AllEqual: Boolean; override; function GetValue: ansistring; override; procedure SetValue(const NewValue: ansistring); override; end; { TNestedPropertyEditor A property editor that uses the PropertyHook, PropList and PropCount. The constructor and destructor do not call inherited, but all derived classes should. This is useful for properties like the TSetElementPropertyEditor. } TNestedPropertyEditor = class(TPropertyEditor) private FParentEditor: TPropertyEditor; public constructor Create(Parent: TPropertyEditor); overload; destructor Destroy; override; property ParentEditor: TPropertyEditor read FParentEditor; end; { TSetElementPropertyEditor A property editor that edits an individual set element. GetName is changed to display the set element name instead of the property name and Get/SetValue is changed to reflect the individual element state. This editor is created by the TSetPropertyEditor editor. } TSetElementPropertyEditor = class(TNestedPropertyEditor) private FElement: Integer; public constructor Create(Parent: TPropertyEditor; AElement: Integer); overload; function AllEqual: Boolean; override; function GetAttributes: TPropertyAttributes; override; function GetName: shortstring; override; function GetValue: ansistring; override; function GetVerbCount: Integer; override; function GetVisualValue: ansistring; override; procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const NewValue: ansistring); override; function ValueIsStreamed: boolean; override; procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState); override; end; { TSetPropertyEditor Default property editor for all set properties. This editor does not edit the set directly but will display sub-properties for each element of the set. GetValue displays the value of the set in standard set syntax. } TSetPropertyEditor = class(TOrdinalPropertyEditor) public function GetAttributes: TPropertyAttributes; override; function GetEditLimit: Integer; override; procedure GetProperties(Proc: TGetPropEditProc); override; procedure SetValue(const NewValue: ansistring); override; function OrdValueToVisualValue(OrdValue: longint): string; override; end; { TStructurePropertyEditor } TStructurePropertyEditor = class(TPropertyEditor) private FSubPropsTypeFilter: TTypeKinds; FSubPropsNameFilter: String; FSubProps: TObjectList; protected function EditorFilter(const AEditor: TPropertyEditor): Boolean; virtual; procedure ListSubProps(Prop: TPropertyEditor); virtual; procedure SetSubPropsTypeFilter(const AValue: TTypeKinds); virtual; public constructor Create(Hook: TPropertyEditorHook; APropCount: Integer); override; destructor Destroy; override; function AllEqual: Boolean; override; property SubPropsTypeFilter: TTypeKinds read FSubPropsTypeFilter write SetSubPropsTypeFilter default tkAny; property SubPropsNameFilter: String read FSubPropsNameFilter write FSubPropsNameFilter; end; { TClassPropertyEditor Default property editor for all objects. Does not allow modifying the property but does display the class name of the object and will allow the editing of the object's properties as sub-properties of the property. } TClassPropertyEditor = class(TStructurePropertyEditor) private FHideClassName: Boolean; protected function GetSelections: TPersistentSelectionList; virtual; public function ValueIsStreamed: boolean; override; function GetAttributes: TPropertyAttributes; override; procedure GetProperties(Proc: TGetPropEditProc); override; function GetValue: String; override; property HideClassName: Boolean read FHideClassName write FHideClassName; end; { TPersistentPropertyEditor A base editor for TPersistent. It does allow editing of the properties. It allows the user to set the value of this property to point to a component in any form or datamodule that is type compatible with the property being edited (e.g. the DataSource property). } TPersistentPropertyEditor = class(TClassPropertyEditor) private // Used in AllEqual of TComponentOneFormPropertyEditor and TComponentPropertyEditor. function ComponentsAllEqual: Boolean; protected function FilterFunc(const ATestEditor: TPropertyEditor): Boolean; function GetPersistentReference: TPersistent; virtual; function GetSelections: TPersistentSelectionList; override; function CheckNewValue({%H-}APersistent: TPersistent): boolean; virtual; public function AllEqual: Boolean; override; procedure Edit; override; function GetAttributes: TPropertyAttributes; override; function GetEditLimit: Integer; override; function GetValue: AnsiString; override; procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const NewValue: ansistring); override; end; { TComponentOneFormPropertyEditor An editor for TComponents. It allows the user to set the value of this property to point to a component in the same form that is type compatible with the property being edited (e.g. the ActiveControl property). } TComponentOneFormPropertyEditor = class(TPersistentPropertyEditor) protected fIgnoreClass: TControlClass; public function AllEqual: Boolean; override; procedure GetValues(Proc: TGetStrProc); override; end; { TCoolBarControlPropertyEditor - An editor for TComponents. It allows the user to set the value of this property to point to a component in the same form that is type compatible with the property being edited and is not a TCustomCoolBar (e.g. the TCoolBand.Control property).} TCoolBarControlPropertyEditor = class(TComponentOneFormPropertyEditor) public constructor Create(Hook: TPropertyEditorHook; APropCount: Integer); override; end; { TComponentPropertyEditor The default editor for TComponents. It allows the user to set the value of this property to point to a component in any form in the project that is type compatible with the property being edited. } TComponentPropertyEditor = class(TPersistentPropertyEditor) protected function GetComponentReference: TComponent; virtual; public function AllEqual: Boolean; override; end; { TInterfacePropertyEditor The default editor for interface references. It allows the user to set the value of this property to refer to an interface implemented by a component on the form (or via form linking) that is type compatible with the property being edited. } TInterfacePropertyEditor = class(TComponentPropertyEditor) private protected function GetComponent(const AInterface: IInterface): TComponent; function GetComponentReference: TComponent; override; function GetSelections: TPersistentSelectionList; override; public function AllEqual: Boolean; override; procedure Edit; override; function GetAttributes: TPropertyAttributes; override; procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const NewValue: string); override; function GetValue: AnsiString; override; end; { TNoteBookActiveControlPropertyEditor } TNoteBookActiveControlPropertyEditor = class(TComponentPropertyEditor) protected function CheckNewValue(APersistent: TPersistent): boolean; override; public function GetAttributes: TPropertyAttributes; override; procedure GetValues(Proc: TGetStrProc); override; end; { TPagesPropertyEditor PropertyEditor editor for the TNoteBook.Pages properties. Brings up a dialog with a Memo for entering pages. } TPagesPropEditorDlg = class; TPagesPropertyEditor = class(TClassPropertyEditor) public procedure AssignItems(OldItmes, NewItems: TStrings); procedure Edit; override; function CreateDlg(s: TStrings): TPagesPropEditorDlg; virtual; function GetAttributes: TPropertyAttributes; override; end; { TRecordPropertyEditor } TRecordPropertyEditor = class(TStructurePropertyEditor) private FCanReadFields: boolean; FCanWriteFields: boolean; FHideRecordName: Boolean; protected FRecordData: PByte; // depending on FRecordRead this points to a temp mem or the instance FReadAccess, FWriteAccess: Byte; // see ptField..ptConst procedure LoadRecord; virtual; procedure GetRecordData(const aMethod: TMethod; WithIndex: boolean; Index: Longint); virtual; public constructor Create(Hook: TPropertyEditorHook; APropCount: Integer); override; destructor Destroy; override; function AllEqual: Boolean; override; function GetAttributes: TPropertyAttributes; override; procedure GetProperties(Proc: TGetPropEditProc); override; function GetValue: string; override; procedure Initialize; override; function ValueIsStreamed: boolean; override; property HideRecordName: Boolean read FHideRecordName write FHideRecordName; property CanReadFields: boolean read FCanReadFields; property CanWriteFields: boolean read FCanWriteFields; end; { TMethodPropertyEditor Property editor for all method properties. } TMethodPropertyEditor = class(TPropertyEditor) private function GetTrimmedEventName: shortstring; public function AllEqual: Boolean; override; procedure Edit; override; procedure ShowValue; override; function GetAttributes: TPropertyAttributes; override; function GetEditLimit: Integer; override; function GetValue: ansistring; override; procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const NewValue: ansistring); override; function GetFormMethodName: shortstring; class function GetDefaultMethodName(Root, Component: TComponent; const RootClassName, ComponentName, PropName: shortstring): shortstring; end; { TComponentNamePropertyEditor Property editor for the Name property. It restricts the name property from being displayed when more than one component is selected. } TComponentNamePropertyEditor = class(TStringPropertyEditor) public function GetAttributes: TPropertyAttributes; override; function GetEditLimit: Integer; override; function GetValue: ansistring; override; procedure SetValue(const NewValue: ansistring); override; end; { TDatePropertyEditor Property editor for date portion of TDateTime type. } TDatePropertyEditor = class(TPropertyEditor) public function GetAttributes: TPropertyAttributes; override; function GetValue: string; override; procedure SetValue(const Value: string); override; end; { TTimePropertyEditor Property editor for time portion of TDateTime type. } TTimePropertyEditor = class(TPropertyEditor) public function GetAttributes: TPropertyAttributes; override; function GetValue: string; override; procedure SetValue(const Value: string); override; end; { TDateTimePropertyEditor Edits both date and time data simultaneously } TDateTimePropertyEditor = class(TPropertyEditor) public function GetAttributes: TPropertyAttributes; override; function GetValue: string; override; procedure SetValue(const Value: string); override; end; { TVariantPropertyEditor } TVariantPropertyEditor = class(TPropertyEditor) public function GetAttributes: TPropertyAttributes; override; function GetValue: string; override; procedure SetValue(const {%H-}Value: string); override; procedure GetProperties({%H-}Proc:TGetPropEditProc); override; end; { TModalResultPropertyEditor } TModalResultPropertyEditor = class(TIntegerPropertyEditor) public function GetAttributes: TPropertyAttributes; override; function OrdValueToVisualValue(OrdValue: longint): string; override; procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const NewValue:ansistring); override; end; { TShortCutPropertyEditor Property editor the ShortCut property. Allows both typing in a short cut value or picking a short-cut value from a list. } TShortCutPropertyEditor = class(TOrdinalPropertyEditor) public procedure Edit; override; function GetAttributes: TPropertyAttributes; override; function OrdValueToVisualValue(OrdValue: longint): string; override; procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const Value: string); override; end; { TTabOrderPropertyEditor Property editor for the TabOrder property. Prevents the property from being displayed when more than one component is selected. } TTabOrderPropertyEditor = class(TIntegerPropertyEditor) public function GetAttributes: TPropertyAttributes; override; end; { TCaptionPropertyEditor Property editor for the Caption and Text properties. Updates the value of the property for each change instead on when the property is approved. } TCaptionPropertyEditor = class(TStringPropertyEditor) public function GetAttributes: TPropertyAttributes; override; end; { TMenuItemCaptionEditor MenuItem's Caption gets its own editor. It updates the MenuItem's name when it is turned into a separator. } TMenuItemCaptionEditor = class(TStringPropertyEditor) public procedure SetValue(const NewValue: ansistring); override; end; { TStringMultilinePropertyEditor PropertyEditor editor for a string property when the string can be multiline (e.g. TLabel.Caption, TControl.Hint). Brings up the dialog for entering text. } TStringMultilinePropertyEditor = class(TCaptionPropertyEditor) public procedure Edit; override; function GetAttributes: TPropertyAttributes; override; end; { TStringsPropertyEditor PropertyEditor editor for the TStrings properties. Brings up a dialog with a Memo for entering text. } TStringsPropEditorDlg = class; TStringsPropertyEditor = class(TClassPropertyEditor) public procedure Edit; override; function CreateDlg(s: TStrings): TStringsPropEditorDlg; virtual; function GetAttributes: TPropertyAttributes; override; end; { TValueListPropertyEditor PropertyEditor editor for the TStrings property of TValueListEditor. Brings up a dialog with a ValueListEditor for entering keys and values. } TKeyValPropEditorDlg = class; TValueListPropertyEditor = class(TClassPropertyEditor) public procedure Edit; override; function CreateDlg(s: TStrings): TKeyValPropEditorDlg; virtual; function GetAttributes: TPropertyAttributes; override; end; { TCursorPropertyEditor PropertyEditor editor for the TCursor properties. Displays cursor as constant name if exists, otherwise an integer. } TCursorPropertyEditor = class(TIntegerPropertyEditor) public function GetAttributes: TPropertyAttributes; override; function OrdValueToVisualValue(OrdValue: longint): string; override; procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const NewValue: ansistring); override; end; { TFileNamePropertyEditor PropertyEditor editor for filename properties. Show an TOpenDialog on Edit. } TFileNamePropertyEditor = class(TStringPropertyEditor) public function GetAttributes: TPropertyAttributes; override; procedure Edit; override; function GetFilter: String; virtual; function GetDialogOptions: TOpenOptions; virtual; function GetDialogTitle: string; virtual; function GetInitialDirectory: string; virtual; procedure SetFilename(const Filename: string); virtual; function CreateFileDialog: TOpenDialog; virtual; end; { TDirectoryPropertyEditor PropertyEditor editor for directory properties. Show an TSelectDirectoryDialog on Edit. } TDirectoryPropertyEditor = class(TFileNamePropertyEditor) public function CreateFileDialog: TOpenDialog; override; end; { TURLPropertyEditor PropertyEditor editor for URL properties. Show an TOpenDialog on Edit. } TURLPropertyEditor = class(TFileNamePropertyEditor) public procedure SetFilename(const Filename: string); override; end; { TURLDirectoryPropertyEditor PropertyEditor editor for URL properties. Show an TOpenDialog on Edit. } TURLDirectoryPropertyEditor = class(TURLPropertyEditor) public function CreateFileDialog: TOpenDialog; override; end; { TFileDlgFilterProperty PropertyEditor editor for TFileDialog filter properties. Show a dialog on Edit. } TFileDlgFilterProperty = class(TStringPropertyEditor) public function GetAttributes: TPropertyAttributes; override; procedure Edit; override; end; { TSessionPropertiesPropertyEditor PropertyEditor editor for TControl.SessionProperties properties. Show a dialog on Edit. } TSessionPropertiesPropertyEditor = class(TStringPropertyEditor) public function GetAttributes: TPropertyAttributes; override; procedure Edit; override; end; { TConstraintsPropertyEditor PropertyEditor editor for TControl.Constraints properties. Lets a user set the current size as constraints. } TConstraintsPropertyEditor = class(TClassPropertyEditor) public // These are used for the popup menu in OI function GetVerbCount: Integer; override; function GetVerb(Index: Integer): string; override; procedure PrepareItem(Index: Integer; const AnItem: TMenuItem); override; procedure ExecuteVerb(Index: Integer); override; end; { TListElementPropertyEditor A property editor for a single element of a TListPropertyEditor This editor simply redirects all methods to the TListPropertyEditor } TListPropertyEditor = class; TListElementPropertyEditor = class(TNestedPropertyEditor) private FIndex: integer; FList: TListPropertyEditor; public constructor Create(Parent: TListPropertyEditor; AnIndex: integer); overload; destructor Destroy; override; function GetAttributes: TPropertyAttributes; override; function GetName:shortstring; override; procedure GetProperties(Proc: TGetPropEditProc); override; function GetValue: ansistring; override; procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const NewValue: ansistring); override; property List: TListPropertyEditor read FList; property TheIndex: integer read FIndex; end; { TListPropertyEditor A property editor with dynamic sub properties representing a list of objects. The items are shown embedded in the OI and if the user presses the Edit button as extra window to select items, which are then shown in the OI. UNDER CONSTRUCTION by Mattias The problem with all properties is, that we don't get notified, when something changes. In this case, the list can change, which means the property editors for the list elements must be deleted or created. } TListPropertyEditor = class(TPropertyEditor) private FSaveElementLock: integer; FSubPropertiesChanged: boolean; protected procedure BeginSaveElement; procedure EndSaveElement; function IsSaving: boolean; property SaveElementLock: integer read FSaveElementLock; protected // methods and variables usable for descendent property editors: // MWE: hmm... don't like "public" objects // TODO: change this ? SavedList: TObject; SavedElements: TList; SavedPropertyEditors: TList; function ReadElementCount: integer; virtual; function ReadElement(Index: integer): TPersistent; virtual; function CreateElementPropEditor( Index: integer): TListElementPropertyEditor; virtual; procedure DoSaveElements; virtual; procedure FreeElementPropertyEditors; virtual; function GetElementAttributes( {%H-}Element: TListElementPropertyEditor): TPropertyAttributes; virtual; function GetElementName( {%H-}Element: TListElementPropertyEditor):shortstring; virtual; procedure GetElementProperties({%H-}Element: TListElementPropertyEditor; {%H-}Proc: TGetPropEditProc); virtual; function GetElementValue( {%H-}Element: TListElementPropertyEditor): ansistring; virtual; procedure GetElementValues({%H-}Element: TListElementPropertyEditor; {%H-}Proc: TGetStrProc); virtual; procedure SetElementValue({%H-}Element: TListElementPropertyEditor; {%H-}NewValue: ansistring); virtual; public constructor Create(Hook:TPropertyEditorHook; APropCount:Integer); override; destructor Destroy; override; function GetAttributes: TPropertyAttributes; override; function GetElementCount: integer; function GetElement(Index: integer): TPersistent; function GetElement(Element: TListElementPropertyEditor): TPersistent; function GetElementPropEditor(Index: integer): TListElementPropertyEditor; procedure GetProperties(Proc: TGetPropEditProc); override; function GetValue: AnsiString; override; procedure Initialize; override; procedure SaveElements; function SubPropertiesNeedsUpdate: boolean; override; end; { TCollectionPropertyEditor Default property editor for all TCollections, embedded in the OI UNDER CONSTRUCTION by Mattias} TCollectionPropertyEditor = class(TListPropertyEditor) private protected function ReadElementCount: integer; override; function ReadElement(Index: integer): TPersistent; override; function GetElementAttributes( {%H-}Element: TListElementPropertyEditor): TPropertyAttributes; override; function GetElementName( Element: TListElementPropertyEditor):shortstring; override; procedure GetElementProperties(Element: TListElementPropertyEditor; Proc: TGetPropEditProc); override; function GetElementValue( Element: TListElementPropertyEditor): ansistring; override; procedure GetElementValues(Element: TListElementPropertyEditor; Proc: TGetStrProc); override; procedure SetElementValue(Element: TListElementPropertyEditor; NewValue: ansistring); override; public function GetAttributes: TPropertyAttributes; override; procedure Edit; override; class function ShowCollectionEditor(ACollection: TCollection; OwnerPersistent: TPersistent; const PropName: String): TCustomForm; virtual; end; { TDisabledCollectionPropertyEditor } TDisabledCollectionPropertyEditor = class(TCollectionPropertyEditor) public function GetAttributes: TPropertyAttributes; override; end; { TNoAddDeleteCollectionPropertyEditor } TNoAddDeleteCollectionPropertyEditor = class(TCollectionPropertyEditor) public class function ShowCollectionEditor(ACollection: TCollection; OwnerPersistent: TPersistent; const PropName: String): TCustomForm; override; end; //============================================================================== // Delphi Compatible Property Editor Classnames type TOrdinalProperty = TOrdinalPropertyEditor; TIntegerProperty = TIntegerPropertyEditor; TCharProperty = TCharPropertyEditor; TEnumProperty = TEnumPropertyEditor; TBoolProperty = TBoolPropertyEditor; TInt64Property = TInt64PropertyEditor; TFloatProperty = TFloatPropertyEditor; TStringProperty = TStringPropertyEditor; TNestedProperty = TNestedPropertyEditor; TSetElementProperty = TSetElementPropertyEditor; TSetProperty = TSetPropertyEditor; TClassProperty = TClassPropertyEditor; TMethodProperty = TMethodPropertyEditor; TComponentProperty = TPersistentPropertyEditor; TComponentNameProperty = TComponentNamePropertyEditor; // TImeNameProperty = TImeNamePropertyEditor; TCursorProperty = TCursorPropertyEditor; TModalResultProperty = TModalResultPropertyEditor; TShortCutProperty = TShortCutPropertyEditor; // TMPFilenameProperty = TMPFilenamePropertyEditor; TTabOrderProperty = TTabOrderPropertyEditor; TCaptionProperty = TCaptionPropertyEditor; TDateProperty = TDatePropertyEditor; TTimeProperty = TTimePropertyEditor; TDateTimeProperty = TDateTimePropertyEditor; type TSelectionEditorAttribute = ( seaFilterProperties ); TSelectionEditorAttributes = set of TSelectionEditorAttribute; { TBaseSelectionEditor } TBaseSelectionEditor = class constructor Create({%H-}ADesigner: TIDesigner; {%H-}AHook: TPropertyEditorHook); virtual; function GetAttributes: TSelectionEditorAttributes; virtual; abstract; procedure FilterProperties(ASelection: TPersistentSelectionList; AProperties: TPropertyEditorList); virtual; abstract; end; TSelectionEditorClass = class of TBaseSelectionEditor; TSelectionEditorClassList = specialize TFPGList; { TSelectionEditor } TSelectionEditor = class(TBaseSelectionEditor) private FDesigner: TIDesigner; FHook: TPropertyEditorHook; public constructor Create(ADesigner: TIDesigner; AHook: TPropertyEditorHook); override; function GetAttributes: TSelectionEditorAttributes; override; procedure FilterProperties({%H-}ASelection: TPersistentSelectionList; {%H-}AProperties: TPropertyEditorList); override; property Designer: TIDesigner read FDesigner; property Hook: TPropertyEditorHook read FHook; end; //============================================================================== { RegisterPropertyEditor Registers a new property editor for the given type. When a component is selected the Object Inspector will create a property editor for each of the component's properties. The property editor is created based on the type of the property. If, for example, the property type is an Integer, the property editor for Integer will be created (by default that would be TIntegerPropertyEditor). Most properties do not need specialized property editors. For example, if the property is an ordinal type the default property editor will restrict the range to the ordinal subtype range (e.g. a property of type TMyRange=1..10 will only allow values between 1 and 10 to be entered into the property). Enumerated types will display a drop-down list of all the enumerated values (e.g. TShapes = (sCircle,sSquare,sTriangle) will be edited by a drop-down list containing only sCircle,sSquare and sTriangle). A property editor needs only be created if default property editor or none of the existing property editors are sufficient to edit the property. This is typically because the property is an object. The registered types are looked up newest to oldest. This allows an existing property editor replaced by a custom property editor. PropertyEditorType The type information pointer returned by the TypeInfo built-in function (e.g. TypeInfo(TMyRange) or TypeInfo(TShapes)). PersistentClass Type of the persistent object to which to restrict this type editor. This parameter can be left nil which will mean this type editor applies to all properties of PropertyEditorType. PropertyEditorName The name of the property to which to restrict this type editor. This parameter is ignored if PersistentClass is nil. This parameter can be an empty string ('') which will mean that this editor applies to all properties of PropertyEditorType in PersistentClass. editorClass The class of the editor to be created whenever a property of the type passed in PropertyEditorTypeInfo is displayed in the Object Inspector. The class will be created by calling EditorClass.Create. } procedure RegisterPropertyEditor(PropertyType: PTypeInfo; PersistentClass: TClass; const PropertyName: shortstring; EditorClass: TPropertyEditorClass); type TPropertyEditorMapperFunc=function(Obj: TPersistent; PropInfo: PPropInfo): TPropertyEditorClass; const AllTypeKinds = [tkInteger..High(TTypeKind)]; procedure RegisterPropertyEditorMapper(Mapper:TPropertyEditorMapperFunc); type TPropertyEditorFilterFunc = function(const ATestEditor: TPropertyEditor): Boolean of object; TPropInfoFilterFunc = function(const APropInfo: PPropInfo): Boolean of object; procedure GetPersistentProperties(ASelection: TPersistentSelectionList; AFilter: TTypeKinds; AHook: TPropertyEditorHook; AProc: TGetPropEditProc; APropInfoFilterFunc: TPropInfoFilterFunc; AEditorFilterFunc: TPropertyEditorFilterFunc {$IFDEF HasExtRtti};ExtVisibility: TVisibilityClasses = []{$ENDIF}); procedure GetPersistentProperties(ASelection: TPersistentSelectionList; AFilter: TTypeKinds; AHook: TPropertyEditorHook; AProc: TGetPropEditProc; AEditorFilterFunc: TPropertyEditorFilterFunc); procedure GetPersistentProperties(AItem: TPersistent; AFilter: TTypeKinds; AHook: TPropertyEditorHook; AProc: TGetPropEditProc; AEditorFilterFunc: TPropertyEditorFilterFunc); function GetEditorClass(PropInfo: PPropInfo; Obj: TPersistent): TPropertyEditorClass; function GetEditorClass(PropName: shortstring; Info: PTypeInfo; Obj: TPersistent): TPropertyEditorClass; //============================================================================== procedure RegisterSelectionEditor(AComponentClass: TComponentClass; AEditorClass: TSelectionEditorClass); procedure GetSelectionEditorClasses(AComponent: TComponent; AEditorList: TSelectionEditorClassList); procedure GetSelectionEditorClasses(ASelection: TPersistentSelectionList; AEditorList: TSelectionEditorClassList); //============================================================================== procedure RegisterListPropertyEditor(AnEditor: TListPropertyEditor); procedure UnregisterListPropertyEditor(AnEditor: TListPropertyEditor); procedure UpdateListPropertyEditors(AnObject: TObject); type TSelectableComponentFlag = ( scfWithoutRoot, scfWithoutInlineChilds ); TSelectableComponentFlags = set of TSelectableComponentFlag; procedure GetSelectableComponents(Root: TComponent; Flags: TSelectableComponentFlags; var ComponentList: TFPList); //============================================================================== { TPropertyEditorHook This is the interface for methods, components and objects handling of all property editors. Just create such thing and give it the object inspector. } type // lookup root TPropHookChangeLookupRoot = procedure of object; // methods TPropHookCreateMethod = function(const Name: ShortString; ATypeInfo: PTypeInfo; APersistent: TPersistent; const APropertyPath: string): TMethod of object; TPropHookGetMethodName = function(const Method: TMethod; CheckOwner: TObject; OrigLookupRoot: TPersistent): String of object; TPropHookGetCompatibleMethods = procedure(InstProp: PInstProp; const Proc: TGetStrProc) of object; TPropHookGetMethods = procedure(TypeData: PTypeData; Proc: TGetStrProc) of object; TPropHookCompatibleMethodExists = function(const Name: String; InstProp: PInstProp; var MethodIsCompatible,MethodIsPublished,IdentIsMethod: boolean ):boolean of object; TPropHookMethodExists = function(const Name: String; TypeData: PTypeData; var MethodIsCompatible,MethodIsPublished,IdentIsMethod: boolean ):boolean of object; TPropHookRenameMethod = procedure(const CurName, NewName: String) of object; TPropHookShowMethod = procedure(const Name: String) of object; TPropHookMethodFromAncestor = function(const Method:TMethod):boolean of object; TPropHookMethodFromLookupRoot = function(const Method:TMethod):boolean of object; TPropHookChainCall = procedure(const AMethodName, InstanceName, InstanceMethod:ShortString; TypeData:PTypeData) of object; // components TPropHookGetComponent = function(const ComponentPath: String):TComponent of object; TPropHookGetComponentName = function(AComponent: TComponent):String of object; TPropHookGetComponentNames = procedure(TypeData: PTypeData; Proc: TGetStrProc) of object; TPropHookGetRootClassName = function:ShortString of object; TPropHookGetAncestorInstProp = function(const InstProp: TInstProp; out AncestorInstProp: TInstProp): boolean of object; TPropHookAddClicked = function(ADesigner: TIDesigner; MouseDownComponent: TComponent; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; var AComponentClass: TComponentClass; var NewParent: TComponent): boolean of object; TPropHookBeforeAddPersistent = function(Sender: TObject; APersistentClass: TPersistentClass; Parent: TPersistent): boolean of object; TPropHookComponentRenamed = procedure(AComponent: TComponent) of object; TPropHookPersistentAdded = procedure(APersistent: TPersistent; Select: boolean ) of object; TPropHookPersistentDel = procedure(APersistent: TPersistent) of object; TPropHookDeletePersistent = procedure(var APersistent: TPersistent) of object; TPropHookGetSelection = procedure(const ASelection: TPersistentSelectionList ) of object; TPropHookSetSelection = procedure(const ASelection: TPersistentSelectionList ) of object; TPropHookAddDependency = procedure(const AClass: TClass; const AnUnitName: shortstring) of object; // persistent objects TPropHookGetObject = function(const Name:ShortString):TPersistent of object; TPropHookGetObjectName = function(Instance:TPersistent):ShortString of object; TPropHookGetObjectNames = procedure(TypeData:PTypeData; Proc: TGetStrProc) of object; TPropHookObjectPropertyChanged = procedure(Sender: TObject; NewObject: TPersistent) of object; // modifing TPropHookModified = procedure(Sender: TObject) of object; TPropHookModifiedWithName = procedure(Sender: TObject; PropName: ShortString) of object; TPropHookRevert = procedure(Instance:TPersistent; PropInfo:PPropInfo) of object; TPropHookRefreshPropertyValues = procedure of object; // other TPropHookGetCheckboxForBoolean = procedure(var Value: Boolean) of object; TPropHookType = ( // lookup root htChangeLookupRoot, // methods htCreateMethod, htGetMethodName, htGetCompatibleMethods, htGetMethods, htCompatibleMethodExists, htMethodExists, htRenameMethod, htShowMethod, htMethodFromAncestor, htMethodFromLookupRoot, htChainCall, // components htGetComponent, htGetComponentName, htGetComponentNames, htGetRootClassName, htGetAncestorInstProp, htAddClicked, // user selected a component class and clicked on a form to add a component htComponentRenamed, // persistent selection htBeforeAddPersistent, htPersistentAdded, htPersistentDeleting, htPersistentDeleted, htDeletePersistent, htGetSelectedPersistents, htSetSelectedPersistents, // persistent objects htGetObject, htGetObjectName, htGetObjectNames, htObjectPropertyChanged, // modifing htModified, htModifiedWithName, htRevert, htRefreshPropertyValues, // dependencies htAddDependency, // designer htDesignerMouseDown, htDesignerMouseUp, // other htGetCheckboxForBoolean ); { TPropertyEditorHook } TPropertyEditorHook = class(TComponent) private FComponentPropertyOnlyDesign: boolean; FHandlers: array[TPropHookType] of TMethodList; // lookup root FLookupRoot: TPersistent; procedure SetLookupRoot(APersistent: TPersistent); procedure AddHandler(HookType: TPropHookType; const Handler: TMethod); procedure RemoveHandler(HookType: TPropHookType; const Handler: TMethod); function GetHandlerCount(HookType: TPropHookType): integer; function GetNextHandlerIndex(HookType: TPropHookType; var i: integer): boolean; protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; public GetPrivateDirectory: AnsiString; destructor Destroy; override; // lookup root property LookupRoot: TPersistent read FLookupRoot write SetLookupRoot; // methods function CreateMethod(const aName: ShortString; ATypeInfo:PTypeInfo; APersistent: TPersistent; const APropertyPath: string): TMethod; function GetMethodName(const Method: TMethod; PropOwner: TObject): String; procedure GetMethods(TypeData: PTypeData; const Proc: TGetStrProc); procedure GetCompatibleMethods(InstProp: PInstProp; const Proc: TGetStrProc); function MethodExists(const aName: String; TypeData: PTypeData; var MethodIsCompatible,MethodIsPublished,IdentIsMethod: boolean):boolean; function CompatibleMethodExists(const aName: String; InstProp: PInstProp; out MethodIsCompatible,MethodIsPublished,IdentIsMethod: boolean):boolean; procedure RenameMethod(const CurName, NewName: String); procedure ShowMethod(const aName: String); function MethodFromAncestor(const Method: TMethod): boolean; function MethodFromLookupRoot(const Method: TMethod): boolean; procedure ChainCall(const AMethodName, InstanceName, InstanceMethod: ShortString; TypeData: PTypeData); // components function GetComponent(const ComponentPath: string): TComponent; function GetComponentName(AComponent: TComponent): String; procedure GetComponentNames(TypeData: PTypeData; const Proc: TGetStrProc); function GetRootClassName: ShortString; function GetAncestorInstance(const InstProp: TInstProp; out AncestorInstProp: TInstProp): boolean; function AddClicked(ADesigner: TIDesigner; MouseDownComponent: TComponent; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; var AComponentClass: TComponentClass; var NewParent: TComponent): boolean; function BeforeAddPersistent(Sender: TObject; APersistentClass: TPersistentClass; Parent: TPersistent): boolean; procedure ComponentRenamed(AComponent: TComponent); procedure PersistentAdded(APersistent: TPersistent; Select: boolean); procedure PersistentDeleting(APersistent: TPersistent); procedure PersistentDeleted(APersistent: TPersistent); procedure DeletePersistent(var APersistent: TPersistent); procedure GetSelection(const ASelection: TPersistentSelectionList); procedure SetSelection(const ASelection: TPersistentSelectionList); procedure Unselect(const APersistent: TPersistent); function IsSelected(const APersistent: TPersistent): boolean; procedure SelectOnlyThis(const APersistent: TPersistent); procedure DesignerMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure DesignerMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); // persistent objects function GetObject(const aName: ShortString): TPersistent; function GetObjectName(Instance: TPersistent; AOwnerComp: TComponent): String; procedure GetObjectNames(TypeData: PTypeData; const Proc: TGetStrProc); procedure ObjectReferenceChanged(Sender: TObject; NewObject: TPersistent); // modifing procedure Modified(Sender: TObject; PropName: ShortString = ''); procedure Revert(Instance: TPersistent; PropInfo: PPropInfo); procedure RefreshPropertyValues; property ComponentPropertyOnlyDesign: boolean read FComponentPropertyOnlyDesign write FComponentPropertyOnlyDesign; // dependencies procedure AddDependency(const AClass: TClass; const AnUnitname: shortstring); // other function GetCheckboxForBoolean: Boolean; public // Handlers procedure RemoveAllHandlersForObject(const HandlerObject: TObject); // lookup root procedure AddHandlerChangeLookupRoot( const OnChangeLookupRoot: TPropHookChangeLookupRoot); procedure RemoveHandlerChangeLookupRoot( const OnChangeLookupRoot: TPropHookChangeLookupRoot); // method events procedure AddHandlerCreateMethod(const OnCreateMethod: TPropHookCreateMethod); procedure RemoveHandlerCreateMethod(const OnCreateMethod: TPropHookCreateMethod); procedure AddHandlerGetMethodName(const OnGetMethodName: TPropHookGetMethodName); procedure RemoveHandlerGetMethodName(const OnGetMethodName: TPropHookGetMethodName); procedure AddHandlerGetCompatibleMethods( const OnGetMethods: TPropHookGetCompatibleMethods); procedure RemoveHandlerGetCompatibleMethods( const OnGetMethods: TPropHookGetCompatibleMethods); procedure AddHandlerGetMethods(const OnGetMethods: TPropHookGetMethods); procedure RemoveHandlerGetMethods(const OnGetMethods: TPropHookGetMethods); procedure AddHandlerCompatibleMethodExists( const OnMethodExists: TPropHookCompatibleMethodExists); procedure RemoveHandlerCompatibleMethodExists( const OnMethodExists: TPropHookCompatibleMethodExists); procedure AddHandlerMethodExists(const OnMethodExists: TPropHookMethodExists); procedure RemoveHandlerMethodExists(const OnMethodExists: TPropHookMethodExists); procedure AddHandlerRenameMethod(const OnRenameMethod: TPropHookRenameMethod); procedure RemoveHandlerRenameMethod(const OnRenameMethod: TPropHookRenameMethod); procedure AddHandlerShowMethod(const OnShowMethod: TPropHookShowMethod); procedure RemoveHandlerShowMethod(const OnShowMethod: TPropHookShowMethod); procedure AddHandlerMethodFromAncestor( const OnMethodFromAncestor: TPropHookMethodFromAncestor); procedure RemoveHandlerMethodFromAncestor( const OnMethodFromAncestor: TPropHookMethodFromAncestor); procedure AddHandlerMethodFromLookupRoot( const OnMethodFromLookupRoot: TPropHookMethodFromLookupRoot); procedure RemoveHandlerMethodFromLookupRoot( const OnMethodFromLookupRoot: TPropHookMethodFromLookupRoot); procedure AddHandlerChainCall(const OnChainCall: TPropHookChainCall); procedure RemoveHandlerChainCall(const OnChainCall: TPropHookChainCall); // component event procedure AddHandlerGetComponent(const OnGetComponent: TPropHookGetComponent); procedure RemoveHandlerGetComponent(const OnGetComponent: TPropHookGetComponent); procedure AddHandlerGetComponentName( const OnGetComponentName: TPropHookGetComponentName); procedure RemoveHandlerGetComponentName( const OnGetComponentName: TPropHookGetComponentName); procedure AddHandlerGetComponentNames( const OnGetComponentNames: TPropHookGetComponentNames); procedure RemoveHandlerGetComponentNames( const OnGetComponentNames: TPropHookGetComponentNames); procedure AddHandlerAddClicked(const Handler: TPropHookAddClicked); procedure RemoveHandlerAddClicked(const Handler: TPropHookAddClicked); procedure AddHandlerGetRootClassName( const OnGetRootClassName: TPropHookGetRootClassName); procedure RemoveHandlerGetRootClassName( const OnGetRootClassName: TPropHookGetRootClassName); procedure AddHandlerGetAncestorInstProp( const OnGetAncestorInstProp: TPropHookGetAncestorInstProp); procedure RemoveHandlerGetAncestorInstProp( const OnGetAncestorInstProp: TPropHookGetAncestorInstProp); procedure AddHandlerDesignerMouseDown(const OnMouseDown: TMouseEvent); procedure RemoveHandlerDesignerMouseDown(const OnMouseDown: TMouseEvent); procedure AddHandlerDesignerMouseUp(const OnMouseUp: TMouseEvent); procedure RemoveHandlerDesignerMouseUp(const OnMouseUp: TMouseEvent); // component create, delete, rename procedure AddHandlerComponentRenamed( const OnComponentRenamed: TPropHookComponentRenamed); procedure RemoveHandlerComponentRenamed( const OnComponentRenamed: TPropHookComponentRenamed); procedure AddHandlerBeforeAddPersistent( const OnBeforeAddPersistent: TPropHookBeforeAddPersistent); procedure RemoveHandlerBeforeAddPersistent( const OnBeforeAddPersistent: TPropHookBeforeAddPersistent); procedure AddHandlerPersistentAdded( const OnPersistentAdded: TPropHookPersistentAdded); procedure RemoveHandlerPersistentAdded( const OnPersistentAdded: TPropHookPersistentAdded); procedure AddHandlerPersistentDeleting( const OnPersistentDeleting: TPropHookPersistentDel); procedure RemoveHandlerPersistentDeleting( const OnPersistentDeleting: TPropHookPersistentDel); procedure AddHandlerPersistentDeleted( const OnPersistentDeleted: TPropHookPersistentDel); procedure RemoveHandlerPersistentDeleted( const OnPersistentDeleted: TPropHookPersistentDel); procedure AddHandlerDeletePersistent( const OnDeletePersistent: TPropHookDeletePersistent); procedure RemoveHandlerDeletePersistent( const OnDeletePersistent: TPropHookDeletePersistent); // persistent selection procedure AddHandlerGetSelection(const OnGetSelection: TPropHookGetSelection); procedure RemoveHandlerGetSelection(const OnGetSelection: TPropHookGetSelection); procedure AddHandlerSetSelection(const OnSetSelection: TPropHookSetSelection); procedure RemoveHandlerSetSelection(const OnSetSelection: TPropHookSetSelection); // persistent object events procedure AddHandlerGetObject(const OnGetObject: TPropHookGetObject); procedure RemoveHandlerGetObject(const OnGetObject: TPropHookGetObject); procedure AddHandlerGetObjectName(const OnGetObjectName: TPropHookGetObjectName); procedure RemoveHandlerGetObjectName(const OnGetObjectName: TPropHookGetObjectName); procedure AddHandlerGetObjectNames(const OnGetObjectNames: TPropHookGetObjectNames); procedure RemoveHandlerGetObjectNames(const OnGetObjectNames: TPropHookGetObjectNames); procedure AddHandlerObjectPropertyChanged( const OnObjectPropertyChanged: TPropHookObjectPropertyChanged); procedure RemoveHandlerObjectPropertyChanged( const OnObjectPropertyChanged: TPropHookObjectPropertyChanged); // modifing events procedure AddHandlerModified(const OnModified: TPropHookModified); procedure RemoveHandlerModified(const OnModified: TPropHookModified); procedure AddHandlerModifiedWithName(const OnModified: TPropHookModifiedWithName); procedure RemoveHandlerModifiedWithName(const OnModified: TPropHookModifiedWithName); procedure AddHandlerRevert(const OnRevert: TPropHookRevert); procedure RemoveHandlerRevert(const OnRevert: TPropHookRevert); procedure AddHandlerRefreshPropertyValues( const OnRefreshPropertyValues: TPropHookRefreshPropertyValues); procedure RemoveHandlerRefreshPropertyValues( const OnRefreshPropertyValues: TPropHookRefreshPropertyValues); procedure AddHandlerAddDependency(const OnAddDependency: TPropHookAddDependency); procedure RemoveHandlerAddDependency(const OnAddDependency: TPropHookAddDependency); procedure AddHandlerGetCheckboxForBoolean( const OnGetCheckboxForBoolean: TPropHookGetCheckboxForBoolean); end; //============================================================================== { TPropInfoList } type TPropInfoList = class private FList: PPropList; FCount: Integer; {$IFDEF HasExtRtti} FExtVisibility: TVisibilityClasses; FListExt: PPropListEx; function GetExt(Index: Integer): PPropInfoEx; {$ENDIF} function Get(Index: Integer): PPropInfo; public constructor Create(Instance: TPersistent; Filter: TTypeKinds); {$IFDEF HasExtRtti} constructor Create(Instance: TPersistent; Filter: TTypeKinds; AddExtVisibility: TVisibilityClasses); {$ENDIF} destructor Destroy; override; function Contains(P: PPropInfo): Boolean; procedure Delete(Index: Integer); procedure Intersect(List: TPropInfoList); procedure Sort; property Count: Integer read FCount; property Items[Index: Integer]: PPropInfo read Get; default; {$IFDEF HasExtRtti} property ExtVisibility: TVisibilityClasses read FExtVisibility; property Ext[Index: Integer]: PPropInfoEx read GetExt; {$ENDIF} end; //============================================================================== type TStringsPropEditorDlg = class(TStringsPropEditorFrm) public Editor: TPropertyEditor; end; TKeyValPropEditorDlg = class(TKeyValPropEditorFrm) public Editor: TPropertyEditor; end; TPagesPropEditorDlg = class(TPagesPropEditorFrm) public Editor: TPropertyEditor; end; { TCustomShortCutGrabBox } TCustomShortCutGrabBox = class(TCustomPanel) private FAllowedShifts: TShiftState; FGrabButton: TButton; FMainOkButton: TCustomButton; FKey: Word; FKeyComboBox: TComboBox; FShiftButtons: TShiftState; FShiftState: TShiftState; FCheckBoxes: array[TShiftStateEnum] of TCheckBox; FGrabForm: TForm; function GetKey: Word; function GetShiftCheckBox(Shift: TShiftStateEnum): TCheckBox; procedure SetAllowedShifts(const AValue: TShiftState); procedure SetKey(const AValue: Word); procedure SetShiftButtons(const AValue: TShiftState); procedure SetShiftState(const AValue: TShiftState); // Event handlers procedure GrabButtonClick(Sender: TObject); procedure ShiftCheckBoxClick(Sender: TObject); procedure GrabFormKeyDown(Sender: TObject; var AKey: Word; AShift: TShiftState); procedure KeyComboboxEditingDone(Sender: TObject); protected procedure Loaded; override; procedure RealSetText(const {%H-}Value: TCaption); override; procedure UpdateShiftButtons; procedure Notification(AComponent: TComponent; Operation: TOperation); override; function ShiftToStr(s: TShiftStateEnum): string; public constructor Create(TheOwner: TComponent); override; function GetDefaultShiftButtons: TShiftState; property ShiftState: TShiftState read FShiftState write SetShiftState; property Key: Word read GetKey write SetKey; property ShiftButtons: TShiftState read FShiftButtons write SetShiftButtons; property AllowedShifts: TShiftState read FAllowedShifts write SetAllowedShifts; property KeyComboBox: TComboBox read FKeyComboBox; property GrabButton: TButton read FGrabButton; property MainOkButton: TCustomButton read FMainOkButton write FMainOkButton; property ShiftCheckBox[Shift: TShiftStateEnum]: TCheckBox read GetShiftCheckBox; end; { TShortCutGrabBox } TShortCutGrabBox = class(TCustomShortCutGrabBox) published property Align; property Alignment; property AllowedShifts; property Anchors; property AutoSize; property BevelInner; property BevelOuter; property BevelWidth; property BorderSpacing; property BorderStyle; property BorderWidth; property Caption; property ChildSizing; property ClientHeight; property ClientWidth; property Color; property Constraints; property DockSite; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property FullRepaint; property Key; property OnClick; property OnDblClick; property OnDockDrop; property OnDockOver; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnGetDockCaption; property OnGetSiteInfo; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnResize; property OnStartDock; property OnStartDrag; property OnUnDock; property ParentColor; property ParentFont; property ParentShowHint; property PopupMenu; property ShiftButtons; property ShiftState; property ShowHint; property TabOrder; property TabStop; property UseDockManager default True; property Visible; end; //============================================================================== // Global flags: var GReferenceExpandable: Boolean = true; GShowReadOnlyProps: Boolean = true; // default Hook - set by IDE var GlobalDesignHook: TPropertyEditorHook; function ClassTypeInfo(Value: TClass): PTypeInfo; function GetClassUnitName(Value: TClass): string; procedure CreateComponentEvent(AComponent: TComponent; const EventName: string); function ClassNameToComponentName(const AClassName: string): string; function ControlAcceptsStreamableChildComponent(aControl: TWinControl; aComponentClass: TComponentClass; aLookupRoot: TPersistent): boolean; procedure LazSetMethodProp(Instance : TObject;PropInfo : PPropInfo; Value : TMethod); procedure WritePublishedProperties(Instance: TPersistent); procedure EditCollection(AComponent: TComponent; ACollection: TCollection; APropName: String); procedure EditCollectionNoAddDel(AComponent: TComponent; ACollection: TCollection; APropName: String); // Returns true if given property should be displayed on the property list // filtered by AFilter and APropNameFilter. function IsInteresting(AEditor: TPropertyEditor; const AFilter: TTypeKinds; const APropNameFilter: String): Boolean; function GetOrdField(Field: Pointer; FieldInfo: PTypeInfo): Int64; overload; procedure SetOrdField(Field: Pointer; FieldInfo: PTypeInfo; Value: Int64); overload; function GetEnumField(Field: Pointer; FieldInfo: PTypeInfo): String; overload; procedure SetEnumField(Field: Pointer; FieldInfo: PTypeInfo; const Value: string); overload; function GetSetField(Field: Pointer; FieldInfo: PTypeInfo; Brackets: Boolean): String; overload; procedure SetSetField(Field: Pointer; FieldInfo: PTypeInfo; const Value: string); overload; function GetStringField(Field: Pointer; FieldInfo: PTypeInfo): String; overload; procedure SetStringField(Field: Pointer; FieldInfo: PTypeInfo; const Value: string); overload; function GetWideStringField(Field: Pointer; FieldInfo: PTypeInfo): WideString; overload; procedure SetWideStringField(Field: Pointer; FieldInfo: PTypeInfo; const Value: WideString); overload; function GetUnicodeStringField(Field: Pointer; FieldInfo: PTypeInfo): UnicodeString; overload; procedure SetUnicodeStringField(Field: Pointer; FieldInfo: PTypeInfo; const Value: UnicodeString); overload; function GetRawbyteStringField(Field: Pointer; FieldInfo: PTypeInfo): RawByteString; overload; procedure SetRawbyteStringField(Field: Pointer; FieldInfo: PTypeInfo; const Value: RawByteString); overload; function GetFloatField(Field: Pointer; FieldInfo: PTypeInfo): Extended; overload; procedure SetFloatField(Field: Pointer; FieldInfo: PTypeInfo; const Value: Extended); overload; function GetObjectField(Field: Pointer; FieldInfo: PTypeInfo; MinClass: TClass = nil): TObject; overload; procedure SetObjectField(Field: Pointer; FieldInfo: PTypeInfo; const Value: TObject); overload; function GetPointerField(Field: Pointer; FieldInfo: PTypeInfo): Pointer; overload; procedure SetPointerField(Field: Pointer; FieldInfo: PTypeInfo; const Value: Pointer); overload; function GetMethodField(Field: Pointer; FieldInfo: PTypeInfo): TMethod; overload; procedure SetMethodField(Field: Pointer; FieldInfo: PTypeInfo; const Value: TMethod); overload; function GetInterfaceField(Field: Pointer; FieldInfo: PTypeInfo): IInterface; overload; procedure SetInterfaceField(Field: Pointer; FieldInfo: PTypeInfo; const Value: IInterface); overload; function GetVariantField(Field: Pointer; FieldInfo: PTypeInfo): Variant; overload; procedure SetVariantField(Field: Pointer; FieldInfo: PTypeInfo; const Value: Variant); overload; Function GetPointerProp(Instance: TObject; PropInfo: PPropInfo): Pointer; overload; Procedure SetPointerProp(Instance: TObject; PropInfo: PPropInfo; Value: Pointer); overload; function dbgs(peh: TPropEditHint): string; overload; const NoDefaultValue = Longint($80000000); // magic number for properties with nodefault modifier implementation var ListPropertyEditors: TList = nil; VirtualKeyStrings: TStringHashList = nil; procedure RegisterListPropertyEditor(AnEditor: TListPropertyEditor); begin if ListPropertyEditors=nil then ListPropertyEditors:=TList.Create; ListPropertyEditors.Add(AnEditor); end; procedure UnregisterListPropertyEditor(AnEditor: TListPropertyEditor); begin if ListPropertyEditors=nil then exit; ListPropertyEditors.Remove(AnEditor); end; procedure UpdateListPropertyEditors(AnObject: TObject); var i: integer; Editor: TListPropertyEditor; begin if ListPropertyEditors=nil then exit; for i:=0 to ListPropertyEditors.Count-1 do begin Editor:=TListPropertyEditor(ListPropertyEditors[i]); if (Editor.GetComponent(0)=AnObject) and (Editor.OnSubPropertiesChanged<>nil) then Editor.UpdateSubProperties; end; end; type { TSelectableComponentEnumerator } TSelectableComponentEnumerator = class(TComponent) public List: TFPList; Flags: TSelectableComponentFlags; Root: TComponent; procedure GetSelectableComponents(ARoot: TComponent); procedure Gather(Child: TComponent); end; { TSelectionEditor } constructor TSelectionEditor.Create(ADesigner: TIDesigner; AHook: TPropertyEditorHook); begin inherited Create(ADesigner, AHook); FDesigner := ADesigner; FHook := AHook; end; function TSelectionEditor.GetAttributes: TSelectionEditorAttributes; begin Result := []; end; procedure TSelectionEditor.FilterProperties( ASelection: TPersistentSelectionList; AProperties: TPropertyEditorList); begin end; { TBaseSelectionEditor } constructor TBaseSelectionEditor.Create(ADesigner: TIDesigner; AHook: TPropertyEditorHook); begin end; { TPagesPropertyEditor } procedure TPagesPropertyEditor.AssignItems(OldItmes, NewItems: TStrings); var Unchanged, Index, PageIndex: Integer; DummyNotebook: TNotebook; APage: TPage; PageComponent: TPersistent; NoteBook: TNoteBook; begin // search for unchanged pages Unchanged := 0; while (Unchanged < NewItems.Count) and (Unchanged < OldItmes.Count) and (NewItems.Objects[Unchanged] = OldItmes.Objects[Unchanged]) and (NewItems[Unchanged] = TPage(OldItmes.Objects[Unchanged]).Name) do Inc(Unchanged); if (Unchanged = OldItmes.Count) and (Unchanged = NewItems.Count) then Exit; NoteBook := TNotebook(FOwnerComponent); DummyNotebook := TNotebook.Create(nil); try // move all unused/changed pages to dummy for Index := OldItmes.Count - 1 downto Unchanged do begin APage := TPage(OldItmes.Objects[Index]); APage.Parent := DummyNotebook; end; // add NewItems or changed pages to notebook for Index := Unchanged to NewItems.Count - 1 do begin if Assigned(NewItems.Objects[Index]) then begin APage := TPage(NewItems.Objects[Index]); end else begin PageIndex := NoteBook.Pages.Add(NewItems[Index]); APage := TPage(NoteBook.Pages.Objects[PageIndex]); end; APage.Parent := NoteBook; if IsValidIdent(NewItems[Index]) then APage.Name := NewItems[Index]; APage.Caption := NewItems[Index]; PropertyHook.PersistentAdded(APage, False); end; // delete all unused OldItmes pages for Index := DummyNotebook.PageCount - 1 downto 0 do begin APage := TPage(DummyNotebook.Pages.Objects[Index]); APage.Parent := nil;; DummyNotebook.Pages.Delete(Index); PageComponent := TPersistent(APage); PropertyHook.DeletePersistent(PageComponent); end; finally DummyNotebook.Free; end; end; procedure TPagesPropertyEditor.Edit; var TheDialog: TPagesPropEditorDlg; Old, New: TStrings; begin Old := TStrings(GetObjectValue); TheDialog := CreateDlg(Old); try if (TheDialog.ShowModal = mrOK) then begin New := TheDialog.ListBox.Items; AssignItems(Old, TheDialog.ListBox.Items); SetPtrValue(New); end; finally TheDialog.Free; end; end; function TPagesPropertyEditor.CreateDlg(s: TStrings): TPagesPropEditorDlg; begin Result := TPagesPropEditorDlg.Create(Application); Result.Editor := Self; Result.ListBox.Items.Assign(s); end; function TPagesPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paDialog, paRevertable, paReadOnly]; end; { TRecordPropertyEditor } procedure TRecordPropertyEditor.LoadRecord; var PropInfo: PPropInfo; Instance: TPersistent; AMethod: TMethod; begin if FRecordData=nil then raise EPropertyError.CreateFmt(SErrCannotReadProperty, [GetName]); PropInfo:=GetPropInfo; Instance:=FPropList^[0].Instance; if (PropInfo=nil) or (Instance=nil) then raise EPropertyError.CreateFmt(SErrCannotReadProperty, [GetName]); case (PropInfo^.PropProcs) and 3 of ptField: ; ptStatic, ptVirtual: begin if (PropInfo^.PropProcs and 3)=ptStatic then AMethod.Code:=PropInfo^.GetProc else AMethod.Code:=PCodePointer(Pointer(Instance.ClassType)+{%H-}PtrUInt(PropInfo^.GetProc))^; AMethod.Data:=Instance; if ((PropInfo^.PropProcs shr 6) and 1)<>0 then begin GetRecordData(AMethod,true,PropInfo^.Index); end else begin GetRecordData(AMethod,false,0); end; end; else raise EPropertyError.CreateFmt(SErrCannotReadProperty, [GetName]); end; end; procedure TRecordPropertyEditor.GetRecordData(const aMethod: TMethod; WithIndex: boolean; Index: Longint); begin raise EPropertyError.CreateFmt(SErrCannotReadProperty, [GetName]); if aMethod.Code<>nil then ; if WithIndex and (Index>=0) then ; end; constructor TRecordPropertyEditor.Create(Hook: TPropertyEditorHook; APropCount: Integer); begin inherited Create(Hook, APropCount); end; destructor TRecordPropertyEditor.Destroy; begin if FReadAccess in [ptStatic,ptVirtual] then ReAllocMem(FRecordData,0); inherited Destroy; end; function TRecordPropertyEditor.AllEqual: Boolean; begin Result:=True; // ToDo: Maybe all sub-properties should be compared for equality. end; function TRecordPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [{paMultiSelect, }paSubProperties, paReadOnly]; end; procedure TRecordPropertyEditor.GetProperties(Proc: TGetPropEditProc); {$IFDEF HasExtRtti} var PropInfo: PPropInfo; aTypeData: PTypeData; i: Integer; FieldTypeInfo: PTypeInfo; FieldCnt: LongInt; Editor: TPropertyEditor; Instance: TPersistent; FieldList: PExtendedFieldInfoTable; Field: PExtendedVmtFieldEntry; EdClass: TPropertyEditorClass; {$ENDIF} begin {$IFDEF HasExtRtti} Instance:=FPropList^[0].Instance; PropInfo:=GetPropInfo; if PropInfo=nil then exit; aTypeData:=GetTypeData(PropInfo^.PropType); FieldCnt:=GetFieldList(PropInfo^.PropType,FieldList,[vcPublic,vcPublished]); // create field editors if CanReadFields then begin if FRecordData=nil then case (PropInfo^.PropProcs) and 3 of ptField: // direct access FRecordData:=PByte(Instance)+{%H-}PtrUInt(PropInfo^.GetProc); else // local cache FRecordData:=AllocMem(aTypeData^.RecSize); end; for i:=0 to FieldCnt-1 do begin Field:=FieldList^[i]; FieldTypeInfo:=Field^.FieldType^; EdClass:=GetEditorClass('',FieldTypeInfo,nil); Editor := EdClass.Create(PropertyHook,1); Editor.SetRecordFieldEntry(0, PByte(FRecordData)+Field^.FieldOffset, Field^.Name, FieldTypeInfo); Editor.Initialize; if ((PropCount > 1) and not (paMultiSelect in Editor.GetAttributes)) or not Editor.ValueAvailable then begin Editor.Free; end else begin Proc(Editor); end; end; end; {$ELSE} if Proc<>nil then ; {$ENDIF} end; function TRecordPropertyEditor.GetValue: string; begin if FHideRecordName then Result:='' else Result:='(' + GetPropType^.Name + ')'; end; procedure TRecordPropertyEditor.Initialize; var PropInfo: PPropInfo; begin inherited Initialize; PropInfo:=GetPropInfo; if PropInfo=nil then exit; // check read and write access FReadAccess:=(PropInfo^.PropProcs) and 3; FCanReadFields:=FReadAccess in [ptField{,ptStatic,ptVirtual}]; FWriteAccess:=(PropInfo^.PropProcs shr 2) and 3; FCanWriteFields:=FWriteAccess=ptField; end; function TRecordPropertyEditor.ValueIsStreamed: boolean; begin Result:=false; end; { TSelectableComponentEnumerator } procedure TSelectableComponentEnumerator.GetSelectableComponents( ARoot: TComponent); begin Root:=ARoot; if List=nil then List:=TFPList.Create; if Root=nil then exit; if not (scfWithoutRoot in Flags) then List.Add(Root); TSelectableComponentEnumerator(Root).GetChildren(@Gather,Root); end; procedure TSelectableComponentEnumerator.Gather(Child: TComponent); var OldRoot: TComponent; begin if not ((Child is TControl) and (csNoDesignSelectable in TControl(Child).ControlStyle)) then List.Add(Child); OldRoot:=Root; try if csInline in Child.ComponentState then begin if scfWithoutInlineChilds in Flags then exit; if (Child is TControl) and (csOwnedChildrenNotSelectable in TControl(Child).ControlStyle) then exit; Root:=Child; end; TSelectableComponentEnumerator(Child).GetChildren(@Gather,Root); finally Root:=OldRoot; end; end; procedure GetSelectableComponents(Root: TComponent; Flags: TSelectableComponentFlags; var ComponentList: TFPList); var e: TSelectableComponentEnumerator; begin e:=TSelectableComponentEnumerator.Create(nil); try e.List:=ComponentList; e.Flags:=Flags; e.GetSelectableComponents(Root); ComponentList:=e.List; finally e.Free; end; end; procedure LazSetMethodProp(Instance: TObject; PropInfo: PPropInfo; Value: TMethod); type PMethod = ^TMethod; TSetMethodProcIndex=procedure(index:longint;p:TMethod) of object; TSetMethodProc=procedure(p:TMethod) of object; var AMethod : TMethod; begin case (PropInfo^.PropProcs shr 2) and 3 of ptfield: PMethod(Pointer(Instance)+{%H-}PtrUInt(PropInfo^.SetProc))^ := Value; ptstatic, ptvirtual : begin if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then AMethod.Code:=PropInfo^.SetProc else AMethod.Code:=PPointer(Pointer(Instance.ClassType)+{%H-}PtrUInt(PropInfo^.SetProc))^; AMethod.Data:=Instance; if (Value.Code=nil) and (Value.Data<>nil) then begin // this is a fake method // Comparing fake methods with OldValue=NewValue results always in // true. Therefore this will fail: // if FMethod=NewValue then exit; // FMethod:=NewValue; // Change the method two times try Value.Code:=Pointer(1); if ((PropInfo^.PropProcs shr 6) and 1)<>0 then TSetMethodProcIndex(AMethod)(PropInfo^.Index,Value) else TSetMethodProc(AMethod)(Value); except end; Value.Code:=nil; end; if ((PropInfo^.PropProcs shr 6) and 1)<>0 then TSetMethodProcIndex(AMethod)(PropInfo^.Index,Value) else TSetMethodProc(AMethod)(Value); end; end; end; // ----------------------------------------------------------- procedure WritePublishedProperties(Instance: TPersistent); var TypeInfo: PTypeInfo; TypeData: PTypeData; PropInfo: PPropInfo; PropData: ^TPropData; CurCount: integer; begin TypeInfo:=Instance.ClassInfo; TypeData:=GetTypeData(TypeInfo); debugln('WritePublishedProperties Instance=',DbgS(Instance),' ',Instance.ClassName,' TypeData^.PropCount=',dbgs(TypeData^.PropCount)); if Instance is TComponent then debugln(' TComponent(Instance).Name=',TComponent(Instance).Name); // read all properties and remove doubles TypeInfo:=Instance.ClassInfo; repeat // read all property infos of current class TypeData:=GetTypeData(TypeInfo); // skip unitname PropData:=AlignToPtr(PByte(@TypeData^.UnitName)+Length(TypeData^.UnitName)+1); // read property count CurCount:=PWord(PropData)^; PropInfo:=PPropInfo(@PropData^.PropList); debugln(' UnitName=',TypeData^.UnitName,' Type=',TypeInfo^.Name,' CurPropCount=',dbgs(CurCount)); {writeln('TPropInfoList.Create D ',CurCount,' TypeData^.ClassType=',DbgS(TypeData^.ClassType)); writeln('TPropInfoList.Create E ClassName="',TypeData^.ClassType.ClassName,'"', ' TypeInfo=',DbgS(TypeInfo), ' TypeData^.ClassType.ClassInfo=',DbgS(TypeData^.ClassType.ClassInfo), ' TypeData^.ClassType.ClassParent=',DbgS(TypeData^.ClassType.ClassParent), ' TypeData^.ParentInfo=',DbgS(TypeData^.ParentInfo), ''); CurParent:=TypeData^.ClassType.ClassParent; if CurParent<>nil then begin writeln('TPropInfoList.Create F CurParent.ClassName=',CurParent.ClassName, ' CurParent.ClassInfo=',DbgS(CurParent.ClassInfo), ''); end;} // read properties while CurCount>0 do begin // point PropInfo to next propinfo record. // Located at Name[Length(Name)+1] ! debugln(' Property ',PropInfo^.Name,' Type=',PropInfo^.PropType^.Name); PropInfo:=PPropInfo(AlignToPtr(pointer(@PropInfo^.Name)+PByte(@PropInfo^.Name)^+1)); dec(CurCount); end; TypeInfo:=TypeData^.ParentInfo; if TypeInfo=nil then break; until false; end; //------------------------------------------------------------------------------ const { TypeKinds see typinfo.pp TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,tkFloat, tkSet,tkMethod,tkSString,tkLString,tkAString, tkWString,tkVariant,tkArray,tkRecord,tkInterface, tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord, tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar, tkHelper); } // default property editor classes PropClassMap:array[TypInfo.TTypeKind] of TPropertyEditorClass=( nil, // tkUnknown TIntegerPropertyEditor, // tkInteger TCharpropertyEditor, // tkChar TEnumPropertyEditor, // tkEnumeration TFloatPropertyEditor, // tkFloat TSetPropertyEditor, // tkSet TMethodPropertyEditor, // tkMethod TStringPropertyEditor, // tkSString TStringPropertyEditor, // tkLString TStringPropertyEditor, // tkAString TWideStringPropertyEditor, // tkWString TPropertyEditor, // tkVariant nil, // tkArray TRecordPropertyEditor, // tkRecord TInterfacePropertyEditor, // tkInterface TClassPropertyEditor, // tkClass nil, // tkObject TPropertyEditor, // tkWChar TBoolPropertyEditor, // tkBool TInt64PropertyEditor, // tkInt64 TQWordPropertyEditor, // tkQWord nil, // tkDynArray nil, // tkInterfaceRaw, nil, // tkProcVar TUnicodeStringPropertyEditor,// tkUString nil // tkUChar {$IF declared(tkHelper)} ,nil // tkHelper {$ENDIF} {$IF declared(tkFile)} ,nil // tkFile {$ENDIF} {$IF declared(tkClassRef)} ,nil // tkClassRef {$ENDIF} {$IF declared(tkPointer)} ,nil // tkPointer {$ENDIF} ); var PropertyEditorMapperList:TFPList; PropertyClassList:TFPList; SelectionEditorClassList:TFPList; type PPropertyClassRec=^TPropertyClassRec; TPropertyClassRec=record PropertyType:PTypeInfo; PropertyName:shortstring; PersistentClass:TClass; EditorClass:TPropertyEditorClass; end; PPropertyEditorMapperRec=^TPropertyEditorMapperRec; TPropertyEditorMapperRec=record Mapper:TPropertyEditorMapperFunc; end; PSelectionEditorClassRec=^TSelectionEditorClassRec; TSelectionEditorClassRec=record ComponentClass:TComponentClass; EditorClass:TSelectionEditorClass; end; { TPropInfoList } constructor TPropInfoList.Create(Instance:TPersistent; Filter:TTypeKinds); var ListCapacity: integer; procedure Add(PropInfo: PPropInfo{$IFDEF HasExtRtti}; Ext: PPropInfoEx{$ENDIF}); var i: Integer; begin if PropInfo^.PropType^.Kind in Filter then begin // check if name already exists in list i:=FCount-1; while (i>=0) and (CompareText(FList^[i]^.Name,PropInfo^.Name)<>0) do dec(i); if (i<0) then begin // add property info if FCount=ListCapacity then begin if ListCapacity<16 then ListCapacity:=16 else ListCapacity:=ListCapacity*2; ReAllocMem(FList,ListCapacity*SizeOf(Pointer)); {$IFDEF HasExtRtti} ReAllocMem(FListExt,ListCapacity*SizeOf(Pointer)); {$ENDIF} end; FList^[FCount]:=PropInfo; {$IFDEF HasExtRtti} FListExt^[FCount]:=Ext; {$ENDIF} inc(FCount); end; end; end; var aTypeInfo: PTypeInfo; TypeData: PTypeData; PropInfo: PPropInfo; PropData: ^TPropData; {$IFDEF HasExtRtti} PropList: PPropListEx; PropInfoEx: PPropInfoEx; {$ENDIF} CurCount: integer; //CurParent: TClass; begin aTypeInfo:=Instance.ClassInfo; // read all published properties and remove doubles TypeData:=GetTypeData(aTypeInfo); ListCapacity:=TypeData^.PropCount; ReAllocMem(FList,ListCapacity * SizeOf(Pointer)); {$IFDEF HASEXTRTTI} ReAllocMem(FListExt,ListCapacity * SizeOf(Pointer)); {$ENDIF} aTypeInfo:=Instance.ClassInfo; FCount:=0; repeat // read all property infos of current class TypeData:=GetTypeData(aTypeInfo); // skip unitname PropData:=AlignToPtr(Pointer(@TypeData^.UnitName)+Length(TypeData^.UnitName)+1); // read property count CurCount:=PropData^.PropCount; PropInfo:=PPropInfo(@PropData^.PropList); {writeln('TPropInfoList.Create D ',CurCount,' TypeData^.ClassType=',DbgS(TypeData^.ClassType)); writeln('TPropInfoList.Create E ClassName="',TypeData^.ClassType.ClassName,'"', ' TypeInfo=',DbgS(aTypeInfo), ' TypeData^.ClassType.ClassInfo=',DbgS(TypeData^.ClassType.ClassInfo), ' TypeData^.ClassType.ClassParent=',DbgS(TypeData^.ClassType.ClassParent), ' TypeData^.ParentInfo=',DbgS(TypeData^.ParentInfo), ''); CurParent:=TypeData^.ClassType.ClassParent; if CurParent<>nil then begin writeln('TPropInfoList.Create F CurParent.ClassName=',CurParent.ClassName, ' CurParent.ClassInfo=',DbgS(CurParent.ClassInfo), ''); end;} // read properties while CurCount>0 do begin Add(PropInfo{$IFDEF HasExtRtti},nil{$ENDIF}); // point PropInfo to next propinfo record. // Located at Name[Length(Name)+1] ! PropInfo:=PPropInfo(AlignToPtr(pointer(@PropInfo^.Name)+PByte(@PropInfo^.Name)^+1)); dec(CurCount); end; {$IFDEF HasExtRtti} if FExtVisibility<>[] then begin CurCount:=GetPropListEx(aTypeInfo,PropList,FExtVisibility); try while CurCount>0 do begin dec(CurCount); PropInfoEx:=PropList^[CurCount]; Add(PropInfoEx^.Info,PropInfoEx); end; finally Freemem(PropList); end; end; {$ENDIF} aTypeInfo:=TypeData^.ParentInfo; until aTypeInfo=nil; Sort; end; {$IFDEF HasExtRtti} constructor TPropInfoList.Create(Instance: TPersistent; Filter: TTypeKinds; AddExtVisibility: TVisibilityClasses); begin FExtVisibility:=AddExtVisibility; Create(Instance,Filter); end; {$ENDIF} destructor TPropInfoList.Destroy; begin if FList<>nil then FreeMem(FList); {$IFDEF HasExtRtti} if FListExt<>nil then FreeMem(FListExt); {$ENDIF HasExtRtti} end; function TPropInfoList.Contains(P:PPropInfo):Boolean; var I: Integer; begin for I := 0 to FCount - 1 do begin with FList^[I]^ do begin if (PropType^.Kind=P^.PropType^.Kind) and (CompareText(Name,P^.Name)=0) then begin Result := True; Exit; end; end; end; Result := False; end; procedure TPropInfoList.Delete(Index:Integer); begin Dec(FCount); if Index >= FCount then exit; System.Move(FList^[Index+1],FList^[Index],(FCount-Index) * SizeOf(Pointer)); {$IFDEF HasExtRtti} System.Move(FListExt^[Index+1],FListExt^[Index],(FCount-Index) * SizeOf(Pointer)); {$ENDIF} end; function TPropInfoList.Get(Index:Integer):PPropInfo; begin Result:=FList^[Index]; end; {$IFDEF HasExtRtti} function TPropInfoList.GetExt(Index: Integer): PPropInfoEx; begin Result:=FListExt^[Index]; end; {$ENDIF} procedure TPropInfoList.Intersect(List:TPropInfoList); var i:Integer; begin for i:=FCount-1 downto 0 do if not List.Contains(FList^[i]) then Delete(i); end; procedure TPropInfoList.Sort; procedure QuickSort(L, R: Integer); var i, j: Longint; p: PPropInfo; h: Pointer; begin repeat i := L; j := R; p := FList^[(L + R) div 2]; repeat while CompareText(p^.Name, FList^[i]^.Name) > 0 do inc(i); while CompareText(p^.Name, FList^[j]^.Name) < 0 do dec(j); if i <= j then begin h := FList^[i]; Flist^[i] := FList^[j]; FList^[j] := h; {$IFDEF HasExtRtti} h := FListExt^[i]; FListExt^[i] := FListExt^[j]; FListExt^[j] := h; {$ENDIF} inc(i); dec(j); end; until i > j; if L < j then QuickSort(L, j); L := i; until i >= R; end; begin if Count > 0 then QuickSort(0, Count - 1); end; //------------------------------------------------------------------------------ procedure RegisterSelectionEditor(AComponentClass: TComponentClass; AEditorClass: TSelectionEditorClass); var p:PSelectionEditorClassRec; begin if not Assigned(AComponentClass) or not Assigned(AEditorClass) then Exit; if not Assigned(SelectionEditorClassList) then SelectionEditorClassList:=TFPList.Create; New(p); p^.ComponentClass:=AComponentClass; p^.EditorClass:=AEditorClass; SelectionEditorClassList.Add(p); end; procedure GetSelectionEditorClasses(AComponent: TComponent; AEditorList: TSelectionEditorClassList); var i:LongInt; begin if not Assigned(AComponent) or not Assigned(AEditorList) then Exit; if not Assigned(SelectionEditorClassList) then Exit; for i:=0 to SelectionEditorClassList.Count-1 do begin with PSelectionEditorClassRec(SelectionEditorClassList[i])^ do begin if AComponent.InheritsFrom(ComponentClass) then AEditorList.Add(EditorClass); end; end; end; procedure GetSelectionEditorClasses(ASelection: TPersistentSelectionList; AEditorList: TSelectionEditorClassList); var tmp:TSelectionEditorClassList; i,j:LongInt; sel:TPersistent; begin if not Assigned(ASelection) or (ASelection.Count=0) or not Assigned(AEditorList) then Exit; tmp:=TSelectionEditorClassList.Create; try for i:=0 to ASelection.Count-1 do begin sel:=ASelection[i]; if not (sel is TComponent) then Continue; GetSelectionEditorClasses(TComponent(sel),tmp); { if there are no classes yet, we pick them as is, otherwise we remove all those from the existing list that are not part of the new list } if AEditorList.Count=0 then AEditorList.Assign(tmp) else begin for j:=AEditorList.Count-1 downto 0 do begin if tmp.IndexOf(AEditorList[j])<0 then AEditorList.Delete(j); end; end; tmp.Clear; end; finally tmp.Free; end; end; { GetComponentProperties } procedure RegisterPropertyEditor(PropertyType:PTypeInfo; PersistentClass: TClass; const PropertyName:shortstring; EditorClass:TPropertyEditorClass); var P:PPropertyClassRec; begin if PropertyType=nil then exit; if PropertyClassList=nil then PropertyClassList:=TFPList.Create; New(P); P^.PropertyType:=PropertyType; P^.PersistentClass:=PersistentClass; P^.PropertyName:=PropertyName; P^.EditorClass:=EditorClass; PropertyClassList.Insert(0,P); end; procedure RegisterPropertyEditorMapper(Mapper:TPropertyEditorMapperFunc); var P:PPropertyEditorMapperRec; begin if PropertyEditorMapperList=nil then PropertyEditorMapperList:=TFPList.Create; New(P); P^.Mapper:=Mapper; PropertyEditorMapperList.Insert(0,P); end; function GetEditorClass(PropInfo:PPropInfo; Obj:TPersistent): TPropertyEditorClass; var I: Integer; begin Result := nil; if PropertyEditorMapperList<>nil then begin for I:=0 to PropertyEditorMapperList.Count-1 do begin with PPropertyEditorMapperRec(PropertyEditorMapperList[I])^ do begin Result:=Mapper(Obj,PropInfo); if Result<>nil then break; end; end; end; Result:=GetEditorClass(PropInfo^.Name,PropInfo^.PropType,Obj); end; function GetEditorClass(PropName: shortstring; Info: PTypeInfo; Obj: TPersistent ): TPropertyEditorClass; var P, C: PPropertyClassRec; I: Integer; TypeData: PTypeData; begin Result := nil; I:=0; C:=nil; TypeData:=GetTypeData(Info); while I < PropertyClassList.Count do begin P:=PropertyClassList[I]; if ((P^.PropertyType=Info) or ((P^.PropertyType^.Kind=Info^.Kind) and (P^.PropertyType^.Name=Info^.Name) ) ) or ( (Info^.Kind=tkClass) and (P^.PropertyType^.Kind=tkClass) and TypeData^.ClassType.InheritsFrom( GetTypeData(P^.PropertyType)^.ClassType) ) then if ((P^.PersistentClass=nil) or ((Obj<>nil) and (Obj.InheritsFrom(P^.PersistentClass)))) and ((P^.PropertyName='') or (CompareText(P^.PropertyName,PropName)=0)) then if (C=nil) or // see if P is better match than C ((C^.PersistentClass=nil) and (P^.PersistentClass<>nil)) or ((C^.PropertyName='') and (P^.PropertyName<>'')) or // P's proptype match is exact,but C's does not ((C^.PropertyType<>Info) and (P^.PropertyType=Info)) or // P's proptype is more specific than C's proptype ((P^.PropertyType<>C^.PropertyType) and (P^.PropertyType^.Kind=tkClass) and (C^.PropertyType^.Kind=tkClass) and GetTypeData(P^.PropertyType)^.ClassType.InheritsFrom( GetTypeData(C^.PropertyType)^.ClassType)) or // P's component class is more specific than C's component class ((P^.PersistentClass<>nil) and (C^.PersistentClass<>nil) and (P^.PersistentClass<>C^.PersistentClass) and (P^.PersistentClass.InheritsFrom(C^.PersistentClass))) then C:=P; Inc(I); end; if C<>nil then Result:=C^.EditorClass else begin if (Info^.Kind<>tkClass) or (TypeData^.ClassType.InheritsFrom(TPersistent)) or (TypeData^.PropCount > 0) then Result:=PropClassMap[Info^.Kind] else Result:=nil; end; if (Result<>nil) and Result.InheritsFrom(THiddenPropertyEditor) then Result:=nil; end; procedure GetPersistentProperties(ASelection: TPersistentSelectionList; AFilter: TTypeKinds; AHook: TPropertyEditorHook; AProc: TGetPropEditProc; APropInfoFilterFunc: TPropInfoFilterFunc; AEditorFilterFunc: TPropertyEditorFilterFunc {$IFDEF HasExtRtti};ExtVisibility: TVisibilityClasses = []{$ENDIF}); var I, J, SelCount: Integer; ClassTyp: TClass; Candidates: TPropInfoList; PropLists: TFPList; PropEditor: TPropertyEditor; PropEditorList: TPropertyEditorList; SelEditor: TBaseSelectionEditor; SelEditorList: TSelectionEditorClassList; EdClass: TPropertyEditorClass; PropInfo: PPropInfo; AddEditor: Boolean; Instance: TPersistent; Designer: TIDesigner; begin if (ASelection = nil) or (ASelection.Count = 0) then Exit; SelCount := ASelection.Count; Instance := ASelection[0]; ClassTyp := Instance.ClassType; // Create a property candidate list of all properties that can be found in // every component in the list and in the Filter Candidates := TPropInfoList.Create(Instance, AFilter{$IFDEF HasExtRtti},ExtVisibility{$ENDIF}); try // check each property candidate for I := Candidates.Count - 1 downto 0 do begin PropInfo := Candidates[I]; // check if property is readable if (PropInfo^.GetProc=nil) or ((not GShowReadOnlyProps) and (PropInfo^.PropType^.Kind <> tkClass) and (PropInfo^.SetProc = nil)) or (Assigned(APropInfoFilterFunc) and (not APropInfoFilterFunc(PropInfo))) then begin Candidates.Delete(I); Continue; end; EdClass := GetEditorClass(PropInfo, Instance); if EdClass = nil then begin Candidates.Delete(I); Continue; end; // create a test property editor for the property PropEditor := EdClass.Create(AHook,1); PropEditor.SetPropEntry(0, Instance, PropInfo); PropEditor.Initialize; // check for multiselection, ValueAvailable and customfilter if ((SelCount > 1) and not (paMultiSelect in PropEditor.GetAttributes)) or not PropEditor.ValueAvailable or (Assigned(AEditorFilterFunc) and not AEditorFilterFunc(PropEditor)) then Candidates.Delete(I); PropEditor.Free; end; PropEditorList := TPropertyEditorList.Create(True); try PropLists := TFPList.Create; try PropLists.Count := SelCount; // Create a property info list for each component in the selection for I := 0 to SelCount - 1 do PropLists[i] := TPropInfoList.Create(ASelection[I], AFilter{$IFDEF HasExtRtti},ExtVisibility{$ENDIF}); // Eliminate each property in Candidates that is not in all property lists for I := 0 to SelCount - 1 do Candidates.Intersect(TPropInfoList(PropLists[I])); // Eliminate each property in the property list that are not in Candidates for I := 0 to SelCount - 1 do TPropInfoList(PropLists[I]).Intersect(Candidates); // PropList now has a matrix of PropInfo's. // -> create a property editor for each property for I := 0 to Candidates.Count - 1 do begin EdClass := GetEditorClass(Candidates[I], Instance); if EdClass = nil then Continue; PropEditor := EdClass.Create(AHook, SelCount); AddEditor := True; for J := 0 to SelCount - 1 do begin if (ASelection[J].ClassType <> ClassTyp) and (GetEditorClass(TPropInfoList(PropLists[J])[I], ASelection[J])<>EdClass) then begin AddEditor := False; Break; end; PropEditor.SetPropEntry(J, ASelection[J], TPropInfoList(PropLists[J])[I]); end; if AddEditor then begin PropEditor.Initialize; if not PropEditor.ValueAvailable then AddEditor:=false; end; if AddEditor then PropEditorList.Add(PropEditor) else PropEditor.Free; end; finally for I := 0 to PropLists.Count - 1 do TPropInfoList(PropLists[I]).Free; PropLists.Free; end; SelEditorList := TSelectionEditorClassList.Create; try GetSelectionEditorClasses(ASelection, SelEditorList); { is it safe to assume that the whole selection has the same designer? } Designer := FindRootDesigner(ASelection[0]); for I := 0 to SelEditorList.Count - 1 do begin SelEditor := SelEditorList[I].Create(Designer, AHook); try if seaFilterProperties in SelEditor.GetAttributes then SelEditor.FilterProperties(ASelection, PropEditorList); finally SelEditor.Free; end; end; finally SelEditorList.Free; end; { no longer free the editors } PropEditorList.FreeObjects := False; for I := 0 to PropEditorList.Count - 1 do AProc(PropEditorList[I]); finally PropEditorList.Free; end; finally Candidates.Free; end; end; procedure GetPersistentProperties(ASelection: TPersistentSelectionList; AFilter: TTypeKinds; AHook: TPropertyEditorHook; AProc: TGetPropEditProc; AEditorFilterFunc: TPropertyEditorFilterFunc); begin GetPersistentProperties(ASelection,AFilter,AHook,AProc,nil,AEditorFilterFunc); end; procedure GetPersistentProperties(AItem: TPersistent; AFilter: TTypeKinds; AHook: TPropertyEditorHook; AProc: TGetPropEditProc; AEditorFilterFunc: TPropertyEditorFilterFunc); var Selection: TPersistentSelectionList; begin if AItem = nil then Exit; Selection := TPersistentSelectionList.Create; try Selection.Add(AItem); GetPersistentProperties(Selection,AFilter,AHook,AProc,AEditorFilterFunc); finally Selection.Free; end; end; { TPropertyEditor } constructor TPropertyEditor.Create(Hook: TPropertyEditorHook; APropCount:Integer); var PropListSize: Integer; begin FPropertyHook:=Hook; PropListSize:=APropCount * SizeOf(TInstProp); GetMem(FPropList,PropListSize); FillByte(FPropList^,PropListSize,0); FPropCount:=APropCount; end; destructor TPropertyEditor.Destroy; begin if FPropList<>nil then FreeMem(FPropList,FPropCount * SizeOf(TInstProp)); end; procedure TPropertyEditor.Activate; begin // end; procedure TPropertyEditor.Deactivate; begin // end; function TPropertyEditor.AllEqual:Boolean; begin Result:=FPropCount=1; end; procedure TPropertyEditor.Edit; type TGetStrFunc = function(const StrValue:ansistring):Integer of object; var I:Integer; Values: TStringList; AddValue: TGetStrFunc; begin if not AutoFill then Exit; Values:=TStringList.Create; Values.UseLocale := False; Values.Sorted:=paSortList in GetAttributes; try AddValue := @Values.Add; GetValues(TGetStrProc((@AddValue)^)); if Values.Count > 0 then begin I:=Values.IndexOf(FirstValue)+1; if I=Values.Count then I:=0; FirstValue:=Values[I]; end; finally Values.Free; end; end; procedure TPropertyEditor.Edit(AOwnerComponent: TComponent); begin FOwnerComponent := AOwnerComponent; Edit; FOwnerComponent := Nil; end; procedure TPropertyEditor.ShowValue; begin end; function TPropertyEditor.AutoFill:Boolean; begin Result:=paValueList in GetAttributes; end; function TPropertyEditor.CallStoredFunction: Boolean; begin with FPropList^[0] do begin if PropInfo=nil then exit(false); Result := (Instance <> nil) and IsStoredProp(Instance, PropInfo); end; end; {$IFDEF UseOINormalCheckBox} function TPropertyEditor.DrawCheckbox(ACanvas: TCanvas; const ARect: TRect; IsTrue: Boolean): TRect; // Draws a Checkbox using theme services for editing booleans. // Returns the output rectangle adjusted for new text location. var Details: TThemedElementDetails; Check: TThemedButton; BRect: TRect; Sz: TSize; TopMargin: Integer; VisVal: String; begin VisVal := GetVisualValue; // Draw the box using theme services. if (VisVal = '') or (VisVal = oisMixed) then Check := tbCheckBoxMixedNormal else if IsTrue then Check := tbCheckBoxCheckedNormal else Check := tbCheckBoxUncheckedNormal; Details := ThemeServices.GetElementDetails(Check); Sz := TCustomCheckBoxThemed.GetCheckBoxSize(ScreenInfo.PixelsPerInchX); TopMargin := (ARect.Bottom - ARect.Top - Sz.cy) div 2; BRect := ARect; // Left varies by widgetset and theme etc. Real Checkbox itself has a left margin. Inc(BRect.Left, 3); // ToDo: How to find out the real margin? Result := BRect; // Result Rect will be used for text. Inc(BRect.Top, TopMargin); BRect.Right := BRect.Left + Sz.cx; BRect.Bottom := BRect.Top + Sz.cy; ThemeServices.DrawElement(ACanvas.Handle, Details, BRect, nil); // Text will be written after the box. Inc(Result.Left, Sz.cx + 4); end; {$ENDIF} function TPropertyEditor.DrawCheckValue(ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState; IsTrue: Boolean): TRect; // Draws Boolean value as text or Checkbox depending on user setting from PropertyHook. // Uses either theme services (func DrawCheckbox) or TCheckBoxThemed depending // on UseOINormalCheckBox define. // Returns Rect for textual part if it must be drawn, otherwise Result.Top = -100. {$IFnDEF UseOINormalCheckBox} var BRect: TRect; VisVal: string; stat: TCheckBoxState; {$ENDIF} begin Result.Top := 0; if FPropertyHook.GetCheckboxForBoolean then begin // Checkbox for Booleans. {$IFnDEF UseOINormalCheckBox} Result.Top := -100; // No need to call PropDrawValue further. BRect := ARect; Inc(BRect.Left, CheckBoxThemedLeftOffs); VisVal := GetVisualValue; if (VisVal = '') or (VisVal = oisMixed) then stat := cbGrayed else if VisVal = '(True)' then stat := cbChecked else stat := cbUnchecked; TCheckBoxThemed.PaintSelf(ACanvas, VisVal, BRect, stat, False, False, False, False, taRightJustify); {$ELSE} Result := DrawCheckbox(ACanvas, ARect, IsTrue); {$ENDIF} end else Result := ARect; // Classic Combobox for Booleans. end; function TPropertyEditor.GetAttributes: TPropertyAttributes; begin Result:=[paMultiSelect,paRevertable]; end; function TPropertyEditor.IsReadOnly: boolean; begin Result:=paReadOnly in GetAttributes; end; function TPropertyEditor.GetComponent(Index: Integer): TPersistent; begin Result:=FPropList^[Index].Instance; end; function TPropertyEditor.GetUnitName(Index: Integer): string; begin Result:=GetClassUnitName(GetComponent(Index).ClassType); end; function TPropertyEditor.GetPropTypeUnitName(Index: Integer): string; type PPropData = ^TPropData; var aPersistent: TPersistent; CurPropInfo: PPropInfo; hp: PTypeData; pd: PPropData; i: Integer; UpperName: ShortString; ATypeInfo: PTypeInfo; NameFound: Boolean; ThePropType: PTypeInfo; begin Result:=''; aPersistent:=GetComponent(Index); UpperName:=UpCase(GetName); ThePropType:=GetPropType; ATypeInfo:=PTypeInfo(aPersistent.ClassInfo); while Assigned(ATypeInfo) do begin // skip the name hp:=GetTypeData(ATypeInfo); // the class info rtti the property rtti follows immediatly pd:=AlignToPtr(Pointer(Pointer(@hp^.UnitName)+Length(hp^.UnitName)+1)); CurPropInfo:=PPropInfo(@pd^.PropList); NameFound:=false; for i:=1 to pd^.PropCount do begin // found a property of that name ? if Upcase(CurPropInfo^.Name)=UpperName then begin DebugLn(['TPropertyEditor.GetPropTypeUnitName ',hp^.UnitName,' IsSamePropInfo=',CurPropInfo^.PropType=ThePropType]); NameFound:=true; if CurPropInfo^.PropType=ThePropType then Result:=hp^.UnitName; end; // skip to next property CurPropInfo:=PPropInfo(AlignToPtr(Pointer(@CurPropInfo^.Name)+Byte(CurPropInfo^.Name[0])+1)); end; if not NameFound then break; // parent class ATypeInfo:=hp^.ParentInfo; end; end; function TPropertyEditor.GetPropertyPath(Index: integer): string; begin Result:=GetComponent(Index).ClassName+'.'+GetName; end; function TPropertyEditor.GetFloatValue:Extended; begin Result:=GetFloatValueAt(0); end; procedure SetIndexValues(P: PPropInfo; var Index, IValue : Longint); begin Index:=((P^.PropProcs shr 6) and 1); if Index<>0 then IValue:=P^.Index else IValue:=0; end; function TPropertyEditor.GetFloatValueAt(Index:Integer):Extended; begin Result:=FPropList^[Index].GetFloat; end; function TPropertyEditor.GetMethodValue:TMethod; begin Result:=GetMethodValueAt(0); end; // workaround for buggy rtl function function LazGetMethodProp(Instance: TObject; PropInfo: PPropInfo): TMethod; type TGetMethodProcIndex=function(Index: Longint): TMethod of object; TGetMethodProc=function(): TMethod of object; PMethod = ^TMethod; var value: PMethod; AMethod : TMethod; begin Result.Code:=nil; Result.Data:=nil; case (PropInfo^.PropProcs) and 3 of ptfield: begin Value:=PMethod(Pointer(Instance)+{%H-}PtrUInt(PropInfo^.GetProc)); if Value<>nil then Result:=Value^; end; ptstatic, ptvirtual : begin if (PropInfo^.PropProcs and 3)=ptStatic then AMethod.Code:=PropInfo^.GetProc else AMethod.Code:=PPointer(Pointer(Instance.ClassType) +{%H-}PtrUInt(PropInfo^.GetProc))^; AMethod.Data:=Instance; if ((PropInfo^.PropProcs shr 6) and 1)<>0 then Result:=TGetMethodProcIndex(AMethod)(PropInfo^.Index) else Result:=TGetMethodProc(AMethod)(); end; end; end; function TPropertyEditor.GetMethodValueAt(Index: Integer):TMethod; begin Result:=FPropList^[Index].GetMethod; end; function TPropertyEditor.GetEditLimit: Integer; begin Result := 255; end; function TPropertyEditor.GetName: shortstring; begin with FPropList^[0] do begin if PropInfo<>nil then Result:=PropInfo^.Name else if FieldName<>nil then Result:=FieldName^ else Result:=''; end; end; function TPropertyEditor.GetOrdValue: Longint; begin Result:=GetOrdValueAt(0); end; function TPropertyEditor.GetOrdValueAt(Index: Integer): Longint; begin Result:=FPropList^[Index].GetOrd; end; function TPropertyEditor.GetObjectValue: TObject; begin Result:=GetObjectValueAt(0); end; function TPropertyEditor.GetObjectValue(MinClass: TClass): TObject; begin Result:=GetObjectValueAt(0, MinClass); end; function TPropertyEditor.GetObjectValueAt(Index: Integer): TObject; begin Result:=FPropList^[Index].GetObject; end; function TPropertyEditor.GetObjectValueAt(Index: Integer; MinClass: TClass): TObject; begin Result:=FPropList^[Index].GetObject(MinClass); end; function TPropertyEditor.GetDefaultOrdValue: Longint; var APropInfo: PPropInfo; begin APropInfo:=FPropList^[0].PropInfo; if APropInfo<>nil then Result:=APropInfo^.Default else Result:=0; end; function TPropertyEditor.GetSetValue(Brackets: boolean): AnsiString; begin Result:=FPropList^[0].GetSet(Brackets); end; function TPropertyEditor.GetSetValueAt(Index: Integer; Brackets: boolean): AnsiString; begin Result:=FPropList^[Index].GetSet(Brackets); end; function TPropertyEditor.GetPrivateDirectory:ansistring; begin Result:=''; if PropertyHook<>nil then Result:=PropertyHook.GetPrivateDirectory; end; procedure TPropertyEditor.DrawValue(const AValue: string; ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState); var Style : TTextStyle; begin FillChar(Style{%H-},SizeOf(Style),0); With Style do begin Alignment := taLeftJustify; Layout := tlCenter; Opaque := False; Clipping := True; ShowPrefix := False; WordBreak := False; SingleLine := True; ExpandTabs := True; SystemFont := False; end; ACanvas.TextRect(ARect,ARect.Left+3,ARect.Top,AValue, Style); end; procedure TPropertyEditor.GetProperties(Proc:TGetPropEditProc); begin end; function TPropertyEditor.GetPropInfo: PPropInfo; begin Result:=FPropList^[0].PropInfo; end; function TPropertyEditor.GetInstProp: PInstProp; begin Result:=@FPropList^[0]; end; function TPropertyEditor.GetEnumValueAt(Index: Integer): string; begin Result:=FPropList^[Index].GetEnum; end; function TPropertyEditor.GetPropType: PTypeInfo; begin with FPropList^[0] do begin if FieldTypeInfo<>nil then Result:=FieldTypeInfo else Result:=PropInfo^.PropType; end; end; function TPropertyEditor.GetStrValue: AnsiString; begin Result:=GetStrValueAt(0); end; function TPropertyEditor.GetStrValueAt(Index:Integer): AnsiString; begin Result:=FPropList^[Index].GetString; end; function TPropertyEditor.GetVarValue: Variant; begin Result:=GetVarValueAt(0); end; function TPropertyEditor.GetVarValueAt(Index:Integer): Variant; begin Result:=FPropList^[Index].GetVariant; end; function TPropertyEditor.GetWideStrValue: WideString; begin Result:=GetWideStrValueAt(0); end; function TPropertyEditor.GetWideStrValueAt(Index: Integer): WideString; begin Result:=FPropList^[Index].GetWideString; end; function TPropertyEditor.HasDefaultValue: Boolean; var APropInfo: PPropInfo; begin APropInfo:=FPropList^[0].PropInfo; if APropInfo=nil then exit(true); Result := APropInfo^.Default<>NoDefaultValue; end; function TPropertyEditor.GetUnicodeStrValue: UnicodeString; begin Result:=GetUnicodeStrValueAt(0); end; function TPropertyEditor.GetUnicodeStrValueAt(Index: Integer): UnicodeString; begin Result:=FPropList^[Index].GetUnicodeString; end; function TPropertyEditor.GetValue:ansistring; begin Result:=oisUnknown; end; function TPropertyEditor.GetHint(HintType: TPropEditHint; x, y: integer): string; var TypeHint: String; begin Result := GetName + LineEnding + oisValue + ' ' + GetVisualValue; case GetPropType^.Kind of tkInteger : TypeHint:=oisInteger; tkInt64 : TypeHint:=oisInt64; tkBool : TypeHint:=oisBoolean; tkEnumeration : TypeHint:=oisEnumeration; tkChar, tkWChar : TypeHint:=oisChar; tkUnknown : TypeHint:=oisUnknown; tkObject : TypeHint:=oisObject; tkClass : TypeHint:=oisClass; tkQWord : TypeHint:=oisWord; tkString, tkLString, tkAString, tkWString : TypeHint:=oisString; tkFloat : TypeHint:=oisFloat; tkSet : TypeHint:=oisSet; tkMethod : TypeHint:=oisMethod; tkVariant : TypeHint:=oisVariant; tkArray : TypeHint:=oisArray; tkRecord : TypeHint:=oisRecord; tkInterface : TypeHint:=oisInterface; else TypeHint:=''; end; if TypeHint<>'' then Result:=Result+LineEnding+TypeHint; end; function TPropertyEditor.GetDefaultValue: ansistring; begin if not HasDefaultValue then raise EPropertyError.Create('No property default available'); Result:=''; end; function TPropertyEditor.GetVisualValue: ansistring; begin if AllEqual then begin Result:=GetValue; {$IFDEF LCLCarbon} Result:=StringReplace(Result,LineEnding,LineFeedSymbolUTF8,[rfReplaceAll]) {$ENDIF} end else Result:=''; end; procedure TPropertyEditor.GetValues(Proc:TGetStrProc); begin end; procedure TPropertyEditor.Initialize; begin with FPropList^[0] do begin if Instance<>nil then begin if PropInfo=nil then raise Exception.Create('TPropertyEditor.Initialize 20240902134758 '+dbgsName(Self)); end else if Field<>nil then begin if FieldTypeInfo=nil then raise Exception.Create('TPropertyEditor.Initialize 20240902134825 '+dbgsName(Self)); end else raise Exception.Create('TPropertyEditor.Initialize 20240902134831 '+dbgsName(Self)); end; end; procedure TPropertyEditor.Modified(Index: integer); var PropName: ShortString; begin if PropertyHook = nil then exit; with FPropList^[Index] do begin if PropInfo<>nil then PropName:=PropInfo^.Name else PropName:=''; end; PropertyHook.Modified(Self, PropName); end; procedure TPropertyEditor.SetPropEntry(Index:Integer; AnInstance:TPersistent; APropInfo:PPropInfo); begin FPropList^[Index]:=Default(TInstProp); with FPropList^[Index] do begin Instance:=AnInstance; PropInfo:=APropInfo; end; end; procedure TPropertyEditor.SetRecordFieldEntry(Index: Integer; AnInstance: Pointer; aName: PShortString; AFieldInfo: PTypeInfo); begin FPropList^[Index]:=Default(TInstProp); with FPropList^[Index] do begin Field:=AnInstance; FieldName:=aName; FieldTypeInfo:=AFieldInfo; end; end; procedure TPropertyEditor.SetFloatValue(const NewValue: Extended); var I: Integer; begin for I:=0 to FPropCount-1 do with FPropList^[I] do begin SetFloat(NewValue); Modified(I); end; end; procedure TPropertyEditor.SetMethodValue(const NewValue: TMethod); var I: Integer; begin for I:=0 to FPropCount-1 do with FPropList^[I] do begin SetMethod(NewValue); Modified(I); end; end; procedure TPropertyEditor.SetInt64Value(const NewValue: Int64); var I: Integer; begin for I:=0 to FPropCount-1 do with FPropList^[I] do begin SetOrd(NewValue); Modified(I); end; end; procedure TPropertyEditor.SetIntfValue(const NewValue: IInterface); var I: Integer; begin for I := 0 to FPropCount - 1 do with FPropList^[I] do begin SetInterface(NewValue); Modified(I); end; end; procedure TPropertyEditor.SetOrdValue(const NewValue: Longint); var I: Integer; begin for I := 0 to FPropCount - 1 do with FPropList^[I] do begin SetOrd(NewValue); Modified(I); end; end; procedure TPropertyEditor.SetPtrValue(const NewValue: Pointer); var I: Integer; begin for I := 0 to FPropCount - 1 do with FPropList^[I] do begin SetPointerValue(NewValue); Modified(I); end; end; procedure TPropertyEditor.SetStrValue(const NewValue: AnsiString); var I: Integer; begin for I:=0 to FPropCount-1 do with FPropList^[I] do begin SetString(NewValue); Modified(I); end; end; procedure TPropertyEditor.SetWideStrValue(const NewValue: WideString); var I: Integer; begin for I:=0 to FPropCount-1 do with FPropList^[I] do begin SetWideString(NewValue); Modified(I); end; end; procedure TPropertyEditor.SetUnicodeStrValue(const NewValue: UnicodeString); var I: Integer; begin for I:=0 to FPropCount-1 do with FPropList^[I] do begin SetUnicodeString(NewValue); Modified(I); end; end; procedure TPropertyEditor.SetVarValue(const NewValue: Variant); var I: Integer; begin for I:=0 to FPropCount-1 do with FPropList^[I] do begin SetVariant(NewValue); // todo field Modified(I); end; end; procedure TPropertyEditor.Revert; var I: Integer; begin if PropertyHook<>nil then for I:=0 to FPropCount-1 do with FPropList^[I] do PropertyHook.Revert(Instance,PropInfo); // todo field end; procedure TPropertyEditor.RevertToInherited; var i: Integer; AncestorInstProp: TInstProp; Changed: Boolean; InstProp: TInstProp; NewOrdValue, OldOrdValue: Int64; OldStr, NewStr: String; OldWideStr, NewWideStr: WideString; OldUString, NewUString: UnicodeString; OldFloat, NewFloat: Extended; OldObj, NewObj: TObject; OldMethod, NewMethod: TMethod; OldInterface, NewInterface: IInterface; begin if PropertyHook=nil then exit; Changed:=false; try for i:=0 to FPropCount-1 do begin InstProp:=FPropList^[i]; if not PropertyHook.GetAncestorInstance(InstProp,AncestorInstProp) then continue; case InstProp.GetKind of tkInteger,tkChar,tkEnumeration,tkBool,tkInt64,tkQWord: begin OldOrdValue:=InstProp.GetOrd; NewOrdValue:=AncestorInstProp.GetOrd; if OldOrdValue=NewOrdValue then continue; Changed:=true; InstProp.SetOrd(NewOrdValue); end; tkSet: begin OldStr:=InstProp.GetSet(false); NewStr:=AncestorInstProp.GetSet(false); if OldStr=NewStr then continue; Changed:=true; InstProp.SetSet(NewStr); end; tkString,tkLString,tkAString: begin OldStr:=InstProp.GetString; NewStr:=AncestorInstProp.GetString; if OldStr=NewStr then continue; Changed:=true; InstProp.SetString(NewStr); end; tkWString: begin OldWideStr:=InstProp.GetWideString; NewWideStr:=AncestorInstProp.GetWideString; if OldWideStr=NewWideStr then continue; Changed:=true; InstProp.SetWideString(NewWideStr); end; tkUString: begin OldUString:=InstProp.GetUnicodeString; NewUString:=AncestorInstProp.GetUnicodeString; if OldUString=NewUString then continue; Changed:=true; InstProp.SetUnicodeString(NewUString); end; tkFloat: begin OldFloat:=InstProp.GetFloat; NewFloat:=AncestorInstProp.GetFloat; if OldFloat=NewFloat then continue; Changed:=true; InstProp.SetFloat(NewFloat); end; tkClass: begin OldObj:=InstProp.GetObject; NewObj:=AncestorInstProp.GetObject; if OldObj=NewObj then continue; Changed:=true; InstProp.SetObject(NewObj); end; tkMethod: begin OldMethod:=InstProp.GetMethod; NewMethod:=AncestorInstProp.GetMethod; if SameMethod(OldMethod,NewMethod) then continue; Changed:=true; InstProp.SetMethod(NewMethod); end; tkInterface: begin OldInterface:=InstProp.GetInterface; NewInterface:=AncestorInstProp.GetInterface; if OldInterface=NewInterface then continue; Changed:=true; InstProp.SetInterface(NewInterface); end; else end; end; finally if Changed then Modified; end; end; procedure TPropertyEditor.SetValue(const NewValue:ansistring); begin end; function TPropertyEditor.ValueAvailable:Boolean; var I:Integer; begin Result:=True; for I:=0 to FPropCount-1 do begin if (FPropList^[I].Instance is TComponent) and (csCheckPropAvail in TComponent(FPropList^[I].Instance).ComponentStyle) then begin try GetValue; AllEqual; except Result:=False; end; Exit; end; end; end; function TPropertyEditor.GetInt64Value:Int64; begin Result:=GetInt64ValueAt(0); end; function TPropertyEditor.GetInt64ValueAt(Index:Integer):Int64; begin Result:=FPropList^[Index].GetOrd; end; function TPropertyEditor.GetIntfValue: IInterface; begin Result := GetIntfValueAt(0); end; function TPropertyEditor.GetIntfValueAt(Index: Integer): IInterface; begin Result:=FPropList^[Index].GetInterface; end; { these three procedures implement the default render behavior of the object inspector's drop down list editor. You don't need to override the two measure procedures if the default width or height don't need to be changed. } procedure TPropertyEditor.ListMeasureHeight(const AValue: ansistring; Index: Integer; ACanvas: TCanvas; var AHeight: Integer); begin AHeight := ACanvas.TextHeight(AValue); end; procedure TPropertyEditor.ListMeasureWidth(const AValue: ansistring; Index: Integer; ACanvas: TCanvas; var AWidth: Integer); begin // end; procedure TPropertyEditor.ListDrawValue(const AValue: ansistring; Index: Integer; ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState); var Style : TTextStyle; begin FillChar(Style{%H-},SizeOf(Style),0); With Style do begin Alignment := taLeftJustify; Layout := tlCenter; Opaque := False; Clipping := True; ShowPrefix := True; WordBreak := False; SingleLine := True; SystemFont := False; end; ACanvas.TextRect(ARect, ARect.Left+2,ARect.Top,AValue, Style); end; { these three procedures implement the default render behavior of the object inspector's property row. You don't need to override the measure procedure if the default height don't need to be changed. } procedure TPropertyEditor.PropMeasureHeight(const NewValue: ansistring; ACanvas: TCanvas; var AHeight: Integer); begin // end; procedure TPropertyEditor.PropDrawName(ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState); var Style : TTextStyle; begin FillChar(Style{%H-},SizeOf(Style),0); With Style do begin Alignment := taLeftJustify; Layout := tlCenter; Opaque := False; Clipping := True; ShowPrefix := False; WordBreak := False; SingleLine := True; ExpandTabs := True; SystemFont := False; end; ACanvas.TextRect(ARect,ARect.Left+2,ARect.Top,GetName,Style); end; procedure TPropertyEditor.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState); begin DrawValue(GetVisualValue,ACanvas,ARect,AState); end; procedure TPropertyEditor.UpdateSubProperties; begin if (OnSubPropertiesChanged<>nil) and SubPropertiesNeedsUpdate then OnSubPropertiesChanged(Self); end; function TPropertyEditor.SubPropertiesNeedsUpdate: boolean; begin Result:=false; end; function TPropertyEditor.ValueIsStreamed: boolean; begin Result := CallStoredFunction; if Result and HasDefaultValue then Result := GetDefaultValue<>GetVisualValue; end; function TPropertyEditor.IsRevertableToInherited: boolean; begin Result:=(paRevertable in GetAttributes) and (GetComponent(0) is TComponent) and (csAncestor in TComponent(GetComponent(0)).ComponentState) and (PropertyHook<>nil) and (GetPropType^.Kind in [tkInteger,tkChar,tkEnumeration,tkBool,tkInt64,tkQWord, tkSet, tkString,tkLString,tkAString, tkWString, tkUString, tkFloat, tkClass, tkMethod, tkInterface]); end; function TPropertyEditor.GetVerbCount: Integer; begin Result:=0; if HasDefaultValue then inc(Result); // show a menu item for default value only if there is default value if IsRevertableToInherited then inc(Result); // show a menu item for 'Revert to inherited' end; function TPropertyEditor.GetVerb(Index: Integer): string; var i: Integer; begin Result := ''; i:=-1; if HasDefaultValue then begin inc(i); if i=Index then begin Result := Format(oisSetToDefault, [GetDefaultValue]); exit; end; end; if IsRevertableToInherited then begin inc(i); if i=Index then begin Result := oisRevertToInherited; exit; end; end; end; procedure TPropertyEditor.PrepareItem(Index: Integer; const AnItem: TMenuItem); begin // overridden by descendants end; procedure TPropertyEditor.ExecuteVerb(Index: Integer); var i: Integer; begin i:=-1; if HasDefaultValue then begin inc(i); if i=Index then begin SetValue(GetDefaultValue); exit; end; end; if IsRevertableToInherited then begin inc(i); if i=Index then begin RevertToInherited; exit; end; end; end; { TInstProp } function TInstProp.GetTypeInfo: PTypeInfo; begin if PropInfo<>nil then Result:=PropInfo^.PropType else Result:=FieldTypeInfo; end; function TInstProp.GetKind: TTypeKind; begin if PropInfo<>nil then Result:=PropInfo^.PropType^.Kind else Result:=FieldTypeInfo^.Kind; end; function TInstProp.GetOrd: int64; begin if Field<>nil then Result:=GetOrdField(Field,FieldTypeInfo) else Result:=GetOrdProp(Instance,PropInfo); end; procedure TInstProp.SetOrd(const Value: int64); begin if Field<>nil then SetOrdField(Field,FieldTypeInfo,Value) else SetOrdProp(Instance,PropInfo,Value); end; function TInstProp.GetEnum: string; begin if Field<>nil then Result:=GetEnumField(Field,FieldTypeInfo) else Result:=GetEnumProp(Instance,PropInfo); end; procedure TInstProp.SetEnum(const Value: string); begin if Field<>nil then SetEnumField(Field,FieldTypeInfo,Value) else SetEnumProp(Instance,PropInfo,Value); end; function TInstProp.GetSet(Brackets: boolean): string; begin if Field<>nil then Result:=GetSetField(Field,FieldTypeInfo,Brackets) else Result:=GetSetProp(Instance,PropInfo,Brackets); end; procedure TInstProp.SetSet(const Value: string); begin if Field<>nil then SetSetField(Field,FieldTypeInfo,Value) else SetSetProp(Instance,PropInfo,Value); end; function TInstProp.GetString: AnsiString; begin if Field<>nil then Result:=GetStringField(Field,FieldTypeInfo) else Result:=GetStrProp(Instance,PropInfo); end; procedure TInstProp.SetString(const Value: string); begin if Field<>nil then SetStringField(Field,FieldTypeInfo,Value) else SetStrProp(Instance,PropInfo,Value); end; function TInstProp.GetWideString: WideString; begin if Field<>nil then Result:=GetWideStringField(Field,FieldTypeInfo) else Result:=GetWideStrProp(Instance,PropInfo); end; procedure TInstProp.SetWideString(const Value: WideString); begin if Field<>nil then SetWideStringField(Field,FieldTypeInfo,Value) else SetWideStrProp(Instance,PropInfo,Value); end; function TInstProp.GetUnicodeString: UnicodeString; begin if Field<>nil then Result:=GetUnicodeStringField(Field,FieldTypeInfo) else Result:=GetUnicodeStrProp(Instance,PropInfo); end; procedure TInstProp.SetUnicodeString(const Value: UnicodeString); begin if Field<>nil then SetUnicodeStringField(Field,FieldTypeInfo,Value) else SetUnicodeStrProp(Instance,PropInfo,Value); end; function TInstProp.GetRawByteString: RawByteString; begin if Field<>nil then Result:=GetRawbyteStringField(Field,FieldTypeInfo) else Result:=GetRawbyteStrProp(Instance,PropInfo); end; procedure TInstProp.SetRawByteString(const Value: RawByteString); begin if Field<>nil then SetRawbyteStringField(Field,FieldTypeInfo,Value) else SetRawByteStrProp(Instance,PropInfo,Value); end; function TInstProp.GetFloat: Extended; begin if Field<>nil then Result:=GetFloatField(Field,FieldTypeInfo) else Result:=GetFloatProp(Instance,PropInfo); end; procedure TInstProp.SetFloat(const Value: Extended); begin if Field<>nil then SetFloatField(Field,FieldTypeInfo,Value) else SetFloatProp(Instance,PropInfo,Value); end; function TInstProp.GetObject(MinClass: TClass): TObject; begin if Field<>nil then Result:=GetObjectField(Field,FieldTypeInfo,MinClass) else Result:=GetObjectProp(Instance,PropInfo,MinClass); end; procedure TInstProp.SetObject(const Value: TObject); begin if Field<>nil then SetObjectField(Field,FieldTypeInfo,Value) else SetObjectProp(Instance,PropInfo,Value); end; function TInstProp.GetPointerValue: Pointer; begin if Field<>nil then Result:=GetPointerField(Field,FieldTypeInfo) else Result:=GetPointerProp(Instance,PropInfo); end; procedure TInstProp.SetPointerValue(const Value: Pointer); begin if Field<>nil then SetPointerField(Field,FieldTypeInfo,Value) else SetPointerProp(Instance,PropInfo,Value); end; function TInstProp.GetMethod: TMethod; begin if Field<>nil then Result:=GetMethodField(Field,FieldTypeInfo) else Result:=GetMethodProp(Instance,PropInfo); end; procedure TInstProp.SetMethod(const Value: TMethod); begin if Field<>nil then SetMethodField(Field,FieldTypeInfo,Value) else LazSetMethodProp(Instance,PropInfo,Value); end; function TInstProp.GetInterface: IInterface; begin if Field<>nil then Result:=GetInterfaceField(Field,FieldTypeInfo) else Result:=GetInterfaceProp(Instance,PropInfo); end; procedure TInstProp.SetInterface(const Value: IInterface); begin if Field<>nil then SetInterfaceField(Field,FieldTypeInfo,Value) else SetInterfaceProp(Instance,PropInfo,Value); end; function TInstProp.GetVariant: Variant; begin if Field<>nil then Result:=GetVariantField(Field,FieldTypeInfo) else Result:=GetVariantProp(Instance,PropInfo); end; procedure TInstProp.SetVariant(const Value: Variant); begin if Field<>nil then SetVariantField(Field,FieldTypeInfo,Value) else SetVariantProp(Instance,PropInfo,Value); end; { TOrdinalPropertyEditor } function TOrdinalPropertyEditor.AllEqual: Boolean; var I: Integer; V: Longint; begin Result := False; if PropCount > 1 then begin V := GetOrdValue; for I := 1 to PropCount - 1 do if GetOrdValueAt(I) <> V then Exit; end; Result := True; end; function TOrdinalPropertyEditor.GetEditLimit: Integer; begin Result := 63; end; function TOrdinalPropertyEditor.GetValue: ansistring; begin Result:=OrdValueToVisualValue(GetOrdValue); end; function TOrdinalPropertyEditor.GetDefaultValue: ansistring; begin Result:=OrdValueToVisualValue(GetDefaultOrdValue); end; function TOrdinalPropertyEditor.OrdValueToVisualValue(OrdValue: longint): string; begin Result:=IntToStr(OrdValue); end; { TIntegerPropertyEditor } function TIntegerPropertyEditor.OrdValueToVisualValue(OrdValue: longint): string; begin with GetTypeData(GetPropType)^ do begin {debugln('TIntegerPropertyEditor.OrdValueToVisualValue ',GetName,' ',dbgs(ord(OrdType)),' ',dbgs(OrdValue)); case OrdType of otSByte : debugln('TIntegerPropertyEditor.OrdValueToVisualValue otSByte ',dbgs(ShortInt(OrdValue))); otUByte : debugln('TIntegerPropertyEditor.OrdValueToVisualValue otUByte ',dbgs(Byte(OrdValue))); otSWord : debugln('TIntegerPropertyEditor.OrdValueToVisualValue otSWord ',dbgs(SmallInt(OrdValue))); otUWord : debugln('TIntegerPropertyEditor.OrdValueToVisualValue otUWord ',dbgs(Word(OrdValue))); otULong : debugln('TIntegerPropertyEditor.OrdValueToVisualValue otULong ',dbgs(Cardinal(OrdValue))); else debugln('TIntegerPropertyEditor.OrdValueToVisualValue ??? ',dbgs(OrdValue)); end;} case OrdType of otSByte : Result:= IntToStr(ShortInt(OrdValue)); otUByte : Result:= IntToStr(Byte(OrdValue)); otSWord : Result:= IntToStr(Integer(SmallInt(OrdValue)));// double conversion needed due to compiler bug 3534 otUWord : Result:= IntToStr(Word(OrdValue)); otULong : Result:= IntToStr(Cardinal(OrdValue)); else Result := IntToStr(OrdValue); end; //debugln('TIntegerPropertyEditor.OrdValueToVisualValue ',Result); end; end; procedure TIntegerPropertyEditor.SetValue(const NewValue: AnsiString); procedure Error(const Args: array of const); begin raise EPropertyError.CreateResFmt(@SOutOfRange, Args); end; var L: Int64; begin L := StrToInt64(NewValue); with GetTypeData(GetPropType)^ do if OrdType = otULong then begin // unsigned compare and reporting needed if (L < Cardinal(MinValue)) or (L > Cardinal(MaxValue)) then begin // bump up to Int64 to get past the %d in the format string Error([Int64(Cardinal(MinValue)), Int64(Cardinal(MaxValue))]); exit; end end else if (L < MinValue) or (L > MaxValue) then begin Error([MinValue, MaxValue]); exit; end; SetOrdValue(integer(L)); end; { TCharPropertyEditor } function TCharPropertyEditor.OrdValueToVisualValue(OrdValue: longint): string; var Ch: Char; begin Ch := Chr(OrdValue); if Ch in [#33..#127] then Result := Ch else Result:='#'+IntToStr(Ord(Ch)); end; procedure TCharPropertyEditor.SetValue(const NewValue: ansistring); var L: Longint; begin if Length(NewValue) = 0 then L := 0 else if Length(NewValue) = 1 then L := Ord(NewValue[1]) else if NewValue[1] = '#' then L := StrToInt(Copy(NewValue, 2, Maxint)) else begin {raise EPropertyError.CreateRes(@SInvalidPropertyValue)}; exit; end; with GetTypeData(GetPropType)^ do //Only Chars < #$80 are valid single-byte UTF-8 codepoints, //so use this instead of MaxValue (255 for tkChar), since LCL is UTF-8 if (L < MinValue) or (L > $7F) then begin {raise EPropertyError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue])}; exit; end; SetOrdValue(L); end; { TEnumPropertyEditor } function TEnumPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paValueList, paSortList, paRevertable]; end; function TEnumPropertyEditor.OrdValueToVisualValue(OrdValue: longint): string; var L: Longint; TypeData: PTypeData; begin L := OrdValue; TypeData := GetTypeData(GetPropType); with TypeData^ do if (L < MinValue) or (L > MaxValue) then L := MaxValue; Result := GetEnumName(GetPropType, L); end; function TEnumPropertyEditor.GetVisualValue: ansistring; begin if FInvalid then Result := oisInvalid else Result := inherited GetVisualValue; end; procedure TEnumPropertyEditor.GetValues(Proc: TGetStrProc); var I: Integer; EnumType: PTypeInfo; s: String; begin EnumType := GetPropType; with GetTypeData(EnumType)^ do for I := MinValue to MaxValue do begin s := GetEnumName(EnumType, I); Proc(s); end; end; procedure TEnumPropertyEditor.SetValue(const NewValue: ansistring); var I: Integer; begin I := GetEnumValue(GetPropType, NewValue); FInvalid := I < 0; if not FInvalid then SetOrdValue(I); end; { TBoolPropertyEditor } function TBoolPropertyEditor.OrdValueToVisualValue(OrdValue: longint): string; begin if OrdValue = 0 then Result := 'False' else Result := 'True'; if FPropertyHook.GetCheckboxForBoolean then Result := '(' + Result + ')'; end; function TBoolPropertyEditor.GetVisualValue: ansistring; begin Result := inherited GetVisualValue; if Result = '' then Result := oisMixed; end; procedure TBoolPropertyEditor.GetValues(Proc: TGetStrProc); begin Proc('False'); Proc('True'); end; procedure TBoolPropertyEditor.SetValue(const NewValue: ansistring); var I: Integer; begin if (CompareText(NewValue, 'False') = 0) or (CompareText(NewValue, '(False)') = 0) or (CompareText(NewValue, 'F') = 0) then I := 0 else if (CompareText(NewValue, 'True') = 0) or (CompareText(NewValue, '(True)') = 0) or (CompareText(NewValue, 'T') = 0) then I := 1 else I := StrToInt(NewValue); SetOrdValue(I); end; procedure TBoolPropertyEditor.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState); var TxtRect: TRect; begin TxtRect := DrawCheckValue(ACanvas, ARect, AState, GetOrdValue<>0); if TxtRect.Top <> -100 then inherited PropDrawValue(ACanvas, TxtRect, AState); end; { TInt64PropertyEditor } function TInt64PropertyEditor.AllEqual: Boolean; var I: Integer; V: Int64; begin Result := False; if PropCount > 1 then begin V := GetInt64Value; for I := 1 to PropCount - 1 do if GetInt64ValueAt(I) <> V then Exit; end; Result := True; end; function TInt64PropertyEditor.GetEditLimit: Integer; begin Result := 63; end; function TInt64PropertyEditor.GetValue: ansistring; begin Result := IntToStr(GetInt64Value); end; procedure TInt64PropertyEditor.SetValue(const NewValue: ansistring); begin SetInt64Value(StrToInt64(NewValue)); end; { TQWordPropertyEditor } function TQWordPropertyEditor.GetValue: ansistring; begin Result := IntToStr(QWord(GetInt64Value)); end; procedure TQWordPropertyEditor.SetValue(const NewValue: ansistring); begin SetInt64Value(Int64(StrToQWord(NewValue))); end; { TFloatPropertyEditor } function TFloatPropertyEditor.FloatInRange(AValue: Extended; AType: TFloatType): Boolean; {$ifndef FPC_HAS_TYPE_DOUBLE} const MaxDouble = Math.MaxSingle; {$endif} {$ifndef FPC_HAS_TYPE_EXTENDED} const MaxExtended = MaxDouble; {$endif} {$ifndef FPC_HAS_TYPE_COMP} const MaxComp = 9223372036854775807; MinComp = -9223372036854775808; {$endif} begin try case AType of ftSingle: Result := {$ifndef FPC_HAS_TYPE_DOUBLE} //Extended=Single, so anything out of range of a Single will be +/-Infinity not IsInfinite(AValue); {$else} (AValue <= MaxSingle) and (AValue >= -MaxSingle); {$endif} ftDouble: Result := {$ifndef FPC_HAS_TYPE_EXTENDED} //Extended=Double, so anything out of range of a Double will be +/-Infinity not IsInfinite(AValue); {$else} (AValue <= MaxDouble) and (AValue >= -MaxDouble); {$endif} ftExtended: Result := not IsInfinite(AValue); ftComp: Result := (AValue <= MaxComp) and (AValue >= MinComp); ftCurr: Result := (AValue <= MaxCurrency) and (AValue >= MinCurrency); end; except //Currency comparisons can cause Floating Point overflow on Win64 (i.e. compared with +/-MaxDouble, +/-MaxExtended, MaxComp, MinComp, +/-Inf) //and on Win32 (i.e with +/-MaxExtended), not tested other platforms Result := False; end; end; function TFloatPropertyEditor.AllEqual: Boolean; var I: Integer; V: Extended; begin Result := False; if PropCount > 1 then begin V := GetFloatValue; for I := 1 to PropCount - 1 do if GetFloatValueAt(I) <> V then Exit; end; Result := True; end; function TFloatPropertyEditor.FormatValue(const AValue: Extended): ansistring; const Precisions: array[TFloatType] of Integer = (7, 15, 19, 19, 19); var FS: TFormatSettings; begin FS := DefaultFormatSettings; FS.DecimalSeparator := '.'; //It's Pascal sourcecode representation of a float, not a textual (i18n) one Result := FloatToStrF(AValue, ffGeneral, Precisions[GetTypeData(GetPropType)^.FloatType], 0, FS); end; function TFloatPropertyEditor.GetDefaultValue: ansistring; begin if not HasDefaultValue then raise EPropertyError.Create('No property default available'); Result:=FormatValue(0); end; function TFloatPropertyEditor.GetValue: ansistring; begin Result := FormatValue(GetFloatValue); end; procedure TFloatPropertyEditor.SetValue(const NewValue: ansistring); var FS: TFormatSettings; NewFloat: Extended; fType: TFloatType; begin //writeln('TFloatPropertyEditor.SetValue A ',NewValue,' ',StrToFloat(NewValue)); FS := DefaultFormatSettings; FS.DecimalSeparator := '.'; //after all, this is Pascal, so we expect a period if not TryStrToFloat(NewValue, NewFloat, FS) then //if this failed, assume the user entered DS from his current locale NewFloat := StrToFloat(NewValue, DefaultFormatSettings); //conversion succeeded, out of range input gets converted to +/-Inf as well, not only literal user input as '+Inf' //so check user input instead of IsInfinite now if (Pos('inf',LowerCase(NewValue)) > 0) then raise EPropertyError.Create(oisInfinityNotSupported); //Check NaN before checking for range, since you cannot compare NaN to anything if IsNan(NewFloat) then raise EPropertyError.Create(oisNaNNotSupported); fType := GetTypeData(GetPropType)^.FloatType; if not FloatInRange(NewFloat, fType) then raise EPropertyError.Create(oisValueOutOfRange); SetFloatValue(NewFloat); //writeln('TFloatPropertyEditor.SetValue B ',GetValue); end; { TStringPropertyEditor } function TStringPropertyEditor.AllEqual: Boolean; var I: Integer; V: ansistring; begin Result := False; if PropCount > 1 then begin V := GetStrValue; for I := 1 to PropCount - 1 do if GetStrValueAt(I) <> V then Exit; end; Result := True; end; function TStringPropertyEditor.GetEditLimit: Integer; begin if GetPropType^.Kind = tkSString then Result := GetTypeData(GetPropType)^.MaxLength else Result := $0FFF; end; function TStringPropertyEditor.GetValue: ansistring; begin Result := GetStrValue; end; procedure TStringPropertyEditor.SetValue(const NewValue: ansistring); begin SetStrValue(NewValue); end; { TPasswordStringPropertyEditor } function TPasswordStringPropertyEditor.GetPassword: string; begin if GetVisualValue<>'' then Result:='*****' else Result:=''; end; procedure TPasswordStringPropertyEditor.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState); begin DrawValue(GetPassword,ACanvas,ARect,AState); end; { TWideStringPropertyEditor } function TWideStringPropertyEditor.AllEqual: Boolean; var I: Integer; V: widestring; begin Result := False; if PropCount > 1 then begin V := GetWideStrValue; for I := 1 to PropCount - 1 do if GetWideStrValueAt(I) <> V then Exit; end; Result := True; end; function TWideStringPropertyEditor.GetValue: ansistring; begin Result:=UTF8Encode(GetWideStrValue); end; procedure TWideStringPropertyEditor.SetValue(const NewValue: ansistring); begin SetWideStrValue(UTF8Decode(NewValue)); end; { TPasswordWideStringPropertyEditor } function TPasswordWideStringPropertyEditor.GetPassword: WideString; begin if GetVisualValue<>'' then Result:='*****' else Result:=''; end; procedure TPasswordWideStringPropertyEditor.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState); begin DrawValue(UTF8Encode(GetPassword),ACanvas,ARect,AState); end; { TUnicodeStringPropertyEditor } function TUnicodeStringPropertyEditor.AllEqual: Boolean; var I: Integer; V: UnicodeString; begin Result := False; if PropCount > 1 then begin V := GetUnicodeStrValue; for I := 1 to PropCount - 1 do if GetUnicodeStrValueAt(I) <> V then Exit; end; Result := True; end; function TUnicodeStringPropertyEditor.GetValue: ansistring; begin Result:=UTF8Encode(GetUnicodeStrValue); end; procedure TUnicodeStringPropertyEditor.SetValue(const NewValue: ansistring); begin SetUnicodeStrValue(UTF8Decode(NewValue)); end; { TNestedPropertyEditor } constructor TNestedPropertyEditor.Create(Parent: TPropertyEditor); begin FParentEditor:=Parent; FPropertyHook:=Parent.PropertyHook; FPropList:=Parent.FPropList; FPropCount:=Parent.PropCount; end; destructor TNestedPropertyEditor.Destroy; begin end; { TSetElementPropertyEditor } constructor TSetElementPropertyEditor.Create(Parent: TPropertyEditor; AElement: Integer); begin inherited Create(Parent); FElement := AElement; end; // The IntegerSet (a set of size of an integer) // don't know if this is always valid type TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1; function TSetElementPropertyEditor.AllEqual: Boolean; var I: Integer; S: TIntegerSet; V: Boolean; begin Result := False; if PropCount > 1 then begin Integer(S) := GetOrdValue; V := FElement in S; for I := 1 to PropCount - 1 do begin Integer(S) := GetOrdValueAt(I); if (FElement in S) <> V then Exit; end; end; Result := True; end; function TSetElementPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paValueList, paSortList]; end; function TSetElementPropertyEditor.GetName: shortstring; begin Result := GetEnumName(GetTypeData(GetPropType)^.CompType, FElement); end; function TSetElementPropertyEditor.GetValue: ansistring; var S: TIntegerSet; begin Integer(S) := GetOrdValue; Result := BooleanIdents[FElement in S]; if FPropertyHook.GetCheckboxForBoolean then Result := '(' + Result + ')'; end; function TSetElementPropertyEditor.GetVerbCount: Integer; begin Result:=0; end; function TSetElementPropertyEditor.GetVisualValue: ansistring; begin Result := inherited GetVisualValue; if Result = '' then Result := oisMixed; end; procedure TSetElementPropertyEditor.GetValues(Proc: TGetStrProc); begin Proc(BooleanIdents[False]); Proc(BooleanIdents[True]); end; procedure TSetElementPropertyEditor.SetValue(const NewValue: ansistring); var S: TIntegerSet; begin Integer(S) := GetOrdValue; if (CompareText(NewValue, 'True') = 0) or (CompareText(NewValue, '(True)') = 0) then Include(S, FElement) else Exclude(S, FElement); SetOrdValue(Integer(S)); end; function TSetElementPropertyEditor.ValueIsStreamed: boolean; var S1, S2: TIntegerSet; begin Result := CallStoredFunction; if Result and HasDefaultValue then begin Integer(S1) := GetOrdValue; Integer(S2) := GetDefaultOrdValue; Result := (FElement in S1) <> (FElement in S2); end; end; procedure TSetElementPropertyEditor.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; AState: TPropEditDrawState); var S: TIntegerSet; TxtRect: TRect; begin Integer(S) := GetOrdValue; TxtRect := DrawCheckValue(ACanvas, ARect, AState, FElement in S); if TxtRect.Top <> -100 then inherited PropDrawValue(ACanvas, TxtRect, AState); end; { TSetPropertyEditor } function TSetPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paSubProperties, paReadOnly, paRevertable]; end; function TSetPropertyEditor.GetEditLimit: Integer; begin Result := 0; end; procedure TSetPropertyEditor.GetProperties(Proc: TGetPropEditProc); var I: Integer; EnumType: PTypeInfo; begin EnumType := GetTypeData(GetPropType)^.CompType; with GetTypeData(EnumType)^ do for I := MinValue to MaxValue do Proc(TSetElementPropertyEditor.Create(Self, I)); end; procedure TSetPropertyEditor.SetValue(const NewValue: ansistring); var S: TIntegerSet; TypeInfo: PTypeInfo; I: Integer; begin S := []; TypeInfo := GetTypeData(GetPropType)^.CompType; for I := 0 to SizeOf(Integer) * 8 - 1 do if Pos(GetEnumName(TypeInfo, I), NewValue) > 0 then Include(S, I); SetOrdValue(Integer(S)); end; function TSetPropertyEditor.OrdValueToVisualValue(OrdValue: longint): string; var S: TIntegerSet; TypeInfo: PTypeInfo; I: Integer; begin Integer(S) := OrdValue; TypeInfo := GetTypeData(GetPropType)^.CompType; Result := '['; for I := 0 to SizeOf(Integer) * 8 - 1 do if I in S then begin if Length(Result) <> 1 then Result := Result + ','; Result := Result + GetEnumName(TypeInfo, I); end; Result := Result + ']'; end; { TStructurePropertyEditor } function TStructurePropertyEditor.EditorFilter(const AEditor: TPropertyEditor): Boolean; begin Result := IsInteresting(AEditor, SubPropsTypeFilter, SubPropsNameFilter); end; procedure TStructurePropertyEditor.ListSubProps(Prop: TPropertyEditor); begin FSubProps.Add(Prop); end; procedure TStructurePropertyEditor.SetSubPropsTypeFilter(const AValue: TTypeKinds); begin if FSubPropsTypeFilter = AValue then exit; FSubPropsTypeFilter := AValue; end; constructor TStructurePropertyEditor.Create(Hook: TPropertyEditorHook; APropCount: Integer); begin inherited Create(Hook, APropCount); FSubPropsTypeFilter := tkAny; end; destructor TStructurePropertyEditor.Destroy; begin FreeAndNil(FSubProps); inherited Destroy; end; function TStructurePropertyEditor.AllEqual: Boolean; begin Result:=true; end; { TListElementPropertyEditor } constructor TListElementPropertyEditor.Create(Parent: TListPropertyEditor; AnIndex: integer); begin inherited Create(Parent); FList:=Parent; FIndex:=AnIndex; end; destructor TListElementPropertyEditor.Destroy; begin inherited Destroy; end; function TListElementPropertyEditor.GetAttributes: TPropertyAttributes; begin Result:=List.GetElementAttributes(Self); end; function TListElementPropertyEditor.GetName: shortstring; begin Result:=List.GetElementName(Self); end; procedure TListElementPropertyEditor.GetProperties(Proc: TGetPropEditProc); begin List.GetElementProperties(Self,Proc); end; function TListElementPropertyEditor.GetValue: ansistring; begin Result:=List.GetElementValue(Self); end; procedure TListElementPropertyEditor.GetValues(Proc: TGetStrProc); begin List.GetElementValues(Self,Proc); end; procedure TListElementPropertyEditor.SetValue(const NewValue: ansistring); begin List.SetElementValue(Self,NewValue); end; { TListPropertyEditor } function TListPropertyEditor.GetElementCount: integer; begin if not IsSaving then Result:=SavedElements.Count else Result:=ReadElementCount; end; function TListPropertyEditor.GetElement(Index: integer): TPersistent; var ElementCount: integer; begin // do some checks if (Index<0) then raise Exception.Create('TListPropertyEditor.GetElement Index='+IntToStr(Index)); ElementCount:=GetElementCount; if Index>=ElementCount then raise Exception.Create('TListPropertyEditor.GetElement Index='+IntToStr(Index) +' Count='+IntToStr(ElementCount)); // get element if not IsSaving then Result:=TPersistent(SavedElements[Index]) else Result:=ReadElement(Index); end; function TListPropertyEditor.GetElement(Element: TListElementPropertyEditor ): TPersistent; begin Result:=GetElement(Element.TheIndex); end; function TListPropertyEditor.GetElementPropEditor(Index: integer ): TListElementPropertyEditor; // called by GetProperties to get the element property editors begin if not IsSaving then Result:=TListElementPropertyEditor(SavedPropertyEditors[Index]) else Result:=CreateElementPropEditor(Index); end; procedure TListPropertyEditor.SaveElements; begin if IsSaving then exit; BeginSaveElement; FreeElementPropertyEditors; DoSaveElements; FSubPropertiesChanged:=false; EndSaveElement; end; function TListPropertyEditor.SubPropertiesNeedsUpdate: boolean; var i: integer; begin Result:=true; if FSubPropertiesChanged then exit; FSubPropertiesChanged:=true; if SavedList<>GetComponent(0) then exit; if ReadElementCount<>SavedElements.Count then exit; for i:=0 to SavedElements.Count-1 do if TPersistent(SavedElements[i])<>ReadElement(i) then exit; Result:=false; FSubPropertiesChanged:=false; end; function TListPropertyEditor.ReadElementCount: integer; var TheList: TObject; begin TheList := GetObjectValue; if TheList is TList then Result := TList(TheList).Count else Result := 0; end; function TListPropertyEditor.ReadElement(Index: integer): TPersistent; var obj: TObject; begin obj := TObject(TList(GetObjectValue).Items[Index]); if obj is TPersistent then Result:=TPersistent(obj) else raise EInvalidOperation.CreateFmt('List element %d is not a TPersistent descendant', [Index]); end; function TListPropertyEditor.CreateElementPropEditor(Index: integer ): TListElementPropertyEditor; begin Result:=TListElementPropertyEditor.Create(Self,Index); end; procedure TListPropertyEditor.BeginSaveElement; begin inc(FSaveElementLock); end; procedure TListPropertyEditor.EndSaveElement; begin dec(FSaveElementLock); if FSaveElementLock<0 then DebugLn('TListPropertyEditor.EndSaveElement ERROR: FSaveElementLock=', IntToStr(FSaveElementLock)); end; procedure TListPropertyEditor.DoSaveElements; var i, ElementCount: integer; begin SavedList:=GetComponent(0); ElementCount:=GetElementCount; SavedElements.Count:=ElementCount; for i:=0 to ElementCount-1 do SavedElements[i]:=GetElement(i); SavedPropertyEditors.Count:=ElementCount; for i:=0 to ElementCount-1 do SavedPropertyEditors[i]:=GetElementPropEditor(i); end; procedure TListPropertyEditor.FreeElementPropertyEditors; var i: integer; begin for i:=0 to SavedPropertyEditors.Count-1 do TObject(SavedPropertyEditors[i]).Free; SavedPropertyEditors.Clear; end; function TListPropertyEditor.GetElementAttributes( Element: TListElementPropertyEditor ): TPropertyAttributes; begin Result:= [paReadOnly]; end; function TListPropertyEditor.GetElementName(Element: TListElementPropertyEditor ): shortstring; begin Result:=''; end; procedure TListPropertyEditor.GetElementProperties( Element: TListElementPropertyEditor; Proc: TGetPropEditProc); begin end; function TListPropertyEditor.GetElementValue(Element: TListElementPropertyEditor ): ansistring; begin Result:=''; end; procedure TListPropertyEditor.GetElementValues( Element: TListElementPropertyEditor; Proc: TGetStrProc); begin end; procedure TListPropertyEditor.SetElementValue( Element: TListElementPropertyEditor; NewValue: ansistring); begin end; function TListPropertyEditor.IsSaving: boolean; begin Result:=SaveElementLock>0; end; constructor TListPropertyEditor.Create(Hook: TPropertyEditorHook; APropCount: Integer); begin inherited Create(Hook, APropCount); SavedElements:=TList.Create; SavedPropertyEditors:=TList.Create; end; destructor TListPropertyEditor.Destroy; begin UnregisterListPropertyEditor(Self); FreeElementPropertyEditors; FreeAndNil(SavedPropertyEditors); FreeAndNil(SavedElements); inherited Destroy; end; function TListPropertyEditor.GetAttributes: TPropertyAttributes; begin Result:= [paSubProperties, paDynamicSubProps, paReadOnly, paDialog]; end; procedure TListPropertyEditor.GetProperties(Proc: TGetPropEditProc); var i, ElementCount: integer; begin SaveElements; ElementCount:=GetElementCount; for i:=0 to ElementCount-1 do Proc(GetElementPropEditor(i)); end; function TListPropertyEditor.GetValue: AnsiString; var ElementCount: integer; begin ElementCount:=GetElementCount; if ElementCount<>1 then Result:=IntToStr(GetElementCount)+' items' else Result:='1 item'; end; procedure TListPropertyEditor.Initialize; begin inherited Initialize; RegisterListPropertyEditor(Self); SaveElements; end; const CollectionForm: TCollectionPropertyEditorForm = nil; // - - - - - - - - - - - - - - - - - - - - - - - - - - function TCollectionPropertyEditor.ReadElement(Index: integer): TPersistent; var Collection: TCollection; begin Collection:=TCollection(GetObjectValue); Result:=Collection.Items[Index]; end; function TCollectionPropertyEditor.GetElementAttributes( Element: TListElementPropertyEditor): TPropertyAttributes; begin Result := [paSubProperties, paReadOnly]; end; function TCollectionPropertyEditor.GetElementName( Element: TListElementPropertyEditor): shortstring; begin Result:=inherited GetElementName(Element); end; procedure TCollectionPropertyEditor.GetElementProperties( Element: TListElementPropertyEditor; Proc: TGetPropEditProc); begin GetPersistentProperties(GetElement(Element),tkProperties,PropertyHook,Proc,nil); end; function TCollectionPropertyEditor.GetElementValue( Element: TListElementPropertyEditor): ansistring; begin Result:=IntToStr(TCollectionItem(GetElement(Element)).ID); end; procedure TCollectionPropertyEditor.GetElementValues( Element: TListElementPropertyEditor; Proc: TGetStrProc); begin inherited GetElementValues(Element, Proc); end; procedure TCollectionPropertyEditor.SetElementValue( Element: TListElementPropertyEditor; NewValue: ansistring); begin inherited SetElementValue(Element, NewValue); end; function TCollectionPropertyEditor.ReadElementCount: integer; var Collection: TObject; begin Collection := GetObjectValue; if Collection is TCollection then Result := TCollection(Collection).Count else Result := 0; end; function TCollectionPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paDialog, paReadOnly]; end; class function TCollectionPropertyEditor.ShowCollectionEditor( ACollection: TCollection; OwnerPersistent: TPersistent; const PropName: String): TCustomForm; begin if CollectionForm = nil then CollectionForm := TCollectionPropertyEditorForm.Create(Application); CollectionForm.SetCollection(ACollection, OwnerPersistent, PropName); CollectionForm.actAdd.Visible := true; CollectionForm.actDel.Visible := true; CollectionForm.AddButton.Left := 0; CollectionForm.DeleteButton.Left := 1; CollectionForm.DividerToolButton.Show; CollectionForm.DividerToolButton.Left := CollectionForm.DeleteButton.Left + 1; SetPopupModeParentForPropertyEditor(CollectionForm); CollectionForm.EnsureVisible; CollectionForm.UpdateButtons; Result:=CollectionForm; end; procedure TCollectionPropertyEditor.Edit; var TheCollection: TCollection; begin TheCollection := TCollection(GetObjectValue); if TheCollection = nil then raise Exception.Create('Collection=nil'); ShowCollectionEditor(TheCollection, GetComponent(0), GetName); end; { TDisabledCollectionPropertyEditor } function TDisabledCollectionPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paDialog, paReadOnly, paDisableSubProperties]; end; { TNoAddDeleteCollectionPropertyEditor } class function TNoAddDeleteCollectionPropertyEditor.ShowCollectionEditor( ACollection: TCollection; OwnerPersistent: TPersistent; const PropName: String): TCustomForm; begin if CollectionForm = nil then CollectionForm := TCollectionPropertyEditorForm.Create(Application); CollectionForm.SetCollection(ACollection, OwnerPersistent, PropName); CollectionForm.actAdd.Visible := false; CollectionForm.actDel.Visible := false; CollectionForm.DividerToolButton.Hide; SetPopupModeParentForPropertyEditor(CollectionForm); CollectionForm.EnsureVisible; CollectionForm.UpdateButtons; Result := CollectionForm; end; { TClassPropertyEditor } function TClassPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paSubProperties, paReadOnly]; end; procedure TClassPropertyEditor.GetProperties(Proc: TGetPropEditProc); var selection: TPersistentSelectionList; begin selection := GetSelections; if selection = nil then exit; GetPersistentProperties( selection, SubPropsTypeFilter + [tkClass], PropertyHook, Proc, @EditorFilter); selection.Free; end; function TClassPropertyEditor.GetSelections: TPersistentSelectionList; var i: Integer; subItem: TPersistent; begin Result := TPersistentSelectionList.Create; try for i := 0 to PropCount - 1 do begin subItem := TPersistent(GetObjectValueAt(i)); if subItem <> nil then Result.Add(subItem); end; except Result.Free; raise; end; end; function TClassPropertyEditor.GetValue: String; begin if FHideClassName then Result:='' else Result:='(' + GetPropType^.Name + ')'; end; function TClassPropertyEditor.ValueIsStreamed: boolean; var I: Integer; begin Result := inherited ValueIsStreamed; if not Result then Exit; if FSubProps=nil then begin FSubProps := TObjectList.Create(True); GetProperties(@ListSubProps); end; for I := 0 to FSubProps.Count-1 do if TPropertyEditor(FSubProps[I]).ValueIsStreamed then Exit(True); Result := False; end; { TMethodPropertyEditor } function TMethodPropertyEditor.AllEqual: Boolean; var I: Integer; CurFirstValue, AnotherValue: TMethod; begin Result := False; if PropCount > 1 then begin CurFirstValue := GetMethodValue; for I := 1 to PropCount - 1 do begin AnotherValue := GetMethodValueAt(I); // Note: compare Code and Data if (AnotherValue.Code <> CurFirstValue.Code) or (AnotherValue.Data <> CurFirstValue.Data) then Exit; end; end; Result := True; end; procedure TMethodPropertyEditor.Edit; { If the method does not exist in current lookuproot: create it Then jump to the source. For inherited methods this means: A new method is created and a call of the ancestor value is added. Then the IDE jumps to the new method body. } var NewMethodName: String; r: TModalResult; begin NewMethodName := GetValue; {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.Edit OldValue="',NewMethodName,'" FromLookupRoot=',(IsValidIdent(NewMethodName, True, True) and PropertyHook.MethodFromLookupRoot(GetMethodValue))]); DumpStack; {$ENDIF} if IsValidIdent(NewMethodName) and PropertyHook.MethodFromLookupRoot(GetMethodValue) then begin {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.Edit Show']); {$ENDIF} PropertyHook.ShowMethod(NewMethodName); end else begin // the current method is from the another class (e.g. ancestor or frame) if IsValidIdent(NewMethodName) then r:=QuestionDlg('Override or jump', 'The event "'+GetName+'" currently points to an inherited method.', mtConfirmation,[mrYes,'Create Override',mrOk,'Jump to inherited method',mrCancel], 0) else r:=mrYes; case r of mrYes: begin // -> add an override with the default name NewMethodName := GetFormMethodName; {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.Edit NewValue="',NewMethodName,'"']); {$ENDIF} Assert(IsValidIdent(NewMethodName),'Method name "'+NewMethodName+'" must be an identifier'); NewMethodName:=PropertyHook.LookupRoot.ClassName+'.'+NewMethodName; {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.Edit CreateMethod "',NewMethodName,'"...']); {$ENDIF} SetMethodValue(PropertyHook.CreateMethod(NewMethodName, GetPropType, GetComponent(0), GetPropertyPath(0))); {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.Edit CHANGED new method=',GetValue]); {$ENDIF} PropertyHook.RefreshPropertyValues; ShowValue; end; mrOk: begin // -> jump to ancestor method {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.Edit Jump to ancestor method ',NewMethodName]); {$ENDIF} PropertyHook.ShowMethod(NewMethodName); end; end; end; end; procedure TMethodPropertyEditor.ShowValue; var CurMethodName: String; begin CurMethodName:=GetValue; PropertyHook.ShowMethod(CurMethodName); end; function TMethodPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paDialog, paValueList, paSortList, paRevertable]; end; function TMethodPropertyEditor.GetEditLimit: Integer; begin Result := 2*MaxIdentLength+1; // clasname.methodname end; function TrimNonAscii(const Txt: String): String; // ToDo: Find a similar function from FPC libs and use it instead. var I: Integer; begin Result := Txt; for I := Length(Result) downto 1 do if not ( (Result[I] in ['a'..'z', 'A'..'Z', '_']) or (I > 1) and (Result[I] in ['0'..'9']) ) then Delete(Result, I, 1); end; function TrimDotsAndBrackets(const Txt: String): String; var I: Integer; begin Result := Txt; for I := Length(Result) downto 1 do if Result[I] in ['.','[',']'] then Delete(Result, I, 1); end; function TrimEventName(const aName: shortstring): shortstring; begin Result := aName; if (Length(Result) >= 2) and (Result[1] in ['O','o']) and (Result[2] in ['N','n']) then Delete(Result, 1, 2); end; function TMethodPropertyEditor.GetTrimmedEventName: shortstring; begin Result := TrimEventName(GetName); end; function MethodNameSub(Root: TPersistent): shortstring; begin if Root is TCustomForm then Result := 'Form' else if Root is TDataModule then Result := 'DataModule' else if Root is TFrame then Result := 'Frame' else Result := ''; end; function TMethodPropertyEditor.GetFormMethodName: shortstring; // returns the default name for a new method begin Result := ''; if PropertyHook.LookupRoot=nil then exit; if GetComponent(0) = PropertyHook.LookupRoot then begin Result := MethodNameSub(PropertyHook.LookupRoot); if Result = '' then Result := ClassNameToComponentName(PropertyHook.GetRootClassName); end else Result := TrimNonAscii(PropertyHook.GetObjectName(GetComponent(0), FOwnerComponent)); if Result = '' then exit; Result := Result + GetTrimmedEventName; end; class function TMethodPropertyEditor.GetDefaultMethodName(Root, Component: TComponent; const RootClassName, ComponentName, PropName: shortstring): shortstring; // returns the default name for a new method begin Result := ''; if Root=nil then exit; if Component = Root then begin Result := MethodNameSub(Root); if Result = '' then Result := ClassNameToComponentName(RootClassName); end else Result := TrimDotsAndBrackets(ComponentName); if Result <> '' then Result := Result + TrimEventName(PropName) else DebugLn(['TMethodPropertyEditor.GetDefaultMethodName cannot create name - should never happen']); end; function TMethodPropertyEditor.GetValue: ansistring; begin if Assigned(PropertyHook) then Result:=PropertyHook.GetMethodName(GetMethodValue,GetComponent(0)) else begin Result:=''; debugln(['TMethodPropertyEditor.GetValue : PropertyHook=Nil Name=',GetName,' Data=',dbgs(GetMethodValue.Data)]); end; end; procedure TMethodPropertyEditor.GetValues(Proc: TGetStrProc); begin //DebugLn('### TMethodPropertyEditor.GetValues'); Proc(oisNone); PropertyHook.GetCompatibleMethods(GetInstProp, Proc); end; procedure TMethodPropertyEditor.SetValue(const NewValue: ansistring); var CreateNewMethodSrc: Boolean; CurValue: string; NewMethodExists, NewMethodIsCompatible, NewMethodIsPublished, NewIdentIsMethod: boolean; IsNil: Boolean; NewMethod: TMethod; begin CurValue := GetValue; if CurValue = NewValue then exit; {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.SetValue CurValue="',CurValue,'" NewValue="',NewValue,'"']); {$ENDIF} IsNil := (NewValue='') or (NewValue=oisNone); if (not IsNil) and (not IsValidIdent(NewValue)) then begin MessageDlg(oisIncompatibleIdentifier, Format(oisIsNotAValidMethodName,[NewValue]), mtError, [mbCancel, mbIgnore], 0); exit; end; NewMethodExists := (not IsNil) and PropertyHook.CompatibleMethodExists(NewValue, GetInstProp, NewMethodIsCompatible, NewMethodIsPublished, NewIdentIsMethod); {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.SetValue NewValue="',NewValue,'" IsCompatible=',NewMethodIsCompatible,' IsPublished=',NewMethodIsPublished,' IsMethod=',NewIdentIsMethod]); {$ENDIF} if NewMethodExists then begin if not NewIdentIsMethod then begin if MessageDlg(oisIncompatibleIdentifier, Format(oisTheIdentifierIsNotAMethodPressCancelToUndoPressIgn, [NewValue, LineEnding, LineEnding]), mtWarning, [mbCancel, mbIgnore], 0)<>mrIgnore then exit; end; if not NewMethodIsPublished then begin if MessageDlg(oisIncompatibleMethod, Format(oisTheMethodIsNotPublishedPressCancelToUndoPressIgnor, [NewValue, LineEnding, LineEnding]), mtWarning, [mbCancel, mbIgnore], 0)<>mrIgnore then exit; end; if not NewMethodIsCompatible then begin if MessageDlg(oisIncompatibleMethod, Format(oisTheMethodIsIncompatibleToThisEventPressCancelToUnd, [NewValue, GetName, LineEnding, LineEnding]), mtWarning, [mbCancel, mbIgnore], 0)<>mrIgnore then exit; end; end; if IsNil then begin // clear NewMethod.Data := nil; NewMethod.Code := nil; {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.SetValue SET to NIL']); {$ENDIF} SetMethodValue(NewMethod); end else if IsValidIdent(CurValue) and not NewMethodExists and PropertyHook.MethodFromLookupRoot(GetMethodValue) then begin // rename the method // Note: // All other not selected properties that use this method, contain just // the TMethod record. So, changing the name in the jitform will change // all other event names in all other components automatically. {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.SetValue RENAME']); {$ENDIF} PropertyHook.RenameMethod(CurValue, NewValue) end else begin // change value and create method src if needed CreateNewMethodSrc := not NewMethodExists; {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.SetValue CHANGE new method=',CreateNewMethodSrc]); {$ENDIF} SetMethodValue( PropertyHook.CreateMethod(NewValue, GetPropType, GetComponent(0), GetPropertyPath(0))); {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.SetValue CHANGED new method=',CreateNewMethodSrc]); {$ENDIF} if CreateNewMethodSrc then begin {$IFDEF VerboseMethodPropEdit} debugln(['TMethodPropertyEditor.SetValue SHOW "',NewValue,'"']); {$ENDIF} PropertyHook.ShowMethod(NewValue); end; end; {$IFDEF VerboseMethodPropEdit} DebugLn('### TMethodPropertyEditor.SetValue END NewValue=',GetValue); {$ENDIF} end; { TPersistentPropertyEditor } function TPersistentPropertyEditor.FilterFunc( const ATestEditor: TPropertyEditor): Boolean; begin Result := not (paNotNestable in ATestEditor.GetAttributes); end; function TPersistentPropertyEditor.GetPersistentReference: TPersistent; begin Result := TPersistent(GetObjectValue); end; function TPersistentPropertyEditor.GetSelections: TPersistentSelectionList; begin if (GetPersistentReference <> nil) and AllEqual then Result := inherited GetSelections else Result := nil; end; function TPersistentPropertyEditor.CheckNewValue(APersistent: TPersistent): boolean; begin Result:=true; end; function TPersistentPropertyEditor.ComponentsAllEqual: Boolean; // Called from AllEqual of TComponentOneFormPropertyEditor and TComponentPropertyEditor. var I: Integer; AComponent: TComponent; begin Result:=False; AComponent:=TComponent(GetObjectValue); if PropCount > 1 then for I := 1 to PropCount - 1 do if TComponent(GetObjectValueAt(I)) <> AComponent then Exit; if (PropertyHook<>nil) and PropertyHook.ComponentPropertyOnlyDesign then Result:=(AComponent=nil) or (csDesigning in AComponent.ComponentState) else Result:=true; end; function TPersistentPropertyEditor.AllEqual: Boolean; var I: Integer; LInstance: TPersistent; begin Result := False; LInstance := TPersistent(GetObjectValue); if PropCount > 1 then for I := 1 to PropCount - 1 do if TPersistent(GetObjectValueAt(I)) <> LInstance then Exit; Result := True; end; procedure TPersistentPropertyEditor.Edit; var Temp: TPersistent; Designer: TIDesigner; AComponent: TComponent; begin Temp := GetPersistentReference; if Temp is TComponent then begin AComponent:=TComponent(Temp); Designer:=FindRootDesigner(AComponent); if (Designer<>nil) and (Designer.GetShiftState * [ssCtrl, ssLeft] = [ssCtrl, ssLeft]) then Designer.SelectOnlyThisComponent(AComponent) else inherited Edit; end else inherited Edit; end; function TPersistentPropertyEditor.GetAttributes: TPropertyAttributes; var Info: PPropInfo; begin Result := [paMultiSelect]; Info:=GetPropInfo; if (Info<>nil) and Assigned(Info^.SetProc) then Result := Result + [paValueList, paSortList, paRevertable, paVolatileSubProperties] else Result := Result + [paReadOnly]; if GReferenceExpandable and (GetPersistentReference <> nil) and AllEqual then Result := Result + [paSubProperties]; end; function TPersistentPropertyEditor.GetEditLimit: Integer; begin Result := MaxIdentLength; end; function TPersistentPropertyEditor.GetValue: AnsiString; var Component: TComponent; APersistent: TPersistent; begin Result := ''; APersistent := GetPersistentReference; if APersistent is TComponent then begin Component := TComponent(APersistent); if Assigned(PropertyHook) then Result := PropertyHook.GetComponentName(Component) else begin if Assigned(Component) then Result := Component.Name; end; end else if APersistent <> nil then Result := inherited GetValue; end; procedure TPersistentPropertyEditor.GetValues(Proc: TGetStrProc); begin Proc(oisNone); if Assigned(PropertyHook) then PropertyHook.GetComponentNames(GetTypeData(GetPropType), Proc); end; procedure TPersistentPropertyEditor.SetValue(const NewValue: ansistring); var Persistent: TPersistent; begin if NewValue=GetValue then exit; Persistent := nil; if (NewValue <> '') and (NewValue<>oisNone) then begin if Assigned(PropertyHook) then begin Persistent := PropertyHook.GetComponent(NewValue); if not (Persistent is GetTypeData(GetPropType)^.ClassType) then begin raise EPropertyError.Create(oisInvalidPropertyValue); end; end; end; if GetPersistentReference=Persistent then exit; if not CheckNewValue(Persistent) then exit; SetPtrValue(Persistent); if Assigned(PropertyHook) then begin PropertyHook.ObjectReferenceChanged(Self,Persistent); end; end; { TComponentOneFormPropertyEditor } function TComponentOneFormPropertyEditor.AllEqual: Boolean; begin Result:=ComponentsAllEqual; end; procedure TComponentOneFormPropertyEditor.GetValues(Proc: TGetStrProc); procedure TraverseComponents(Root: TComponent); var i: integer; begin for i := 0 to Root.ComponentCount - 1 do if (fIgnoreClass=nil) or not (Root.Components[i] is fIgnoreClass) then Proc(Root.Components[i].Name); end; begin Proc(oisNone); if Assigned(PropertyHook) and (PropertyHook.FLookupRoot is TComponent) then TraverseComponents(TComponent(PropertyHook.FLookupRoot)); end; { TCoolBarControlPropertyEditor } constructor TCoolBarControlPropertyEditor.Create(Hook: TPropertyEditorHook; APropCount: Integer); begin inherited Create(Hook, APropCount); fIgnoreClass := TCustomCoolBar; end; { TComponentPropertyEditor } function TComponentPropertyEditor.GetComponentReference: TComponent; begin Result := TComponent(GetObjectValue); end; function TComponentPropertyEditor.AllEqual: Boolean; begin Result:=ComponentsAllEqual; end; { TInterfacePropertyEditor } function TInterfacePropertyEditor.AllEqual: Boolean; var I: Integer; Component: TComponent; begin Result := False; Component := GetComponentReference; if PropCount > 1 then for I := 1 to PropCount - 1 do if GetComponent(GetIntfValueAt(I)) <> Component then Exit; if (PropertyHook<>nil) and PropertyHook.ComponentPropertyOnlyDesign then Result:=(Component=nil) or (csDesigning in Component.ComponentState) else Result := True; end; procedure TInterfacePropertyEditor.Edit; var Temp: TPersistent; Designer: TIDesigner; AComponent: TComponent; begin Temp := GetComponentReference; if Temp is TComponent then begin AComponent:=TComponent(Temp); Designer:=FindRootDesigner(AComponent); if (Designer<>nil) and (Designer.GetShiftState * [ssCtrl, ssLeft] = [ssCtrl, ssLeft]) then Designer.SelectOnlyThisComponent(AComponent) else inherited Edit; end else inherited Edit; end; function TInterfacePropertyEditor.GetAttributes: TPropertyAttributes; var Info: PPropInfo; begin Result := [paMultiSelect]; Info:=GetPropInfo; if (Info<>nil) and Assigned(Info^.SetProc) then Result := Result + [paValueList, paSortList, paRevertable, paVolatileSubProperties] else Result := Result + [paReadOnly]; if GReferenceExpandable and (GetComponentReference <> nil) and AllEqual then Result := Result + [paSubProperties]; end; function TInterfacePropertyEditor.GetComponent(const AInterface: IInterface): TComponent; var ComponentRef: IInterfaceComponentReference; begin Result := nil; if not Assigned(AInterface) then Exit; if not Supports(AInterface, IInterfaceComponentReference, ComponentRef) then Exit; Result := ComponentRef.GetComponent; end; function TInterfacePropertyEditor.GetComponentReference: TComponent; begin Result := GetComponent(GetIntfValue); end; function TInterfacePropertyEditor.GetSelections: TPersistentSelectionList; var I: Integer; SubItem: TPersistent; begin if AllEqual then begin Result := TPersistentSelectionList.Create; try for I := 0 to PropCount - 1 do begin SubItem := GetComponent(GetIntfValueAt(I)); if Assigned(SubItem) then Result.Add(SubItem); end; except Result.Free; raise; end; end else Result := nil; end; procedure TInterfacePropertyEditor.GetValues(Proc: TGetStrProc); var ID: TGUID; procedure TraverseComponents(Root: TComponent); var i: integer; begin for i := 0 to Root.ComponentCount - 1 do if Supports(Root.Components[i], ID) then Proc(Root.Components[i].Name); end; begin ID := GetTypeData(GetPropType)^.GUID; Proc(oisNone); if Assigned(PropertyHook) and (PropertyHook.FLookupRoot is TComponent) then TraverseComponents(TComponent(PropertyHook.FLookupRoot)); end; procedure TInterfacePropertyEditor.SetValue(const NewValue: string); var Intf: IInterface; Component: TComponent; begin if NewValue = GetValue then Exit; if (NewValue = '') or (NewValue = oisNone) then Intf := nil else begin if Assigned(PropertyHook) then begin Component := PropertyHook.GetComponent(NewValue); if not Assigned(Component) or not Supports(Component, GetTypeData(GetPropType)^.GUID) then raise EPropertyError.Create(oisInvalidPropertyValue); Intf := Component; end else Intf := nil; end; SetIntfValue(Intf); end; function TInterfacePropertyEditor.GetValue: AnsiString; var Component: TComponent; begin Result := ''; Component := GetComponentReference; if Assigned(Component) then begin if Assigned(PropertyHook) then Result := PropertyHook.GetComponentName(Component) else Result := Component.Name; end; end; { TComponentNamePropertyEditor } function TComponentNamePropertyEditor.GetAttributes: TPropertyAttributes; begin Result := []; end; function TComponentNamePropertyEditor.GetEditLimit: Integer; begin Result := MaxIdentLength; end; function TComponentNamePropertyEditor.GetValue: ansistring; begin Result:=inherited GetValue; end; procedure TComponentNamePropertyEditor.SetValue(const NewValue: ansistring); begin if not IsValidIdent(NewValue) then raise Exception.Create(Format(oisComponentNameIsNotAValidIdentifier, [NewValue])); inherited SetValue(NewValue); PropertyHook.ComponentRenamed(TComponent(GetComponent(0))); end; { TDatePropertyEditor } function TDatePropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paRevertable]; end; function TDatePropertyEditor.GetValue: string; var DT: TDateTime; begin DT := TDateTime(GetFloatValue); if DT = 0.0 then Result := '' else Result := DateToStr(DT); end; procedure TDatePropertyEditor.SetValue(const Value: string); var DT: TDateTime; begin if Value = '' then DT := 0.0 else DT := StrToDate(Value); SetFloatValue(DT); end; { TTimePropertyEditor } function TTimePropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paRevertable]; end; function TTimePropertyEditor.GetValue: string; var DT: TDateTime; begin DT := TDateTime(GetFloatValue); if DT = 0.0 then Result := '' else Result := TimeToStr(DT); end; procedure TTimePropertyEditor.SetValue(const Value: string); var DT: TDateTime; begin if Value = '' then DT := 0.0 else DT := StrToTime(Value); SetFloatValue(DT); end; { TDateTimePropertyEditor } function TDateTimePropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paRevertable]; end; function TDateTimePropertyEditor.GetValue: string; var DT: TDateTime; begin DT := TDateTime(GetFloatValue); if DT = 0.0 then Result := '' else Result := DateTimeToStr(DT); end; procedure TDateTimePropertyEditor.SetValue(const Value: string); var DT: TDateTime; ok: Boolean; begin if Value = '' then DT := 0.0 else begin ok:=false; // first try date+time try DT := StrToDateTime(Value); ok:=true; except end; // then try date without time if not ok then try DT := StrToDate(Value); ok:=true; except end; // then try time without date if not ok then try DT := StrToTime(Value); ok:=true; except end; // if all fails then raise exception if not ok then StrToDateTime(Value); end; SetFloatValue(DT); end; const VarTypeStr: array[0..16] of record VarType: Word; Name: String; end = ( (VarType: varempty; Name: 'Unassigned'), (VarType: varnull; Name: 'Null'), (VarType: varsmallint; Name: 'SmallInt'), (VarType: varinteger; Name: 'Integer'), (VarType: varsingle; Name: 'Single'), (VarType: vardouble; Name: 'Double'), (VarType: varcurrency; Name: 'Currency'), (VarType: vardate; Name: 'Date'), (VarType: varolestr; Name: 'OleStr'), (VarType: varboolean; Name: 'Boolean'), (VarType: varshortint; Name: 'ShortInt'), (VarType: varbyte; Name: 'Byte'), (VarType: varword; Name: 'Word'), (VarType: varlongword; Name: 'LongWord'), (VarType: varint64; Name: 'Int64'), (VarType: varqword; Name: 'QWord'), (VarType: varstring; Name: 'String') ); function GetVarTypeName(AVarType: tvartype): String; var I: Integer; begin Result := ''; for I := Low(VarTypeStr) to High(VarTypeStr) do if VarTypeStr[I].VarType = AVarType then Exit(VarTypeStr[I].Name); end; function GetVarTypeByName(AName: String): tvartype; var I: Integer; begin Result := varempty; for I := Low(VarTypeStr) to High(VarTypeStr) do if CompareText(VarTypeStr[I].Name, AName) = 0 then Exit(VarTypeStr[I].VarType); end; type { TVarTypeProperty } TVarTypeProperty = class(TNestedProperty) function GetName: shortstring; override; function GetAttributes: TPropertyAttributes; override; procedure GetValues(Proc: TGetStrProc); override; function GetValue: ansistring; override; procedure SetValue(const NewValue: ansistring); override; end; { TVarTypeProperty } function TVarTypeProperty.GetName: shortstring; begin Result := 'Type'; end; function TVarTypeProperty.GetAttributes: TPropertyAttributes; begin Result := [paValueList]; end; procedure TVarTypeProperty.GetValues(Proc: TGetStrProc); var I: Integer; begin for I := Low(VarTypeStr) to High(VarTypeStr) do Proc(VarTypeStr[I].Name); end; function TVarTypeProperty.GetValue: ansistring; begin Result := GetVarTypeName(VarType(GetVarValue)); if Result = '' then Result := 'Unknown'; // Is there resourcestring for that? end; procedure TVarTypeProperty.SetValue(const NewValue: ansistring); var V: Variant; VT: tvartype; begin V := GetVarValue; VT := GetVarTypeByName(NewValue); case VT of varempty: VarClear(V); varnull: V := Null; else try VarCast(V, V, VT); except VarClear(V); end; end; SetVarValue(V); end; { TVariantPropertyEditor } function TVariantPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paSubProperties]; end; procedure TVariantPropertyEditor.GetProperties(Proc:TGetPropEditProc); begin Proc(TVarTypeProperty.Create(Self)); end; function TVariantPropertyEditor.GetValue: string; begin if VarType(GetVarValue) <> varnull then Result := VarToStrDef(GetVarValue, 'Unknown') // Is there resourcestring for that? else Result := '(Null)'; end; procedure TVariantPropertyEditor.SetValue(const Value: string); var V: Variant; begin try V := Value; except V := 0; // Some backup value. end; SetVarValue(V); end; { TModalResultPropertyEditor } function TModalResultPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paValueList, paRevertable]; end; function TModalResultPropertyEditor.OrdValueToVisualValue(OrdValue: longint): string; var CurValue: Longint; begin CurValue := OrdValue; case CurValue of Low(ModalResultStr)..High(ModalResultStr): Result := ModalResultStr[CurValue]; else Result := IntToStr(CurValue); end; end; procedure TModalResultPropertyEditor.GetValues(Proc: TGetStrProc); var I: Integer; begin for I := Low(ModalResultStr) to High(ModalResultStr) do Proc(ModalResultStr[I]); end; procedure TModalResultPropertyEditor.SetValue(const NewValue: ansistring); var I: Integer; begin if NewValue = '' then begin SetOrdValue(0); Exit; end; for I := Low(ModalResultStr) to High(ModalResultStr) do if CompareText(ModalResultStr[I], NewValue) = 0 then begin SetOrdValue(I); Exit; end; inherited SetValue(NewValue); end; { TShortCutPropertyEditor } const ShortCuts: array[0..135] of TShortCut = ( scNone, Byte('A') or scCtrl, Byte('B') or scCtrl, Byte('C') or scCtrl, Byte('D') or scCtrl, Byte('E') or scCtrl, Byte('F') or scCtrl, Byte('G') or scCtrl, Byte('H') or scCtrl, Byte('I') or scCtrl, Byte('J') or scCtrl, Byte('K') or scCtrl, Byte('L') or scCtrl, Byte('M') or scCtrl, Byte('N') or scCtrl, Byte('O') or scCtrl, Byte('P') or scCtrl, Byte('Q') or scCtrl, Byte('R') or scCtrl, Byte('S') or scCtrl, Byte('T') or scCtrl, Byte('U') or scCtrl, Byte('V') or scCtrl, Byte('W') or scCtrl, Byte('X') or scCtrl, Byte('Y') or scCtrl, Byte('Z') or scCtrl, Byte('A') or scMeta, Byte('B') or scMeta, Byte('C') or scMeta, Byte('D') or scMeta, Byte('E') or scMeta, Byte('F') or scMeta, Byte('G') or scMeta, Byte('H') or scMeta, Byte('I') or scMeta, Byte('J') or scMeta, Byte('K') or scMeta, Byte('L') or scMeta, Byte('M') or scMeta, Byte('N') or scMeta, Byte('O') or scMeta, Byte('P') or scMeta, Byte('Q') or scMeta, Byte('R') or scMeta, Byte('S') or scMeta, Byte('T') or scMeta, Byte('U') or scMeta, Byte('V') or scMeta, Byte('W') or scMeta, Byte('X') or scMeta, Byte('Y') or scMeta, Byte('Z') or scMeta, Byte('A') or scCtrl or scAlt, Byte('B') or scCtrl or scAlt, Byte('C') or scCtrl or scAlt, Byte('D') or scCtrl or scAlt, Byte('E') or scCtrl or scAlt, Byte('F') or scCtrl or scAlt, Byte('G') or scCtrl or scAlt, Byte('H') or scCtrl or scAlt, Byte('I') or scCtrl or scAlt, Byte('J') or scCtrl or scAlt, Byte('K') or scCtrl or scAlt, Byte('L') or scCtrl or scAlt, Byte('M') or scCtrl or scAlt, Byte('N') or scCtrl or scAlt, Byte('O') or scCtrl or scAlt, Byte('P') or scCtrl or scAlt, Byte('Q') or scCtrl or scAlt, Byte('R') or scCtrl or scAlt, Byte('S') or scCtrl or scAlt, Byte('T') or scCtrl or scAlt, Byte('U') or scCtrl or scAlt, Byte('V') or scCtrl or scAlt, Byte('W') or scCtrl or scAlt, Byte('X') or scCtrl or scAlt, Byte('Y') or scCtrl or scAlt, Byte('Z') or scCtrl or scAlt, VK_F1, VK_F2, VK_F3, VK_F4, VK_F5, VK_F6, VK_F7, VK_F8, VK_F9, VK_F10, VK_F11, VK_F12, VK_F1 or scCtrl, VK_F2 or scCtrl, VK_F3 or scCtrl, VK_F4 or scCtrl, VK_F5 or scCtrl, VK_F6 or scCtrl, VK_F7 or scCtrl, VK_F8 or scCtrl, VK_F9 or scCtrl, VK_F10 or scCtrl, VK_F11 or scCtrl, VK_F12 or scCtrl, VK_F1 or scShift, VK_F2 or scShift, VK_F3 or scShift, VK_F4 or scShift, VK_F5 or scShift, VK_F6 or scShift, VK_F7 or scShift, VK_F8 or scShift, VK_F9 or scShift, VK_F10 or scShift, VK_F11 or scShift, VK_F12 or scShift, VK_F1 or scShift or scCtrl, VK_F2 or scShift or scCtrl, VK_F3 or scShift or scCtrl, VK_F4 or scShift or scCtrl, VK_F5 or scShift or scCtrl, VK_F6 or scShift or scCtrl, VK_F7 or scShift or scCtrl, VK_F8 or scShift or scCtrl, VK_F9 or scShift or scCtrl, VK_F10 or scShift or scCtrl, VK_F11 or scShift or scCtrl, VK_F12 or scShift or scCtrl, VK_INSERT, VK_INSERT or scShift, VK_INSERT or scCtrl, VK_DELETE, VK_DELETE or scShift, VK_DELETE or scCtrl, VK_BACK or scAlt, VK_BACK or scShift or scAlt, VK_ESCAPE); procedure TShortCutPropertyEditor.Edit; var Box: TShortCutGrabBox; OldValue, NewValue: TShortCut; OldKey: Word; OldShift: TShiftState; Dlg: TForm; BtnPanel: TButtonPanel; begin Dlg:=TForm.Create(Application); try Dlg.BorderIcons:=[biSystemMenu]; Dlg.Caption:=oisSelectShortCut; Dlg.Position:=poScreenCenter; Dlg.Constraints.MinWidth:=350; Dlg.Constraints.MinHeight:=30; Dlg.Width:=350; Dlg.Height:=120; Box:=TShortCutGrabBox.Create(Dlg); Box.BorderSpacing.Around:=6; Box.Parent:=Dlg; Box.Align:=alClient; OldValue := TShortCut(GetOrdValue); ShortCutToKey(OldValue,OldKey,OldShift); Box.ShiftState:=OldShift; Box.Key:=OldKey; BtnPanel:=TButtonPanel.Create(Dlg); BtnPanel.Parent:=Dlg; BtnPanel.Align:=alBottom; BtnPanel.ShowButtons:=[pbOk,pbCancel]; Dlg.AutoSize:=true; if Dlg.ShowModal=mrOk then begin NewValue:=Menus.ShortCut(Box.Key,Box.ShiftState); if OldValue<>NewValue then SetOrdValue(NewValue); end; finally Dlg.Free; end; end; function TShortCutPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paValueList, paRevertable, paDialog]; end; function TShortCutPropertyEditor.OrdValueToVisualValue(OrdValue: longint): string; var CurValue: TShortCut; begin CurValue := TShortCut(OrdValue); if CurValue = scNone then Result := oisNone else Result := ShortCutToText(CurValue); end; procedure TShortCutPropertyEditor.GetValues(Proc: TGetStrProc); var I: Integer; begin Proc(oisNone); {$IFDEF Darwin} for I := 1 to High(ShortCuts) do Proc(ShortCutToText(ShortCuts[I])); {$ELSE} for I := 1 to 26 do Proc(ShortCutToText(ShortCuts[I])); for I := 53 to High(ShortCuts) do Proc(ShortCutToText(ShortCuts[I])); {$ENDIF} end; procedure TShortCutPropertyEditor.SetValue(const Value: string); var NewValue: TShortCut; begin NewValue := 0; if (Value <> '') and (AnsiCompareText(Value, oisNone) <> 0) then begin NewValue := TextToShortCut(Value); if NewValue = 0 then raise EPropertyError.Create(oisInvalidPropertyValue); end; SetOrdValue(NewValue); end; { TTabOrderPropertyEditor } function TTabOrderPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := []; end; { TCaptionPropertyEditor } function TCaptionPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paAutoUpdate, paRevertable]; end; { TMenuItemCaptionEditor } procedure TMenuItemCaptionEditor.SetValue(const NewValue: ansistring); var Designer: TIDesigner; MI: TMenuItem; Inst: TPersistent; begin Inst := GetComponent(0); if (NewValue = cLineCaption) and (Inst is TMenuItem) then begin MI := TMenuItem(Inst); if AnsiStartsStr('MenuItem', MI.Name) then begin Designer:=FindRootDesigner(MI); if Designer<>nil then MI.Name:=Designer.UniqueName('Separator'); end; end; SetStrValue(NewValue); end; { TStringsPropertyEditor } procedure TStringsPropertyEditor.Edit; var TheDialog: TStringsPropEditorDlg; begin TheDialog := CreateDlg(TStrings(GetObjectValue)); try if (TheDialog.ShowModal = mrOK) then SetPtrValue(TheDialog.Memo.Lines); finally TheDialog.Free; end; end; function TStringsPropertyEditor.CreateDlg(s: TStrings): TStringsPropEditorDlg; begin Result := TStringsPropEditorDlg.Create(Application); Result.Editor := Self; Result.Memo.Text := s.Text; Result.MemoChange(nil); // force call OnChange event end; function TStringsPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paDialog, paRevertable, paReadOnly]; end; { TValueListPropertyEditor } procedure TValueListPropertyEditor.Edit; var TheDialog: TKeyValPropEditorDlg; begin TheDialog := CreateDlg(TStrings(GetObjectValue)); try if (TheDialog.ShowModal = mrOK) then SetPtrValue(TheDialog.ValueListEdit.Strings); finally TheDialog.Free; end; end; function TValueListPropertyEditor.CreateDlg(s: TStrings): TKeyValPropEditorDlg; begin Result := TKeyValPropEditorDlg.Create(Application); Result.Editor := Self; Result.ValueListEdit.Strings.Assign(s); Result.ValueListEdit.Invalidate; end; function TValueListPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paDialog, paRevertable, paReadOnly]; end; { TStringMultilinePropertyEditor } procedure TStringMultilinePropertyEditor.Edit; var TheDialog : TStringsPropEditorDlg; AString : string; LineEndPos: Integer; begin AString := GetStrValue; TheDialog := TStringsPropEditorDlg.Create(nil); try TheDialog.Editor := Self; TheDialog.Memo.Text := AString; TheDialog.MemoChange(nil); if (TheDialog.ShowModal = mrOK) then begin AString := TheDialog.Memo.Text; LineEndPos := Length(AString) - Length(LineEnding) + 1; //erase the last lineending if any if Copy(AString, LineEndPos, Length(LineEnding)) = LineEnding then Delete(AString, LineEndPos, Length(LineEnding)); SetStrValue(AString); end; finally TheDialog.Free; end; end; function TStringMultilinePropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paDialog, paRevertable, paAutoUpdate]; end; { TCursorPropertyEditor } function TCursorPropertyEditor.GetAttributes: TPropertyAttributes; begin Result := [paMultiSelect, paSortList, paValueList, paRevertable]; end; function TCursorPropertyEditor.OrdValueToVisualValue(OrdValue: longint): string; begin Result := CursorToString(TCursor(OrdValue)); end; procedure TCursorPropertyEditor.GetValues(Proc: TGetStrProc); begin GetCursorValues(Proc); end; procedure TCursorPropertyEditor.SetValue(const NewValue: ansistring); var CValue: Longint; begin CValue:=0; if IdentToCursor(NewValue, CValue) then SetOrdValue(CValue) else inherited SetValue(NewValue); end; { TFileNamePropertyEditor } function TFileNamePropertyEditor.GetAttributes: TPropertyAttributes; begin Result:=[paDialog,paRevertable]; end; procedure TFileNamePropertyEditor.Edit; begin With CreateFileDialog do Try Filter:=GetFilter; Options:=GetDialogOptions; FileName:=GetStrValue; InitialDir:=GetInitialDirectory; Title:=GetDialogTitle; If Execute then SetFilename(Filename); Finally Free; end; end; function TFileNamePropertyEditor.GetFilter: String; begin Result:=oisAllFiles+' ('+GetAllFilesMask+')|'+GetAllFilesMask; end; function TFileNamePropertyEditor.GetDialogOptions: TOpenOptions; begin Result:=DefaultOpenDialogOptions; end; function TFileNamePropertyEditor.GetDialogTitle: string; begin Result:=oisSelectAFile; end; function TFileNamePropertyEditor.GetInitialDirectory: string; begin Result:=''; end; procedure TFileNamePropertyEditor.SetFilename(const Filename: string); begin SetStrValue(Filename); end; function TFileNamePropertyEditor.CreateFileDialog: TOpenDialog; begin Result:=TOpenDialog.Create(nil); end; { TDirectoryPropertyEditor } function TDirectoryPropertyEditor.CreateFileDialog: TOpenDialog; begin Result:=TSelectDirectoryDialog.Create(nil); Result.Options:=Result.Options+[ofFileMustExist]; end; { TURLPropertyEditor } procedure TURLPropertyEditor.SetFilename(const Filename: string); function FilenameToURL(const Filename: string): string; var i: Integer; begin Result:=Filename; {$push} {$warnings off} if PathDelim<>'/' then for i:=1 to length(Result) do if Result[i]=PathDelim then Result[i]:='/'; {$pop} if Result<>'' then Result:='file://'+Result; end; begin inherited SetFilename(FilenameToURL(Filename)); end; { TURLDirectoryPropertyEditor } function TURLDirectoryPropertyEditor.CreateFileDialog: TOpenDialog; begin Result:=TSelectDirectoryDialog.Create(nil); Result.Options:=Result.Options+[ofFileMustExist]; end; { TFileDlgFilterProperty } function TFileDlgFilterProperty.GetAttributes: TPropertyAttributes; begin Result:=inherited GetAttributes + [paDialog]; end; procedure TFileDlgFilterProperty.Edit; begin with TFileFilterPropEditForm.Create(Application) do try Filter:=GetStrValue; if ShowModal=mrOk then begin SetStrValue(Filter); Modified; end; finally Free; end; end; { TSessionPropertiesPropertyEditor } function TSessionPropertiesPropertyEditor.GetAttributes: TPropertyAttributes; begin Result:=[paDialog,paRevertable,paReadOnly]; end; procedure TSessionPropertiesPropertyEditor.Edit; begin With TSelectPropertiesForm.Create(Application) do Try PropertyComponent:=GetComponent(0) as TComponent; SelectedProperties:=GetStrValue; Caption:=Format(oisPropertiesOf, [TComponent(GetComponent(0)).Name]); If (ShowModal=mrOK) then SetStrValue(SelectedProperties); Finally Free; end; end; { TConstraintsPropertyEditor } function TConstraintsPropertyEditor.GetVerbCount: Integer; begin Result:=2; end; function TConstraintsPropertyEditor.GetVerb(Index: Integer): string; var s: String; c: TControl; begin case Index of 0: s := oisSetMaxConstraints; 1: s := oisSetMinConstraints; else s := ''; end; c := GetComponent(0) as TControl; Result := Format(s, [c.Height, c.Width]); end; procedure TConstraintsPropertyEditor.PrepareItem(Index: Integer; const AnItem: TMenuItem); var c: TControl; begin c := GetComponent(0) as TControl; case Index of 0: begin // set max constraints AnItem.Enabled := (c.Constraints.MaxHeight<>c.Height) or (c.Constraints.MaxWidth<>c.Width); AnItem.Hint := oisSetMaxConstraintsHint; end; 1: begin // set min constraints AnItem.Enabled := (c.Constraints.MinHeight<>c.Height) or (c.Constraints.MinWidth<>c.Width); AnItem.Hint := oisSetMinConstraintsHint; end; end; end; procedure TConstraintsPropertyEditor.ExecuteVerb(Index: Integer); var c: TControl; begin c := GetComponent(0) as TControl; case Index of 0: begin c.Constraints.MaxHeight := c.Height; c.Constraints.MaxWidth := c.Width; end; 1: begin c.Constraints.MinHeight := c.Height; c.Constraints.MinWidth := c.Width; end; end; end; //============================================================================== { TPropertyEditorHook } function TPropertyEditorHook.CreateMethod(const aName: ShortString; ATypeInfo: PTypeInfo; APersistent: TPersistent; const APropertyPath: string ): TMethod; var i: Integer; Handler: TPropHookCreateMethod; begin Result.Code := nil; Result.Data := nil; if IsValidIdent(aName,true,true) and Assigned(ATypeInfo) then begin i := GetHandlerCount(htCreateMethod); while GetNextHandlerIndex(htCreateMethod, i) do begin Handler := TPropHookCreateMethod(FHandlers[htCreateMethod][i]); Result := Handler(aName, ATypeInfo, APersistent, APropertyPath); if Assigned(Result.Data) or Assigned(Result.Code) then exit; end; end; end; function TPropertyEditorHook.GetMethodName(const Method: TMethod; PropOwner: TObject): String; var i: Integer; begin i:=GetHandlerCount(htGetMethodName); if GetNextHandlerIndex(htGetMethodName,i) then begin Result:=TPropHookGetMethodName(FHandlers[htGetMethodName][i])(Method,PropOwner,LookupRoot); end else begin // search the method name with the given code pointer if Assigned(Method.Code) then begin if Method.Data<>nil then begin Result:=TObject(Method.Data).MethodName(Method.Code); if Result='' then Result:=''; end else Result:=''; end else Result:=''; end; end; procedure TPropertyEditorHook.GetMethods(TypeData: PTypeData; const Proc: TGetStrProc); var i: Integer; begin i:=GetHandlerCount(htGetMethods); while GetNextHandlerIndex(htGetMethods,i) do TPropHookGetMethods(FHandlers[htGetMethods][i])(TypeData,Proc); end; procedure TPropertyEditorHook.GetCompatibleMethods(InstProp: PInstProp; const Proc: TGetStrProc); var i: Integer; begin i:=GetHandlerCount(htGetCompatibleMethods); while GetNextHandlerIndex(htGetCompatibleMethods,i) do TPropHookGetCompatibleMethods(FHandlers[htGetCompatibleMethods][i])(InstProp,Proc); end; function TPropertyEditorHook.MethodExists(const aName: String; TypeData: PTypeData; var MethodIsCompatible, MethodIsPublished, IdentIsMethod: boolean):boolean; var i: Integer; Handler: TPropHookMethodExists; begin // check if a published method with given aName exists in LookupRoot Result:=IsValidIdent(aName) and Assigned(FLookupRoot); if not Result then exit; i:=GetHandlerCount(htMethodExists); if i>=0 then begin while GetNextHandlerIndex(htMethodExists,i) do begin Handler:=TPropHookMethodExists(FHandlers[htMethodExists][i]); Result:=Handler(aName,TypeData, MethodIsCompatible,MethodIsPublished,IdentIsMethod); end; end else begin Result:=(LookupRoot.MethodAddress(aName)<>nil); MethodIsCompatible:=Result; MethodIsPublished:=Result; IdentIsMethod:=Result; end; end; function TPropertyEditorHook.CompatibleMethodExists(const aName: String; InstProp: PInstProp; out MethodIsCompatible, MethodIsPublished, IdentIsMethod: boolean): boolean; var i: Integer; Handler: TPropHookCompatibleMethodExists; begin MethodIsCompatible:=false; MethodIsPublished:=false; IdentIsMethod:=false; // check if a published method with given aName exists in LookupRoot Result:=IsValidIdent(aName) and Assigned(FLookupRoot); if not Result then exit; i:=GetHandlerCount(htCompatibleMethodExists); if i>=0 then begin while GetNextHandlerIndex(htCompatibleMethodExists,i) do begin Handler:=TPropHookCompatibleMethodExists(FHandlers[htCompatibleMethodExists][i]); Result:=Handler(aName,InstProp, MethodIsCompatible,MethodIsPublished,IdentIsMethod); end; end else begin Result:=(LookupRoot.MethodAddress(aName)<>nil); MethodIsCompatible:=Result; MethodIsPublished:=Result; IdentIsMethod:=Result; end; end; procedure TPropertyEditorHook.RenameMethod(const CurName, NewName: String); // rename published method in LookupRoot object and source var i: Integer; begin i:=GetHandlerCount(htRenameMethod); while GetNextHandlerIndex(htRenameMethod,i) do TPropHookRenameMethod(FHandlers[htRenameMethod][i])(CurName,NewName); end; procedure TPropertyEditorHook.ShowMethod(const aName: String); // jump cursor to published method body var i: Integer; begin i:=GetHandlerCount(htShowMethod); while GetNextHandlerIndex(htShowMethod,i) do TPropHookShowMethod(FHandlers[htShowMethod][i])(aName); end; function TPropertyEditorHook.MethodFromAncestor(const Method: TMethod): boolean; var AncestorClass: TClass; i: Integer; Handler: TPropHookMethodFromAncestor; begin // check if given Method is not in LookupRoot source, // but in one of its ancestors i := GetHandlerCount(htMethodFromAncestor); if GetNextHandlerIndex(htMethodFromAncestor, i) then begin Handler := TPropHookMethodFromAncestor(FHandlers[htMethodFromAncestor][i]); Result := Handler(Method); end else begin Result := Assigned(Method.Data) and Assigned(Method.Code); if Result then begin AncestorClass := TObject(Method.Data).ClassParent; Result := Assigned(AncestorClass) and (AncestorClass.MethodName(Method.Code)<>''); end; end; end; function TPropertyEditorHook.MethodFromLookupRoot(const Method: TMethod ): boolean; var Root: TPersistent; i: Integer; Handler: TPropHookMethodFromLookupRoot; begin // check if given Method is in LookupRoot source, Root:=LookupRoot; if Root=nil then exit(false); i := GetHandlerCount(htMethodFromLookupRoot); if GetNextHandlerIndex(htMethodFromLookupRoot, i) then begin Handler := TPropHookMethodFromLookupRoot(FHandlers[htMethodFromLookupRoot][i]); Result := Handler(Method); end else begin Result := (TObject(Method.Data)=Root) and Assigned(Method.Code) and (Root.MethodName(Method.Code)<>''); end; end; procedure TPropertyEditorHook.ChainCall(const AMethodName, InstanceName, InstanceMethod: ShortString; TypeData: PTypeData); var i: Integer; Handler: TPropHookChainCall; begin i:=GetHandlerCount(htChainCall); while GetNextHandlerIndex(htChainCall,i) do begin Handler:=TPropHookChainCall(FHandlers[htChainCall][i]); Handler(AMethodName,InstanceName,InstanceMethod,TypeData); end; end; function TPropertyEditorHook.GetComponent(const ComponentPath: string): TComponent; var i: Integer; begin Result := nil; if not Assigned(LookupRoot) then Exit; i := GetHandlerCount(htGetComponent); while GetNextHandlerIndex(htGetComponent, i) and (Result = nil) do Result := TPropHookGetComponent(FHandlers[htGetComponent][i])(ComponentPath); // Note: TWriter only allows pascal identifiers for names, but in general // there is no restriction. if (Result = nil) and (LookupRoot is TComponent) then Result := TComponent(LookupRoot).FindComponent(ComponentPath); end; function TPropertyEditorHook.GetComponentName(AComponent: TComponent): String; var i: Integer; CompName, OwnerName: String; Handler: TPropHookGetComponentName; begin Result := ''; if AComponent = nil then Exit; i := GetHandlerCount(htGetComponentName); while GetNextHandlerIndex(htGetComponentName, i) and (Result = '') do begin Handler := TPropHookGetComponentName(FHandlers[htGetComponentName][i]); Result := Handler(AComponent); end; if Result = '' then begin CompName := AComponent.Name; if (AComponent.Owner<>LookupRoot) and (AComponent.Owner<>nil) then OwnerName := AComponent.Owner.Name; { if CompName='' then DebugLn('TPropertyEditorHook.GetComponentName: AComponent.Name is empty, '+ 'AComponent.Owner.Name="' + OwnerName+'".'); if OwnerName='' then DebugLn('TPropertyEditorHook.GetComponentName: AComponent.Owner.Name is empty.'); } Result := CompName; if OwnerName<>'' then begin Result := OwnerName; if CompName<>'' then Result := Result+'.'+CompName; end; end; end; procedure TPropertyEditorHook.GetComponentNames(TypeData: PTypeData; const Proc: TGetStrProc); procedure TraverseComponents(Root: TComponent); var i: integer; begin for i := 0 to Root.ComponentCount - 1 do if (Root.Components[i] is TypeData^.ClassType) then Proc(Root.Components[i].Name); end; var i: integer; Handler: TPropHookGetComponentNames; begin if not Assigned(LookupRoot) then Exit; i := GetHandlerCount(htGetComponentNames); if i > 0 then begin while GetNextHandlerIndex(htGetComponentNames, i) do begin Handler := TPropHookGetComponentNames(FHandlers[htGetComponentNames][i]); Handler(TypeData, Proc); end; end else if LookupRoot is TComponent then // No handler -> only traverse local form/datamodule components TraverseComponents(TComponent(LookupRoot)); end; function TPropertyEditorHook.GetRootClassName: ShortString; var i: Integer; Handler: TPropHookGetRootClassName; begin Result := ''; i := GetHandlerCount(htGetRootClassName); while GetNextHandlerIndex(htGetRootClassName, i) and (Result = '') do begin Handler := TPropHookGetRootClassName(FHandlers[htGetRootClassName][i]); Result := Handler(); end; if (Result='') and Assigned(LookupRoot) then Result := LookupRoot.ClassName; end; function TPropertyEditorHook.GetAncestorInstance(const InstProp: TInstProp; out AncestorInstProp: TInstProp): boolean; var i: Integer; Handler: TPropHookGetAncestorInstProp; begin Result:=false; if (InstProp.Instance=nil) or (InstProp.PropInfo=nil) then exit; i := GetHandlerCount(htGetAncestorInstProp); while GetNextHandlerIndex(htGetAncestorInstProp, i) and (not Result) do begin Handler := TPropHookGetAncestorInstProp(FHandlers[htGetAncestorInstProp][i]); Result := Handler(InstProp,AncestorInstProp); end; end; function TPropertyEditorHook.AddClicked(ADesigner: TIDesigner; MouseDownComponent: TComponent; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; var AComponentClass: TComponentClass; var NewParent: TComponent ): boolean; var i: Integer; Handler: TPropHookAddClicked; begin i := GetHandlerCount(htAddClicked); while GetNextHandlerIndex(htAddClicked, i) do begin Handler := TPropHookAddClicked(FHandlers[htAddClicked][i]); Result := Handler(ADesigner,MouseDownComponent,Button,Shift,X,Y, AComponentClass,NewParent); if not Result then exit; if AComponentClass=nil then exit(false); end; Result := True; end; function TPropertyEditorHook.BeforeAddPersistent(Sender: TObject; APersistentClass: TPersistentClass; Parent: TPersistent): boolean; var i: Integer; Handler: TPropHookBeforeAddPersistent; begin i := GetHandlerCount(htBeforeAddPersistent); while GetNextHandlerIndex(htBeforeAddPersistent, i) do begin Handler := TPropHookBeforeAddPersistent(FHandlers[htBeforeAddPersistent][i]); Result := Handler(Sender,APersistentClass,Parent); if not Result then exit; end; Result := True; end; procedure TPropertyEditorHook.ComponentRenamed(AComponent: TComponent); var i: Integer; begin i := GetHandlerCount(htComponentRenamed); while GetNextHandlerIndex(htComponentRenamed, i) do TPropHookComponentRenamed(FHandlers[htComponentRenamed][i])(AComponent); end; procedure TPropertyEditorHook.PersistentAdded(APersistent: TPersistent; Select: boolean); var i: Integer; begin i := GetHandlerCount(htPersistentAdded); while GetNextHandlerIndex(htPersistentAdded, i) do TPropHookPersistentAdded(FHandlers[htPersistentAdded][i])(APersistent, Select); end; procedure TPropertyEditorHook.PersistentDeleting(APersistent: TPersistent); // call this to tell all IDE parts to remove all references from the APersistent var i: Integer; begin i:=GetHandlerCount(htPersistentDeleting); while GetNextHandlerIndex(htPersistentDeleting,i) do TPropHookPersistentDel(FHandlers[htPersistentDeleting][i])(APersistent); end; procedure TPropertyEditorHook.PersistentDeleted(APersistent: TPersistent); var i: Integer; begin i:=GetHandlerCount(htPersistentDeleted); while GetNextHandlerIndex(htPersistentDeleted,i) do TPropHookPersistentDel(FHandlers[htPersistentDeleted][i])(APersistent); end; procedure TPropertyEditorHook.DeletePersistent(var APersistent: TPersistent); // Call this to actually free APersistent // One of the hooks will free it. var i: Integer; begin if APersistent=nil then exit; i:=GetHandlerCount(htDeletePersistent); if i>0 then begin while (APersistent<>nil) and GetNextHandlerIndex(htDeletePersistent,i) do TPropHookDeletePersistent(FHandlers[htDeletePersistent][i])(APersistent); end else FreeThenNil(APersistent); end; procedure TPropertyEditorHook.GetSelection(const ASelection: TPersistentSelectionList); var i: Integer; Handler: TPropHookGetSelection; begin if ASelection=nil then exit; ASelection.Clear; i:=GetHandlerCount(htGetSelectedPersistents); while GetNextHandlerIndex(htGetSelectedPersistents,i) do begin Handler:=TPropHookGetSelection(FHandlers[htGetSelectedPersistents][i]); Handler(ASelection); end; end; procedure TPropertyEditorHook.SetSelection( const ASelection: TPersistentSelectionList); var i: Integer; Handler: TPropHookSetSelection; APersistent: TPersistent; NewLookupRoot: TPersistent; begin // update LookupRoot NewLookupRoot:=LookupRoot; if (ASelection<>nil) and (ASelection.Count>0) then begin APersistent:=ASelection[0]; if APersistent<>nil then NewLookupRoot:=GetLookupRootForComponent(APersistent); end; LookupRoot:=NewLookupRoot; // set selection if ASelection=nil then exit; //debulgn(['TPropertyEditorHook.SetSelection A ASelection.Count=',ASelection.Count]); i:=GetHandlerCount(htSetSelectedPersistents); while GetNextHandlerIndex(htSetSelectedPersistents,i) do begin Handler:=TPropHookSetSelection(FHandlers[htSetSelectedPersistents][i]); Handler(ASelection); end; //debugln(['TPropertyEditorHook.SetSelection END ASelection.Count=',ASelection.Count]); end; procedure TPropertyEditorHook.Unselect(const APersistent: TPersistent); var Selection: TPersistentSelectionList; begin Selection := TPersistentSelectionList.Create; try GetSelection(Selection); if Selection.IndexOf(APersistent)>=0 then begin Selection.Remove(APersistent); SetSelection(Selection); end; finally Selection.Free; end; end; function TPropertyEditorHook.IsSelected(const APersistent: TPersistent): boolean; var Selection: TPersistentSelectionList; begin Selection := TPersistentSelectionList.Create; try GetSelection(Selection); Result:=Selection.IndexOf(APersistent)>=0; finally Selection.Free; end; end; procedure TPropertyEditorHook.SelectOnlyThis(const APersistent: TPersistent); var NewSelection: TPersistentSelectionList; begin NewSelection := TPersistentSelectionList.Create; try if APersistent<>nil then NewSelection.Add(APersistent); SetSelection(NewSelection); finally NewSelection.Free; end; end; procedure TPropertyEditorHook.AddDependency(const AClass: TClass; const AnUnitname: shortstring); var i: Integer; begin i:=GetHandlerCount(htAddDependency); while GetNextHandlerIndex(htAddDependency,i) do TPropHookAddDependency(FHandlers[htAddDependency][i])(AClass,AnUnitName); end; function TPropertyEditorHook.GetObject(const aName: ShortString): TPersistent; var i: Integer; begin Result:=nil; i:=GetHandlerCount(htGetObject); while GetNextHandlerIndex(htGetObject,i) and (Result=nil) do Result:=TPropHookGetObject(FHandlers[htGetObject][i])(aName); end; function TPropertyEditorHook.GetObjectName(Instance: TPersistent; AOwnerComp: TComponent): String; var i: Integer; begin Result:=''; i:=GetHandlerCount(htGetObjectName); if i>0 then begin while GetNextHandlerIndex(htGetObjectName,i) and (Result='') do Result:=TPropHookGetObjectName(FHandlers[htGetObject][i])(Instance); end else if Instance is TComponent then Result:=TComponent(Instance).Name else if instance is TCollectionItem then Result:=TCollectionItem(Instance).GetNamePath else begin Assert(Assigned(AOwnerComp),'TPropertyEditorHook.GetObjectName: AOwnerComp not assigned.'); Result:=AOwnerComp.Name + ClassNameToComponentName(Instance.ClassName); end; end; procedure TPropertyEditorHook.GetObjectNames(TypeData: PTypeData; const Proc: TGetStrProc); var i: Integer; begin i:=GetHandlerCount(htGetObjectNames); while GetNextHandlerIndex(htGetObjectNames,i) do TPropHookGetObjectNames(FHandlers[htGetObjectNames][i])(TypeData,Proc); end; procedure TPropertyEditorHook.ObjectReferenceChanged(Sender: TObject; NewObject: TPersistent); var i: Integer; begin i:=GetHandlerCount(htObjectPropertyChanged); while GetNextHandlerIndex(htObjectPropertyChanged,i) do TPropHookObjectPropertyChanged(FHandlers[htObjectPropertyChanged][i])( Sender,NewObject); end; procedure TPropertyEditorHook.Modified(Sender: TObject; PropName: ShortString); var i: Integer; AForm: TCustomForm; Editor: TPropertyEditor; List: TFPList; APersistent: TPersistent; ARoot: TPersistent; begin i := GetHandlerCount(htModified); while GetNextHandlerIndex(htModified,i) do TPropHookModified(FHandlers[htModified][i])(Sender); if PropName>'' then begin i := GetHandlerCount(htModifiedWithName); while GetNextHandlerIndex(htModifiedWithName,i) do TPropHookModifiedWithName(FHandlers[htModifiedWithName][i])(Sender, PropName); end; if Sender is TPropertyEditor then begin // mark the designer form of every selected persistent Editor := TPropertyEditor(Sender); List := TFPList.Create; try for i := 0 to Editor.PropCount - 1 do begin // for every selected persistent ... APersistent := Editor.GetComponent(i); if APersistent = nil then Continue; if List.IndexOf(APersistent) >= 0 then Continue; List.Add(APersistent); // ... get the lookuproot ... ARoot := GetLookupRootForComponent(APersistent); if ARoot = nil then Continue; if (ARoot <> APersistent) and (List.IndexOf(ARoot) >= 0) then Continue; List.Add(ARoot); if ARoot is TControl then TControl(ARoot).Invalidate; // ... get the designer ... AForm := GetDesignerForm(ARoot); if Assigned(AForm) and Assigned(AForm.Designer) then AForm.Designer.Modified; // ... and mark it modified end; finally List.Free; end; end else if Assigned(FLookupRoot) then begin AForm := GetDesignerForm(FLookupRoot); if Assigned(AForm) and Assigned(AForm.Designer) then AForm.Designer.Modified; end; end; procedure TPropertyEditorHook.DesignerMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var i: Integer; Handler: TMouseEvent; begin i := GetHandlerCount(htDesignerMouseDown); while GetNextHandlerIndex(htDesignerMouseDown, i) do begin Handler := TMouseEvent(FHandlers[htDesignerMouseDown][i]); Handler(Sender, Button, Shift, X, Y); end; end; procedure TPropertyEditorHook.DesignerMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var i: Integer; Handler: TMouseEvent; begin i := GetHandlerCount(htDesignerMouseUp); while GetNextHandlerIndex(htDesignerMouseUp, i) do begin Handler := TMouseEvent(FHandlers[htDesignerMouseUp][i]); Handler(Sender, Button, Shift, X, Y); end; end; procedure TPropertyEditorHook.Revert(Instance:TPersistent; PropInfo:PPropInfo); var i: Integer; begin i:=GetHandlerCount(htRevert); while GetNextHandlerIndex(htRevert,i) do TPropHookRevert(FHandlers[htRevert][i])(Instance,PropInfo); end; procedure TPropertyEditorHook.RefreshPropertyValues; var i: Integer; begin i:=GetHandlerCount(htRefreshPropertyValues); while GetNextHandlerIndex(htRefreshPropertyValues,i) do TPropHookRefreshPropertyValues(FHandlers[htRefreshPropertyValues][i])(); end; function TPropertyEditorHook.GetCheckboxForBoolean: Boolean; var i: Integer; begin Result:=False; i:=GetHandlerCount(htGetCheckboxForBoolean); if i > 0 then TPropHookGetCheckboxForBoolean(FHandlers[htGetCheckboxForBoolean][0])(Result); end; procedure TPropertyEditorHook.RemoveAllHandlersForObject(const HandlerObject: TObject); var HookType: TPropHookType; begin for HookType:=Low(FHandlers) to High(FHandlers) do if FHandlers[HookType]<>nil then FHandlers[HookType].RemoveAllMethodsOfObject(HandlerObject); end; procedure TPropertyEditorHook.AddHandlerChangeLookupRoot( const OnChangeLookupRoot: TPropHookChangeLookupRoot); begin AddHandler(htChangeLookupRoot,TMethod(OnChangeLookupRoot)); end; procedure TPropertyEditorHook.RemoveHandlerChangeLookupRoot( const OnChangeLookupRoot: TPropHookChangeLookupRoot); begin RemoveHandler(htChangeLookupRoot,TMethod(OnChangeLookupRoot)); end; procedure TPropertyEditorHook.AddHandlerCreateMethod( const OnCreateMethod: TPropHookCreateMethod); begin AddHandler(htCreateMethod,TMethod(OnCreateMethod)); end; procedure TPropertyEditorHook.RemoveHandlerCreateMethod( const OnCreateMethod: TPropHookCreateMethod); begin RemoveHandler(htCreateMethod,TMethod(OnCreateMethod)); end; procedure TPropertyEditorHook.AddHandlerGetMethodName( const OnGetMethodName: TPropHookGetMethodName); begin AddHandler(htGetMethodName,TMethod(OnGetMethodName)); end; procedure TPropertyEditorHook.RemoveHandlerGetMethodName( const OnGetMethodName: TPropHookGetMethodName); begin RemoveHandler(htGetMethodName,TMethod(OnGetMethodName)); end; procedure TPropertyEditorHook.AddHandlerGetMethods( const OnGetMethods: TPropHookGetMethods); begin AddHandler(htGetMethods,TMethod(OnGetMethods)); end; procedure TPropertyEditorHook.RemoveHandlerGetMethods( const OnGetMethods: TPropHookGetMethods); begin RemoveHandler(htGetMethods,TMethod(OnGetMethods)); end; procedure TPropertyEditorHook.AddHandlerCompatibleMethodExists( const OnMethodExists: TPropHookCompatibleMethodExists); begin AddHandler(htCompatibleMethodExists,TMethod(OnMethodExists)); end; procedure TPropertyEditorHook.RemoveHandlerCompatibleMethodExists( const OnMethodExists: TPropHookCompatibleMethodExists); begin RemoveHandler(htCompatibleMethodExists,TMethod(OnMethodExists)); end; procedure TPropertyEditorHook.AddHandlerGetCompatibleMethods( const OnGetMethods: TPropHookGetCompatibleMethods); begin AddHandler(htGetCompatibleMethods,TMethod(OnGetMethods)); end; procedure TPropertyEditorHook.RemoveHandlerGetCompatibleMethods( const OnGetMethods: TPropHookGetCompatibleMethods); begin RemoveHandler(htGetCompatibleMethods,TMethod(OnGetMethods)); end; procedure TPropertyEditorHook.AddHandlerMethodExists( const OnMethodExists: TPropHookMethodExists); begin AddHandler(htMethodExists,TMethod(OnMethodExists)); end; procedure TPropertyEditorHook.RemoveHandlerMethodExists( const OnMethodExists: TPropHookMethodExists); begin RemoveHandler(htMethodExists,TMethod(OnMethodExists)); end; procedure TPropertyEditorHook.AddHandlerRenameMethod( const OnRenameMethod: TPropHookRenameMethod); begin AddHandler(htRenameMethod,TMethod(OnRenameMethod)); end; procedure TPropertyEditorHook.RemoveHandlerRenameMethod( const OnRenameMethod: TPropHookRenameMethod); begin RemoveHandler(htRenameMethod,TMethod(OnRenameMethod)); end; procedure TPropertyEditorHook.AddHandlerShowMethod( const OnShowMethod: TPropHookShowMethod); begin AddHandler(htShowMethod,TMethod(OnShowMethod)); end; procedure TPropertyEditorHook.RemoveHandlerShowMethod( const OnShowMethod: TPropHookShowMethod); begin RemoveHandler(htShowMethod,TMethod(OnShowMethod)); end; procedure TPropertyEditorHook.AddHandlerMethodFromAncestor( const OnMethodFromAncestor: TPropHookMethodFromAncestor); begin AddHandler(htMethodFromAncestor,TMethod(OnMethodFromAncestor)); end; procedure TPropertyEditorHook.RemoveHandlerMethodFromAncestor( const OnMethodFromAncestor: TPropHookMethodFromAncestor); begin RemoveHandler(htMethodFromAncestor,TMethod(OnMethodFromAncestor)); end; procedure TPropertyEditorHook.AddHandlerMethodFromLookupRoot( const OnMethodFromLookupRoot: TPropHookMethodFromLookupRoot); begin AddHandler(htMethodFromLookupRoot,TMethod(OnMethodFromLookupRoot)); end; procedure TPropertyEditorHook.RemoveHandlerMethodFromLookupRoot( const OnMethodFromLookupRoot: TPropHookMethodFromLookupRoot); begin RemoveHandler(htMethodFromLookupRoot,TMethod(OnMethodFromLookupRoot)); end; procedure TPropertyEditorHook.AddHandlerChainCall( const OnChainCall: TPropHookChainCall); begin AddHandler(htChainCall,TMethod(OnChainCall)); end; procedure TPropertyEditorHook.RemoveHandlerChainCall( const OnChainCall: TPropHookChainCall); begin RemoveHandler(htChainCall,TMethod(OnChainCall)); end; procedure TPropertyEditorHook.AddHandlerGetComponent( const OnGetComponent: TPropHookGetComponent); begin AddHandler(htGetComponent,TMethod(OnGetComponent)); end; procedure TPropertyEditorHook.RemoveHandlerGetComponent( const OnGetComponent: TPropHookGetComponent); begin RemoveHandler(htGetComponent,TMethod(OnGetComponent)); end; procedure TPropertyEditorHook.AddHandlerGetComponentName( const OnGetComponentName: TPropHookGetComponentName); begin AddHandler(htGetComponentName,TMethod(OnGetComponentName)); end; procedure TPropertyEditorHook.RemoveHandlerGetComponentName( const OnGetComponentName: TPropHookGetComponentName); begin RemoveHandler(htGetComponentName,TMethod(OnGetComponentName)); end; procedure TPropertyEditorHook.AddHandlerGetComponentNames( const OnGetComponentNames: TPropHookGetComponentNames); begin AddHandler(htGetComponentNames,TMethod(OnGetComponentNames)); end; procedure TPropertyEditorHook.RemoveHandlerGetComponentNames( const OnGetComponentNames: TPropHookGetComponentNames); begin RemoveHandler(htGetComponentNames,TMethod(OnGetComponentNames)); end; procedure TPropertyEditorHook.AddHandlerAddClicked( const Handler: TPropHookAddClicked); begin AddHandler(htAddClicked,TMethod(Handler)); end; procedure TPropertyEditorHook.RemoveHandlerAddClicked( const Handler: TPropHookAddClicked); begin RemoveHandler(htAddClicked,TMethod(Handler)); end; procedure TPropertyEditorHook.AddHandlerGetRootClassName( const OnGetRootClassName: TPropHookGetRootClassName); begin AddHandler(htGetRootClassName,TMethod(OnGetRootClassName)); end; procedure TPropertyEditorHook.RemoveHandlerGetRootClassName( const OnGetRootClassName: TPropHookGetRootClassName); begin RemoveHandler(htGetRootClassName,TMethod(OnGetRootClassName)); end; procedure TPropertyEditorHook.AddHandlerGetAncestorInstProp( const OnGetAncestorInstProp: TPropHookGetAncestorInstProp); begin AddHandler(htGetAncestorInstProp,TMethod(OnGetAncestorInstProp)); end; procedure TPropertyEditorHook.RemoveHandlerGetAncestorInstProp( const OnGetAncestorInstProp: TPropHookGetAncestorInstProp); begin RemoveHandler(htGetAncestorInstProp,TMethod(OnGetAncestorInstProp)); end; procedure TPropertyEditorHook.AddHandlerBeforeAddPersistent( const OnBeforeAddPersistent: TPropHookBeforeAddPersistent); begin AddHandler(htBeforeAddPersistent,TMethod(OnBeforeAddPersistent)); end; procedure TPropertyEditorHook.RemoveHandlerBeforeAddPersistent( const OnBeforeAddPersistent: TPropHookBeforeAddPersistent); begin RemoveHandler(htBeforeAddPersistent,TMethod(OnBeforeAddPersistent)); end; procedure TPropertyEditorHook.AddHandlerComponentRenamed( const OnComponentRenamed: TPropHookComponentRenamed); begin AddHandler(htComponentRenamed,TMethod(OnComponentRenamed)); end; procedure TPropertyEditorHook.RemoveHandlerComponentRenamed( const OnComponentRenamed: TPropHookComponentRenamed); begin RemoveHandler(htComponentRenamed,TMethod(OnComponentRenamed)); end; procedure TPropertyEditorHook.AddHandlerPersistentAdded( const OnPersistentAdded: TPropHookPersistentAdded); begin AddHandler(htPersistentAdded,TMethod(OnPersistentAdded)); end; procedure TPropertyEditorHook.RemoveHandlerPersistentAdded( const OnPersistentAdded: TPropHookPersistentAdded); begin RemoveHandler(htPersistentAdded,TMethod(OnPersistentAdded)); end; procedure TPropertyEditorHook.AddHandlerPersistentDeleting( const OnPersistentDeleting: TPropHookPersistentDel); begin AddHandler(htPersistentDeleting,TMethod(OnPersistentDeleting)); end; procedure TPropertyEditorHook.RemoveHandlerPersistentDeleting( const OnPersistentDeleting: TPropHookPersistentDel); begin RemoveHandler(htPersistentDeleting,TMethod(OnPersistentDeleting)); end; procedure TPropertyEditorHook.AddHandlerPersistentDeleted( const OnPersistentDeleted: TPropHookPersistentDel); begin AddHandler(htPersistentDeleted,TMethod(OnPersistentDeleted)); end; procedure TPropertyEditorHook.RemoveHandlerPersistentDeleted( const OnPersistentDeleted: TPropHookPersistentDel); begin RemoveHandler(htPersistentDeleted,TMethod(OnPersistentDeleted)); end; procedure TPropertyEditorHook.AddHandlerDeletePersistent( const OnDeletePersistent: TPropHookDeletePersistent); begin AddHandler(htDeletePersistent,TMethod(OnDeletePersistent)); end; procedure TPropertyEditorHook.RemoveHandlerDeletePersistent( const OnDeletePersistent: TPropHookDeletePersistent); begin RemoveHandler(htDeletePersistent,TMethod(OnDeletePersistent)); end; procedure TPropertyEditorHook.AddHandlerGetSelection( const OnGetSelection: TPropHookGetSelection); begin AddHandler(htGetSelectedPersistents,TMethod(OnGetSelection)); end; procedure TPropertyEditorHook.RemoveHandlerGetSelection( const OnGetSelection: TPropHookGetSelection); begin RemoveHandler(htGetSelectedPersistents,TMethod(OnGetSelection)); end; procedure TPropertyEditorHook.AddHandlerSetSelection( const OnSetSelection: TPropHookSetSelection); begin AddHandler(htSetSelectedPersistents,TMethod(OnSetSelection)); end; procedure TPropertyEditorHook.RemoveHandlerSetSelection( const OnSetSelection: TPropHookSetSelection); begin RemoveHandler(htSetSelectedPersistents,TMethod(OnSetSelection)); end; procedure TPropertyEditorHook.AddHandlerGetObject(const OnGetObject: TPropHookGetObject); begin AddHandler(htGetObject,TMethod(OnGetObject)); end; procedure TPropertyEditorHook.RemoveHandlerGetObject( const OnGetObject: TPropHookGetObject); begin RemoveHandler(htGetObject,TMethod(OnGetObject)); end; procedure TPropertyEditorHook.AddHandlerGetObjectName( const OnGetObjectName: TPropHookGetObjectName); begin AddHandler(htGetObjectName,TMethod(OnGetObjectName)); end; procedure TPropertyEditorHook.RemoveHandlerGetObjectName( const OnGetObjectName: TPropHookGetObjectName); begin RemoveHandler(htGetObjectName,TMethod(OnGetObjectName)); end; procedure TPropertyEditorHook.AddHandlerGetObjectNames( const OnGetObjectNames: TPropHookGetObjectNames); begin AddHandler(htGetObjectNames,TMethod(OnGetObjectNames)); end; procedure TPropertyEditorHook.RemoveHandlerGetObjectNames( const OnGetObjectNames: TPropHookGetObjectNames); begin RemoveHandler(htGetObjectNames,TMethod(OnGetObjectNames)); end; procedure TPropertyEditorHook.AddHandlerObjectPropertyChanged( const OnObjectPropertyChanged: TPropHookObjectPropertyChanged); begin AddHandler(htObjectPropertyChanged,TMethod(OnObjectPropertyChanged)); end; procedure TPropertyEditorHook.RemoveHandlerObjectPropertyChanged( const OnObjectPropertyChanged: TPropHookObjectPropertyChanged); begin RemoveHandler(htObjectPropertyChanged,TMethod(OnObjectPropertyChanged)); end; procedure TPropertyEditorHook.AddHandlerModified(const OnModified: TPropHookModified); begin AddHandler(htModified,TMethod(OnModified)); end; procedure TPropertyEditorHook.RemoveHandlerModified(const OnModified: TPropHookModified); begin RemoveHandler(htModified,TMethod(OnModified)); end; procedure TPropertyEditorHook.AddHandlerModifiedWithName( const OnModified: TPropHookModifiedWithName); begin AddHandler(htModifiedWithName,TMethod(OnModified)); end; procedure TPropertyEditorHook.RemoveHandlerModifiedWithName( const OnModified: TPropHookModifiedWithName); begin RemoveHandler(htModifiedWithName,TMethod(OnModified)); end; procedure TPropertyEditorHook.AddHandlerDesignerMouseDown( const OnMouseDown: TMouseEvent); begin AddHandler(htDesignerMouseDown,TMethod(OnMouseDown)); end; procedure TPropertyEditorHook.AddHandlerDesignerMouseUp( const OnMouseUp: TMouseEvent); begin AddHandler(htDesignerMouseUp,TMethod(OnMouseUp)); end; procedure TPropertyEditorHook.RemoveHandlerDesignerMouseDown( const OnMouseDown: TMouseEvent); begin RemoveHandler(htDesignerMouseDown,TMethod(OnMouseDown)); end; procedure TPropertyEditorHook.RemoveHandlerDesignerMouseUp( const OnMouseUp: TMouseEvent); begin RemoveHandler(htDesignerMouseUp,TMethod(OnMouseUp)); end; procedure TPropertyEditorHook.AddHandlerRevert(const OnRevert: TPropHookRevert); begin AddHandler(htRevert,TMethod(OnRevert)); end; procedure TPropertyEditorHook.RemoveHandlerRevert(const OnRevert: TPropHookRevert); begin RemoveHandler(htRevert,TMethod(OnRevert)); end; procedure TPropertyEditorHook.AddHandlerRefreshPropertyValues( const OnRefreshPropertyValues: TPropHookRefreshPropertyValues); begin AddHandler(htRefreshPropertyValues,TMethod(OnRefreshPropertyValues)); end; procedure TPropertyEditorHook.RemoveHandlerRefreshPropertyValues( const OnRefreshPropertyValues: TPropHookRefreshPropertyValues); begin RemoveHandler(htRefreshPropertyValues,TMethod(OnRefreshPropertyValues)); end; procedure TPropertyEditorHook.AddHandlerAddDependency( const OnAddDependency: TPropHookAddDependency); begin AddHandler(htAddDependency,TMethod(OnAddDependency)); end; procedure TPropertyEditorHook.RemoveHandlerAddDependency( const OnAddDependency: TPropHookAddDependency); begin RemoveHandler(htAddDependency,TMethod(OnAddDependency)); end; procedure TPropertyEditorHook.AddHandlerGetCheckboxForBoolean( const OnGetCheckboxForBoolean: TPropHookGetCheckboxForBoolean); begin AddHandler(htGetCheckboxForBoolean,TMethod(OnGetCheckboxForBoolean)); end; procedure TPropertyEditorHook.SetLookupRoot(APersistent: TPersistent); var i: Integer; begin if FLookupRoot=APersistent then exit; if FLookupRoot is TComponent then RemoveFreeNotification(TComponent(FLookupRoot)); FLookupRoot:=APersistent; if FLookupRoot is TComponent then FreeNotification(TComponent(FLookupRoot)); i:=GetHandlerCount(htChangeLookupRoot); while GetNextHandlerIndex(htChangeLookupRoot,i) do TPropHookChangeLookupRoot(FHandlers[htChangeLookupRoot][i])(); end; procedure TPropertyEditorHook.AddHandler(HookType: TPropHookType; const Handler: TMethod); begin if Handler.Code=nil then RaiseGDBException('TPropertyEditorHook.AddHandler'); if FHandlers[HookType]=nil then FHandlers[HookType]:=TMethodList.Create; FHandlers[HookType].Add(Handler); end; procedure TPropertyEditorHook.RemoveHandler(HookType: TPropHookType; const Handler: TMethod); begin if FHandlers[HookType]<>nil then FHandlers[HookType].Remove(Handler); end; function TPropertyEditorHook.GetHandlerCount(HookType: TPropHookType): integer; begin if FHandlers[HookType]<>nil then Result:=FHandlers[HookType].Count else Result:=0; end; function TPropertyEditorHook.GetNextHandlerIndex(HookType: TPropHookType; var i: integer): boolean; begin if FHandlers[HookType]<>nil then Result:=FHandlers[HookType].NextDownIndex(i) else begin i:=-1; Result:=false; end; end; procedure TPropertyEditorHook.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (Operation=opRemove) and (AComponent=FLookupRoot) then LookupRoot:=nil; end; destructor TPropertyEditorHook.Destroy; var HookType: TPropHookType; begin for HookType:=Low(FHandlers) to high(FHandlers) do FreeThenNil(FHandlers[HookType]); inherited Destroy; end; function KeyStringToVKCode(const s: string): word; var i: PtrInt; Data: Pointer; begin Result:=VK_UNKNOWN; if KeyStringIsIrregular(s) then begin Result:=word(StrToIntDef(copy(s,7,length(s)-8),VK_UNKNOWN)); exit; end; if (s<>'none') and (s<>'') then begin if VirtualKeyStrings=nil then begin VirtualKeyStrings:=TStringHashList.Create(true); for i:=1 to 255 do VirtualKeyStrings.Add(KeyAndShiftStateToKeyString(word(i),[]), {%H-}Pointer(i)); end; end else exit; Data:=VirtualKeyStrings.Data[s]; if Data<>nil then Result:=word({%H-}PtrUInt(Data)); end; function GetClassUnitName(Value: TClass): string; begin if Value=nil then Result:='' else Result:=GetSourceClassUnitName(Value) end; procedure CreateComponentEvent(AComponent: TComponent; const EventName: string); var CurDesigner: TIDesigner; PropInfo: PPropInfo; Hook: TPropertyEditorHook; PersistentList: TPersistentSelectionList; MethodPropEditor: TMethodPropertyEditor; begin CurDesigner:=FindRootDesigner(AComponent); if CurDesigner=nil then exit; // search method PropInfo:=GetPropInfo(AComponent,EventName); //writeln('CreateComponentEvent B ',PropInfo<>nil,' ',PropInfo^.PropType<>nil,' ',PropInfo^.PropType^.Kind=tkMethod,' ',(PropInfo^.GetProc<>nil),' ',(PropInfo^.SetProc<>nil)); if (PropInfo=nil) or (PropInfo^.PropType=nil) or (PropInfo^.PropType^.Kind<>tkMethod) or (PropInfo^.GetProc=nil) or (PropInfo^.SetProc=nil) then exit; MethodPropEditor:=nil; PersistentList:=nil; try PersistentList := TPersistentSelectionList.Create; PersistentList.Add(AComponent); Hook:=GlobalDesignHook; MethodPropEditor := TMethodPropertyEditor.Create(Hook,1); MethodPropEditor.SetPropEntry(0, AComponent, PropInfo); MethodPropEditor.Initialize; MethodPropEditor.Edit; finally MethodPropEditor.Free; PersistentList.Free; end; end; function ClassNameToComponentName(const AClassName: string): string; begin Result:=AClassName; if (length(Result)>2) and (Result[1] in ['T','t']) and (not (Result[2] in ['0'..'9'])) then System.Delete(Result,1,1); end; function ControlAcceptsStreamableChildComponent(aControl: TWinControl; aComponentClass: TComponentClass; aLookupRoot: TPersistent): boolean; {off $DEFINE VerboseAddDesigner} var Parent: TWinControl; begin Result:=false; if not (csAcceptsControls in aControl.ControlStyle) then begin {$IFDEF VerboseAddDesigner} debugln(['ControlAcceptsStreamableChildComponent missing csAcceptsControls in ',DbgSName(aControl)]); {$ENDIF} exit; end; if aComponentClass.InheritsFrom(TControl) and not aControl.CheckChildClassAllowed(aComponentClass, False) then begin {$IFDEF VerboseAddDesigner} debugln(['ControlAcceptsStreamableChildComponent aControl=',DbgSName(aControl),' CheckChildClassAllowed forbids ',DbgSName(aComponentClass)]); {$ENDIF} exit; end; // the LookupRoot allows children if aControl=aLookupRoot then exit(true); // TWriter only supports children of LookupRoot and LookupRoot.Components if (aControl.Owner <> aLookupRoot) and (aControl <> aLookupRoot) then begin {$IFDEF VerboseAddDesigner} debugln(['ControlAcceptsStreamableChildComponent wrong lookuproot aControl=',DbgSName(aControl),' aLookupRoot=',DbgSName(aLookupRoot),' aControl.Owner=',DbgSName(aControl.Owner)]); {$ENDIF} exit; end; // TWriter does not support children on nested components // (i.e. csInline , e.g. on a frame) nor any of its components Parent:=aControl; while (Parent<>nil) and (Parent<>aLookupRoot) do begin if csInline in Parent.ComponentState then begin {$IFDEF VerboseAddDesigner} debugln(['ControlAcceptsStreamableChildComponent aControl=',DbgSName(aControl),' Parent=',DbgSName(Parent),' csInline']); {$ENDIF} exit; end; Parent:=Parent.Parent; end; Result:=true; end; function ClassTypeInfo(Value: TClass): PTypeInfo; begin Result := PTypeInfo(Value.ClassInfo); end; procedure EditCollection(AComponent: TComponent; ACollection: TCollection; APropName: String); begin TCollectionPropertyEditor.ShowCollectionEditor(ACollection, AComponent, APropName); end; procedure EditCollectionNoAddDel(AComponent: TComponent; ACollection: TCollection; APropName: String); begin TNoAddDeleteCollectionPropertyEditor.ShowCollectionEditor(ACollection, AComponent, APropName); end; function IsInteresting(AEditor: TPropertyEditor; const AFilter: TTypeKinds; const APropNameFilter: String): Boolean; var visited: TFPList; // check set element names against AFilter function IsPropInSet( const ATypeInfo: PTypeInfo ) : Boolean; var EnumType: PTypeInfo; i: Integer; begin Result := False; if (ATypeInfo^.Kind <> tkSet) then exit; // Get TypeInfo of set type. EnumType := GetTypeData(ATypeInfo)^.CompType; with GetTypeData(EnumType)^ do for i := MinValue to MaxValue do begin Result := MultiWordSearch(APropNameFilter, GetEnumName(EnumType,i)); if Result then Break; end; end; //check if class has property name function IsPropInClass( const ATypeInfo: PTypeInfo ) : Boolean; var propInfo: PPropInfo; propList: PPropList; i, propCount: Integer; quSubclass: TFPList; icurClass: Integer = 0; begin Result := False; quSubclass := TFPList.Create; quSubclass.Add(ATypeInfo); while icurClass < quSubclass.Count do begin propCount := GetPropList(quSubclass.Items[icurClass], propList); for i := 0 to propCount - 1 do begin propInfo := propList^[i]; Result := MultiWordSearch(APropNameFilter, propInfo^.Name); if Result then break; //if encounter a Set check its elements name. if (propInfo^.PropType^.Kind = tkSet) then begin Result := IsPropInSet(propInfo^.PropType); if Result then break; end; //queue subclasses(only once) to check later. if (propInfo^.PropType^.Kind = tkClass) then if quSubclass.IndexOf(propInfo^.PropType) >= 0 then Continue else quSubclass.Add(propInfo^.PropType); end; if Assigned(propList) then FreeMem(propList); //no need to check subclasses if result is already true. if Result then break; inc(icurClass); end; quSubclass.Free; end; // Add AForceShow to display T****PropertyEditor when subproperties found. // and name of class is not the same as filter procedure Rec(A: TPropertyEditor; AForceShow: Boolean = False); var propList: PPropList; i: Integer; ti: PTypeInfo; edClass: TPropertyEditorClass; ed: TPropertyEditor; obj: TPersistent; PropCnt: LongInt; begin ti := A.GetPropType; //DebugLn('IsInteresting: ', ti^.Name); Result := ti^.Kind <> tkClass; if Result then begin if (APropNameFilter = '') or AForceShow then exit; Result := MultiWordSearch(APropNameFilter, A.GetName); // Check single Props // Check if check Set has element. if (ti^.Kind = tkSet) and (A.ClassType <> TSetElementPropertyEditor) then Result := Result or IsPropInSet(A.GetPropType); exit; end; // Subproperties can change if user selects another object => // we must show the property, even if it is not interesting currently. //Result := paVolatileSubProperties in A.GetAttributes; // Not really needed? //if Result then exit; if tkClass in AFilter then begin // We want classes => any non-trivial editor is immediately interesting. Result := A.ClassType <> TClassPropertyEditor; if Result then begin // if no SubProperties check against filter name if (APropNameFilter = '') then exit; Result := MultiWordSearch(APropNameFilter, A.GetName); if (paSubProperties in A.GetAttributes) then Result := Result or IsPropInClass(A.GetPropType); exit; end; end else if A.GetAttributes * [paSubProperties, paVolatileSubProperties] = [] then exit; obj := TPersistent(A.GetObjectValue); // At this stage, there is nothing interesting left in empty objects. if obj = nil then exit; // Class properties may directly or indirectly refer to the same class, // so we must avoid infinite recursion. if visited.IndexOf(ti) >= 0 then exit; visited.Add(ti); // actual published properties can be different since the instance can be inherited // so update type info from the instance ti := obj.ClassInfo; PropCnt := GetPropList(ti, propList); try for i := 0 to PropCnt - 1 do begin if not (propList^[i]^.PropType^.Kind in AFilter + [tkClass]) then continue; edClass := GetEditorClass(propList^[i], obj); if edClass = nil then continue; ed := edClass.Create(AEditor.FPropertyHook, 1); try ed.SetPropEntry(0, obj, propList^[i]); ed.Initialize; // filter TClassPropertyEditor name recursively Rec(ed, MultiWordSearch(APropNameFilter, A.GetName)); finally ed.Free; end; if Result then break; end; finally FreeMem(propList); end; visited.Delete(visited.Count - 1); end; begin visited := TFPList.Create; try //DebugLn('IsInteresting -> ', AEditor.GetPropInfo^.Name, ': ', AEditor.GetPropInfo^.PropType^.Name); Rec(AEditor); //DebugLn('IsInteresting <- ', BoolToStr(Result, true)); finally visited.Free; end; end; function GetOrdField(Field: Pointer; FieldInfo: PTypeInfo): Int64; var Signed: Boolean; DataSize: Integer; OrdType: TOrdType; begin Result:=0; Signed := false; DataSize := 4; case FieldInfo^.Kind of tkChar, tkBool: DataSize:=1; tkWChar: DataSize:=2; tkSet, tkEnumeration, tkInteger: begin OrdType:=GetTypeData(FieldInfo)^.OrdType; case OrdType of otSByte,otUByte: DataSize := 1; otSWord,otUWord: DataSize := 2; end; Signed := OrdType in [otSByte,otSWord,otSLong]; end; tkInt64 : begin DataSize:=8; Signed:=true; end; tkQword : begin DataSize:=8; Signed:=false; end; end; if Signed then begin case DataSize of 1: Result:=PShortInt(Field)^; 2: Result:=PSmallInt(Field)^; 4: Result:=PLongint(Field)^; 8: Result:=PInt64(Field)^; end; end else begin case DataSize of 1: Result:=PByte(Field)^; 2: Result:=PWord(Field)^; 4: Result:=PLongint(Field)^; 8: Result:=PInt64(Field)^; end; end; end; procedure SetOrdField(Field: Pointer; FieldInfo: PTypeInfo; Value: Int64); var DataSize: Integer; begin if FieldInfo^.Kind in [tkInt64,tkQword] then DataSize := 8 else DataSize := 4; if not (FieldInfo^.Kind in [tkInt64,tkQword,tkClass,tkInterface,tkInterfaceRaw,tkDynArray]) then begin // cut off unnecessary stuff case GetTypeData(FieldInfo)^.OrdType of otSWord,otUWord: begin Value:=Value and $ffff; DataSize := 2; end; otSByte,otUByte: begin Value:=Value and $ff; DataSize := 1; end; end; end; case DataSize of 1: PByte(Field)^:=Byte(Value); 2: PWord(Field)^:=Word(Value); 4: PLongint(Field)^:=Longint(Value); 8: PInt64(Field)^:=Value; end; end; function GetEnumField(Field: Pointer; FieldInfo: PTypeInfo): String; begin Result:=GetEnumName(FieldInfo, GetOrdField(Field, FieldInfo)); end; procedure SetEnumField(Field: Pointer; FieldInfo: PTypeInfo; const Value: string); var PV: Integer; begin PV:=GetEnumValue(FieldInfo, Value); if (PV<0) then raise EPropertyError.CreateFmt(SErrUnknownEnumValue, [Value]); SetOrdField(Field, FieldInfo, PV); end; function GetSetField(Field: Pointer; FieldInfo: PTypeInfo; Brackets: Boolean): String; begin Result:=SetToString(FieldInfo,GetOrdField(Field,FieldInfo),Brackets); end; procedure SetSetField(Field: Pointer; FieldInfo: PTypeInfo; const Value: string); begin SetOrdField(Field,FieldInfo,StringToSet(FieldInfo,Value)); end; function GetStringField(Field: Pointer; FieldInfo: PTypeInfo): String; begin Result:=''; case FieldInfo^.Kind of tkWString: Result:=AnsiString(GetWideStringField(Field,FieldInfo)); tkUString: Result := AnsiString(GetUnicodeStringField(Field,FieldInfo)); tkSString: Result := PShortString(Field)^; tkAString: Result := PAnsiString(Field)^; end; end; procedure SetStringField(Field: Pointer; FieldInfo: PTypeInfo; const Value: string); begin case FieldInfo^.Kind of tkWString: SetWideStringField(Field,FieldInfo,WideString(Value)); tkUString: SetUnicodeStringField(Field,FieldInfo,UnicodeString(Value)); tkSString: PShortString(Field)^:=Value; tkAString: PAnsiString(Field)^:=Value; end; end; function GetWideStringField(Field: Pointer; FieldInfo: PTypeInfo): WideString; begin Result:=''; case FieldInfo^.Kind of tkSString,tkAString: Result := WideString(GetStringField(Field,FieldInfo)); tkUString : Result := GetUnicodeStringField(Field,FieldInfo); tkWString: Result := PWideString(Field)^; end; end; procedure SetWideStringField(Field: Pointer; FieldInfo: PTypeInfo; const Value: WideString); begin case FieldInfo^.Kind of tkSString,tkAString: SetStringField(Field,FieldInfo,AnsiString(Value)); tkUString: SetUnicodeStringField(Field,FieldInfo,Value); tkWString: PWideString(Field)^:=Value; end; end; function GetUnicodeStringField(Field: Pointer; FieldInfo: PTypeInfo): UnicodeString; begin Result:=''; case FieldInfo^.Kind of tkSString,tkAString: Result := UnicodeString(GetStringField(Field,FieldInfo)); tkWString: Result := GetWideStringField(Field,FieldInfo); tkUString : Result := PUnicodeString(Field)^; end; end; procedure SetUnicodeStringField(Field: Pointer; FieldInfo: PTypeInfo; const Value: UnicodeString ); begin case FieldInfo^.Kind of tkSString,tkAString: SetStringField(Field,FieldInfo,AnsiString(Value)); tkWString: SetWideStringField(Field,FieldInfo,Value); tkUString: PUnicodeString(Field)^:=Value; end; end; function GetRawbyteStringField(Field: Pointer; FieldInfo: PTypeInfo): RawByteString; begin Result:=''; case FieldInfo^.Kind of tkWString: Result := RawByteString(GetWideStringField(Field,FieldInfo)); tkUString: Result := RawByteString(GetUnicodeStringField(Field,FieldInfo)); tkSString: Result := RawByteString(GetStringField(Field,FieldInfo)); tkAString: Result := PAnsiString(Field)^; end; end; procedure SetRawbyteStringField(Field: Pointer; FieldInfo: PTypeInfo; const Value: RawByteString ); begin case FieldInfo^.Kind of tkWString: SetWideStringField(Field,FieldInfo,WideString(Value)); tkUString: SetUnicodeStringField(Field,FieldInfo,UnicodeString(Value)); tkSString: SetStringField(Field,FieldInfo,Value); tkAString: PAnsiString(Field)^:=Value; else end; end; function GetFloatField(Field: Pointer; FieldInfo: PTypeInfo): Extended; begin Result:=0.0; case GetTypeData(FieldInfo)^.FloatType of ftSingle: Result:=PSingle(Field)^; ftDouble: Result:=PDouble(Field)^; ftExtended: Result:=PExtended(Field)^; ftComp: Result:=PComp(Field)^; ftCurr: Result:=PCurrency(Field)^; end; end; procedure SetFloatField(Field: Pointer; FieldInfo: PTypeInfo; const Value: Extended); begin Case GetTypeData(FieldInfo)^.FloatType of ftSingle: PSingle(Field)^:=Value; ftDouble: PDouble(Field)^:=Value; ftExtended: PExtended(Field)^:=Value; {$ifdef FPC_COMP_IS_INT64} ftComp: PComp(Field)^:=trunc(Value); {$else FPC_COMP_IS_INT64} ftComp: PComp(Field)^:=Comp(Value); {$endif FPC_COMP_IS_INT64} ftCurr: PCurrency(Field)^:=Value; end; end; function GetObjectField(Field: Pointer; FieldInfo: PTypeInfo; MinClass: TClass): TObject; begin Result:=TObject(PPointer(Field)^); if (MinClass<>nil) and (Result<>nil) Then if not Result.InheritsFrom(MinClass) then Result:=nil; if FieldInfo=nil then ; end; procedure SetObjectField(Field: Pointer; FieldInfo: PTypeInfo; const Value: TObject); begin PPointer(Field)^:=Pointer(Value); if FieldInfo=nil then ; end; function GetPointerField(Field: Pointer; FieldInfo: PTypeInfo): Pointer; begin Result:=PPointer(Field)^; if FieldInfo=nil then ; end; procedure SetPointerField(Field: Pointer; FieldInfo: PTypeInfo; const Value: Pointer); begin PPointer(Field)^:=Value; if FieldInfo=nil then ; end; function GetMethodField(Field: Pointer; FieldInfo: PTypeInfo): TMethod; begin Result:=PMethod(Field)^; if FieldInfo=nil then ; end; procedure SetMethodField(Field: Pointer; FieldInfo: PTypeInfo; const Value: TMethod); begin PMethod(Field)^:=Value; if FieldInfo=nil then ; end; function GetInterfaceField(Field: Pointer; FieldInfo: PTypeInfo): IInterface; begin Result:=IInterface(PPointer(Field)^); if FieldInfo=nil then ; end; procedure SetInterfaceField(Field: Pointer; FieldInfo: PTypeInfo; const Value: IInterface); begin PInterface(Field)^:=Value; if FieldInfo=nil then ; end; function GetVariantField(Field: Pointer; FieldInfo: PTypeInfo): Variant; begin Result:=PVariant(Field)^; end; procedure SetVariantField(Field: Pointer; FieldInfo: PTypeInfo; const Value: Variant); begin PVariant(Field)^:=Value; end; Function GetPointerProp(Instance: TObject; PropInfo : PPropInfo): Pointer; Type TGetPointerProcIndex = function (index:longint): Pointer of object; TGetPointerProc = function (): Pointer of object; var AMethod : TMethod; begin case (PropInfo^.PropProcs) and 3 of ptField: Result := PPointer(Pointer(Instance) + LongWord(PropInfo^.GetProc))^; ptStatic, ptVirtual: begin if (PropInfo^.PropProcs and 3)=ptStatic then AMethod.Code:=PropInfo^.GetProc else AMethod.Code:=PCodePointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.GetProc))^; AMethod.Data:=Instance; if ((PropInfo^.PropProcs shr 6) and 1)<>0 then Result:=TGetPointerProcIndex(AMethod)(PropInfo^.Index) else Result:=TGetPointerProc(AMethod)(); end; else raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]); end; end; Procedure SetPointerProp(Instance: TObject; PropInfo : PPropInfo; Value: Pointer); type TSetPointerProcIndex = procedure(index: longint; p: pointer) of object; TSetPointerProc = procedure(p: pointer) of object; var AMethod : TMethod; begin case (PropInfo^.PropProcs shr 2) and 3 of ptField: PPointer(Pointer(Instance) + LongWord(PropInfo^.SetProc))^:=Value; ptStatic, ptVirtual: begin if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then AMethod.Code:=PropInfo^.SetProc else AMethod.Code:=PCodePointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^; AMethod.Data:=Instance; if ((PropInfo^.PropProcs shr 6) and 1)<>0 then TSetPointerProcIndex(AMethod)(PropInfo^.Index,Value) else TSetPointerProc(AMethod)(Value); end; else raise EPropertyError.CreateFmt(SErrCannotWriteToProperty, [PropInfo^.Name]); end; end; function dbgs(peh: TPropEditHint): string; begin writestr(Result,peh); end; { TNoteBookActiveControlPropertyEditor } function TNoteBookActiveControlPropertyEditor.CheckNewValue(APersistent: TPersistent): boolean; var AComponent: TPersistent; Notebook: TCustomTabControl; begin Result:=true; if APersistent=nil then exit; AComponent:=GetComponent(0); if not (AComponent is TCustomTabControl) then raise Exception.Create('invalid instance for this property editor'); Notebook:=TCustomTabControl(AComponent); if Notebook.IndexOf(APersistent)<0 then raise Exception.Create('only children are allowed for this property'); end; function TNoteBookActiveControlPropertyEditor.GetAttributes: TPropertyAttributes; begin Result:=(inherited GetAttributes)-[paMultiSelect]; end; procedure TNoteBookActiveControlPropertyEditor.GetValues(Proc: TGetStrProc); var AComponent: TPersistent; Notebook: TCustomTabControl; i: Integer; begin Proc(oisNone); AComponent:=GetComponent(0); if not (AComponent is TCustomTabControl) then exit; Notebook:=TCustomTabControl(AComponent); for i:=0 to Notebook.PageCount-1 do Proc(Notebook.Page[i].Name); end; { TCustomShortCutGrabBox } procedure TCustomShortCutGrabBox.SetKey(const AValue: Word); var s: String; i: LongInt; begin if FKey=AValue then exit; FKey:=AValue; s:=KeyAndShiftStateToKeyString(FKey,[]); {$IFDEF VerboseKeyboard} debugln(['TCustomShortCutGrabBox.SetKey ',Key,' "',s,'"']); {$ENDIF} i:=KeyComboBox.Items.IndexOf(s); if i>=0 then KeyComboBox.ItemIndex:=i else if KeyStringIsIrregular(s) then begin KeyComboBox.Items.Add(s); KeyComboBox.ItemIndex:=KeyComboBox.Items.IndexOf(s); end else KeyComboBox.ItemIndex:=0; end; procedure TCustomShortCutGrabBox.GrabButtonClick(Sender: TObject); begin FGrabForm:=TForm.Create(Self); FGrabForm.BorderStyle:=bsDialog; FGrabForm.KeyPreview:=true; FGrabForm.Position:=poScreenCenter; FGrabForm.OnKeyDown:=@GrabFormKeyDown; FGrabForm.Caption:=oisPressAKey; with TLabel.Create(Self) do begin Caption:=oisPressAKeyEGCtrlP; BorderSpacing.Around:=50; Parent:=FGrabForm; end; FGrabForm.Width:=200; FGrabForm.Height:=50; FGrabForm.AutoSize:=true; FGrabForm.ShowModal; // After getting a key, focus the main form's OK button. User can just click Enter. if (Key <> VK_UNKNOWN) and Assigned(MainOkButton) then MainOkButton.SetFocus; FreeAndNil(FGrabForm); end; procedure TCustomShortCutGrabBox.ShiftCheckBoxClick(Sender: TObject); var s: TShiftStateEnum; begin for s:=Low(TShiftStateEnum) to High(TShiftStateEnum) do if FCheckBoxes[s]=Sender then if FCheckBoxes[s].Checked then Include(FShiftState,s) else Exclude(FShiftState,s); end; procedure TCustomShortCutGrabBox.GrabFormKeyDown(Sender: TObject; var AKey: Word; AShift: TShiftState); begin {$IFDEF VerboseKeyboard} DebugLn(['TCustomShortCutGrabBox.GrabFormKeyDown ',AKey,' ',dbgs(AShift)]); DumpStack; {$ENDIF} if not (AKey in [VK_CONTROL, VK_LCONTROL, VK_RCONTROL, VK_SHIFT, VK_LSHIFT, VK_RSHIFT, VK_MENU, VK_LMENU, VK_RMENU, VK_LWIN, VK_RWIN, VK_PROCESSKEY, VK_MODECHANGE, VK_UNKNOWN, VK_UNDEFINED]) then begin if (AKey=VK_ESCAPE) and (AShift=[]) then begin Key:=VK_UNKNOWN; ShiftState:=[]; end else begin Key:=AKey; ShiftState:=AShift; end; FGrabForm.ModalResult:=mrOk; end; end; procedure TCustomShortCutGrabBox.KeyComboboxEditingDone(Sender: TObject); begin Key:=KeyStringToVKCode(KeyComboBox.Text); end; function TCustomShortCutGrabBox.GetShiftCheckBox(Shift: TShiftStateEnum): TCheckBox; begin Result:=FCheckBoxes[Shift]; end; function TCustomShortCutGrabBox.GetKey: Word; begin Result:=FKey; if (FKey = 0) then FShiftState:=[]; end; procedure TCustomShortCutGrabBox.SetAllowedShifts(const AValue: TShiftState); begin if FAllowedShifts=AValue then exit; FAllowedShifts:=AValue; ShiftState:=ShiftState*FAllowedShifts; end; procedure TCustomShortCutGrabBox.SetShiftButtons(const AValue: TShiftState); begin if FShiftButtons=AValue then exit; FShiftButtons:=AValue; UpdateShiftButtons; end; procedure TCustomShortCutGrabBox.SetShiftState(const AValue: TShiftState); var s: TShiftStateEnum; begin if FShiftState=AValue then exit; FShiftState:=AValue; for s:=low(TShiftStateEnum) to High(TShiftStateEnum) do if FCheckBoxes[s]<>nil then FCheckBoxes[s].Checked:=s in FShiftState; end; procedure TCustomShortCutGrabBox.Loaded; begin inherited Loaded; UpdateShiftButtons; end; procedure TCustomShortCutGrabBox.RealSetText(const Value: TCaption); begin // do not allow to set caption end; procedure TCustomShortCutGrabBox.UpdateShiftButtons; var s: TShiftStateEnum; LastCheckBox: TCheckBox; begin if [csLoading,csDestroying]*ComponentState<>[] then exit; LastCheckBox:=nil; DisableAlign; try for s:=low(TShiftStateEnum) to High(TShiftStateEnum) do begin if s in FShiftButtons then begin if FCheckBoxes[s]=nil then begin FCheckBoxes[s]:=TCheckBox.Create(Self); with FCheckBoxes[s] do begin Name:='CheckBox'+ShiftToStr(s); Caption:=ShiftToStr(s); AutoSize:=true; Checked:=s in FShiftState; if LastCheckBox<>nil then AnchorToNeighbour(akLeft,6,LastCheckBox) else AnchorParallel(akLeft,0,Self); AnchorParallel(akTop,0,Self); AnchorParallel(akBottom,0,Self); Parent:=Self; OnClick:=@ShiftCheckBoxClick; end; end; LastCheckBox:=FCheckBoxes[s]; end else begin FreeAndNil(FCheckBoxes[s]); end; end; if LastCheckBox<>nil then FKeyComboBox.AnchorToNeighbour(akLeft,6,LastCheckBox) else FKeyComboBox.AnchorParallel(akLeft,0,Self); finally EnableAlign; end; end; procedure TCustomShortCutGrabBox.Notification(AComponent: TComponent; Operation: TOperation); var s: TShiftStateEnum; begin inherited Notification(AComponent, Operation); if Operation=opRemove then begin if AComponent=FGrabButton then FGrabButton:=nil; if AComponent=FKeyComboBox then FKeyComboBox:=nil; if AComponent=FGrabForm then FGrabForm:=nil; for s:=Low(TShiftStateEnum) to High(TShiftStateEnum) do if FCheckBoxes[s]=AComponent then begin FCheckBoxes[s]:=nil; Exclude(FShiftButtons,s); end; end; end; function TCustomShortCutGrabBox.ShiftToStr(s: TShiftStateEnum): string; begin case s of ssShift: Result:='Shift'; ssAlt: Result:='Alt'; ssCtrl: Result:='Ctrl'; ssMeta: Result:='Meta'; ssSuper: Result:='Super'; ssHyper: {$IFDEF Darwin} Result:='Cmd'; {$ELSE} Result:='Hyper'; {$ENDIF} ssAltGr: Result:='AltGr'; ssCaps: Result:='Caps'; ssNum: Result:='Numlock'; ssScroll: Result:='Scroll'; else Result:='Modifier'+IntToStr(ord(s)); end; end; constructor TCustomShortCutGrabBox.Create(TheOwner: TComponent); procedure AddKeyToCombobox(i: integer); var s: String; begin s := KeyAndShiftStateToKeyString(i, []); if not KeyStringIsIrregular(s) then FKeyComboBox.Items.Add(s); end; var i: Integer; ShSt: TShiftStateEnum; begin inherited Create(TheOwner); FAllowedShifts:=[ssShift, ssAlt, ssCtrl, ssMeta, ssSuper, ssHyper, ssAltGr, ssCaps, ssNum, ssScroll]; FGrabButton:=TButton.Create(Self); with FGrabButton do begin Name:='GrabButton'; Caption:=srGrabKey; Align:=alRight; AutoSize:=true; Parent:=Self; OnClick:=@GrabButtonClick; end; FKeyComboBox:=TComboBox.Create(Self); with FKeyComboBox do begin Name:='FKeyComboBox'; AutoSize:=true; Items.BeginUpdate; AddKeyToCombobox(0); for i:=VK_BACK to VK_SCROLL do AddKeyToCombobox(i); for i:=VK_BROWSER_BACK to VK_OEM_CLEAR do AddKeyToCombobox(i); Items.EndUpdate; OnEditingDone:=@KeyComboboxEditingDone; Parent:=Self; AnchorToNeighbour(akRight,6,FGrabButton); AnchorVerticalCenterTo(FGrabButton); Constraints.MinWidth:=130; end; BevelOuter:=bvNone; ShiftButtons:=GetDefaultShiftButtons; ShiftState:=[]; Key:=VK_UNKNOWN; KeyComboBox.Text:=KeyAndShiftStateToKeyString(Key,[]); // Fix TabOrders. The controls were created in "wrong" order. i:=FGrabButton.TabOrder; // GrabButton was created first. for ShSt:=Low(FCheckBoxes) to High(FCheckBoxes) do begin if Assigned(FCheckBoxes[ShSt]) then begin FCheckBoxes[ShSt].TabOrder:=i; Inc(i); end; end; FKeyComboBox.TabOrder:=i; FGrabButton.TabOrder:=i+1; end; function TCustomShortCutGrabBox.GetDefaultShiftButtons: TShiftState; begin {$IFDEF Darwin} Result:=[ssCtrl,ssShift,ssAlt,ssMeta]; {$ELSE} Result:=[ssCtrl,ssShift,ssAlt]; {$ENDIF} end; procedure InitPropEdits; begin // Don't create PropertyClassList and PropertyEditorMapperList lists here. // RegisterPropertyEditor and RegisterPropertyEditorMapper create them, // and they are called from many initialization sections in unpredictable order. // register the standard property editors RegisterPropertyEditor(TypeInfo(AnsiString), TComponent, 'Name', TComponentNamePropertyEditor); RegisterPropertyEditor(TypeInfo(TTranslateString), TCustomLabel, 'Caption', TStringMultilinePropertyEditor); RegisterPropertyEditor(TypeInfo(TTranslateString), TCustomStaticText, 'Caption', TStringMultilinePropertyEditor); RegisterPropertyEditor(TypeInfo(TTranslateString), TCustomCheckBox, 'Caption', TStringMultilinePropertyEditor); RegisterPropertyEditor(TypeInfo(TTranslateString), TCustomSpeedButton, 'Caption', TStringMultilinePropertyEditor); RegisterPropertyEditor(TypeInfo(TTranslateString), TMenuItem, 'Caption', TMenuItemCaptionEditor); RegisterPropertyEditor(TypeInfo(TTranslateString), TComponent, 'Hint', TStringMultilinePropertyEditor); RegisterPropertyEditor(TypeInfo(TCaption), TGridColumnTitle, 'Caption', TStringMultilinePropertyEditor); RegisterPropertyEditor(TypeInfo(TTabOrder), TControl, 'TabOrder', TTabOrderPropertyEditor); RegisterPropertyEditor(TypeInfo(ShortString), nil, '', TCaptionPropertyEditor); RegisterPropertyEditor(TypeInfo(TStrings), nil, '', TStringsPropertyEditor); RegisterPropertyEditor(TypeInfo(TFileName), nil, '', TFileNamePropertyEditor); RegisterPropertyEditor(TypeInfo(AnsiString), nil, 'SessionProperties', TSessionPropertiesPropertyEditor); RegisterPropertyEditor(TypeInfo(TModalResult), nil, 'ModalResult', TModalResultPropertyEditor); RegisterPropertyEditor(TypeInfo(TShortCut), nil, '', TShortCutPropertyEditor); //RegisterPropertyEditor(DummyClassForPropTypes.PTypeInfos('TDate'), nil,'',TDatePropertyEditor); //RegisterPropertyEditor(DummyClassForPropTypes.PTypeInfos('TTime'), nil,'',TTimePropertyEditor); RegisterPropertyEditor(TypeInfo(TDateTime), nil, '', TDateTimePropertyEditor); RegisterPropertyEditor(TypeInfo(TCursor), nil, '', TCursorPropertyEditor); RegisterPropertyEditor(TypeInfo(TComponent), nil, '', TComponentPropertyEditor); RegisterPropertyEditor(TypeInfo(TComponent), nil, 'ActiveControl', TComponentOneFormPropertyEditor); RegisterPropertyEditor(TypeInfo(TControl), TCoolBand, 'Control', TCoolBarControlPropertyEditor); RegisterPropertyEditor(TypeInfo(TCollection), nil, '', TCollectionPropertyEditor); RegisterPropertyEditor(TypeInfo(TFlowPanelControlList), TFlowPanel, 'ControlList', TNoAddDeleteCollectionPropertyEditor); RegisterPropertyEditor(TypeInfo(TControl), TFlowPanelControl, 'Control', THiddenPropertyEditor); RegisterPropertyEditor(TypeInfo(AnsiString), TFileDialog, 'Filter', TFileDlgFilterProperty); RegisterPropertyEditor(TypeInfo(AnsiString), TFilterComboBox, 'Filter', TFileDlgFilterProperty); RegisterPropertyEditor(TypeInfo(AnsiString), TFileNameEdit, 'Filter', TFileDlgFilterProperty); RegisterPropertyEditor(TypeInfo(AnsiString), TCustomPropertyStorage, 'Filename', TFileNamePropertyEditor); RegisterPropertyEditor(TypeInfo(TStrings), TValueListEditor, 'Strings', TValueListPropertyEditor); RegisterPropertyEditor(TypeInfo(TCustomPage), TCustomTabControl, 'ActivePage', TNoteBookActiveControlPropertyEditor); RegisterPropertyEditor(TypeInfo(TSizeConstraints), TControl, 'Constraints', TConstraintsPropertyEditor); RegisterPropertyEditor(TypeInfo(TStrings), TNoteBook, 'Pages', TPagesPropertyEditor); RegisterPropertyEditor(TypeInfo(TTranslateString), TCustomTaskDialog, 'Text', TStringMultilinePropertyEditor); RegisterPropertyEditor(TypeInfo(TTranslateString), TCustomTaskDialog, 'ExpandedText', TStringMultilinePropertyEditor); RegisterPropertyEditor(TypeInfo(TTranslateString), TCustomTaskDialog, 'FooterText', TStringMultilinePropertyEditor); // Property is hidden and editing disabled by HiddenPropertyEditor : RegisterPropertyEditor(TypeInfo(TAnchorSide), TControl, 'AnchorSideLeft', THiddenPropertyEditor); RegisterPropertyEditor(TypeInfo(TAnchorSide), TControl, 'AnchorSideTop', THiddenPropertyEditor); RegisterPropertyEditor(TypeInfo(TAnchorSide), TControl, 'AnchorSideRight', THiddenPropertyEditor); RegisterPropertyEditor(TypeInfo(TAnchorSide), TControl, 'AnchorSideBottom', THiddenPropertyEditor); RegisterPropertyEditor(TypeInfo(LongInt), TControl, 'ClientWidth', THiddenPropertyEditor); RegisterPropertyEditor(TypeInfo(LongInt), TControl, 'ClientHeight', THiddenPropertyEditor); RegisterPropertyEditor(TypeInfo(AnsiString), TCustomForm, 'LCLVersion', THiddenPropertyEditor); RegisterPropertyEditor(TypeInfo(AnsiString), TCustomFrame, 'LCLVersion', THiddenPropertyEditor); // since fpc 2.6.0 WordBool, LongBool and QWordBool only allow 0 and 1 RegisterPropertyEditor(TypeInfo(WordBool), nil, '', TBoolPropertyEditor); RegisterPropertyEditor(TypeInfo(LongBool), nil, '', TBoolPropertyEditor); RegisterPropertyEditor(TypeInfo(QWordBool), nil, '', TBoolPropertyEditor); RegisterPropertyEditor(TypeInfo(IInterface), nil, '', TInterfacePropertyEditor); RegisterPropertyEditor(TypeInfo(Variant), nil, '', TVariantPropertyEditor); end; procedure FinalPropEdits; var i: integer; pm: PPropertyEditorMapperRec; pc: PPropertyClassRec; sec: PSelectionEditorClassRec; begin if PropertyEditorMapperList<>nil then begin for i:=0 to PropertyEditorMapperList.Count-1 do begin pm:=PPropertyEditorMapperRec(PropertyEditorMapperList.Items[i]); Dispose(pm); end; FreeAndNil(PropertyEditorMapperList); end; if PropertyClassList<>nil then begin for i:=0 to PropertyClassList.Count-1 do begin pc:=PPropertyClassRec(PropertyClassList[i]); Dispose(pc); end; FreeAndNil(PropertyClassList); end; if Assigned(SelectionEditorClassList) then begin for i:=0 to SelectionEditorClassList.Count-1 do begin sec:=PSelectionEditorClassRec(SelectionEditorClassList[i]); Dispose(sec); end; FreeAndNil(SelectionEditorClassList); end; FreeAndNil(ListPropertyEditors); FreeAndNil(VirtualKeyStrings); end; initialization InitPropEdits; finalization FinalPropEdits; end.