flexprops.pas

是一套创建矢量图形的VCL组件

  protected
   function  GetDisplayValue: string; override;
  public
   constructor Create(AOwner: TPropList; const AName: string);
   destructor Destroy; override;
   procedure Setup(Canvas: TCanvas; Scale: integer = 100); override;
   function  Edit: boolean; override;
   procedure GetFont(var AFont: TFont);
   procedure SetFont(const AFont: TFont);
   property  Handle: HFont read GetHandle write SetHandle;
  published
   property PixelsPerInch: Integer read GetPixelsPerInch write SetPixelsPerInch
     stored False;
   property Charset: TFontCharset read GetCharset write SetCharset
     stored StoreCharset;
   property Color: TColor read GetColor write SetColor
     stored StoreColor;
   property Height: Integer read FFontHeight write SetHeight stored False;
   property Name: TFontName read GetName write SetName;
   property Pitch: TFontPitch read GetPitch write SetPitch
     stored StorePitch;
   property Size: Integer read GetSize write SetSize;
   property Style: TFontStyles read GetStyle write SetStyle
     stored StoreStyle;
  end;

  TPictureProp = class(TCustomProp)
  private
   FPicture: TPicture;
   FColumns: integer;
   FRows: integer;
   FMasked: boolean;
   FMaskColor: TColor;
   FLinkName: string;
   function  GetIsLoaded: boolean;
   function  GetGraphic: TGraphic;
   procedure SetGraphic(const Value: TGraphic);
   procedure SetColumns(const Value: integer);
   procedure SetRows(const Value: integer);
   procedure SetMaskColor(const Value: TColor);
   procedure SetMasked(const Value: boolean);
   function  GetImgRect(Index: integer): TRect;
   function  GetCellSizeRect: TRect;
   procedure SetLinkName(const Value: string);
   procedure PictureChange(Sender: TObject);
   function  StoreColumns: Boolean;
   function  StoreGraphic: Boolean;
   function  StoreLinkName: Boolean;
   function  StoreMaskColor: Boolean;
   function  StoreMasked: Boolean;
   function  StoreRows: Boolean;
  protected
   function  GetDisplayValue: string; override;
   function  GetIsRaster: boolean; virtual;
   function  GetFrameBitmap(FrameIndex: integer): TBitmap; virtual;
  public
   constructor Create(AOwner: TPropList; const AName: string);
   destructor Destroy; override;
   procedure Draw(Canvas: TCanvas; var R: TRect; FrameIndex: integer);
   procedure Clear(RemoveLink: boolean);
   procedure UpdateImageLink;
   procedure SetPropValue(const PropName: string; Value: Variant); override;
   function  GetPropValue(const PropName: string): Variant; override;
   function  GetPropType(const PropName: string): TPropType; override;
   property  IsLoaded: boolean read GetIsLoaded;
   property  IsRaster: boolean read GetIsRaster;
   property  ImgRect[Index: integer]: TRect read GetImgRect;
   property  CellSizeRect: TRect read GetCellSizeRect;
  published
   property  Graphic: TGraphic read GetGraphic write SetGraphic
     stored StoreGraphic;
   property  Columns: integer read FColumns write SetColumns
     stored StoreColumns;
   property  Rows: integer read FRows write SetRows stored StoreRows;
   property  Masked: boolean read FMasked write SetMasked stored StoreMasked;
   property  MaskColor: TColor read FMaskColor write SetMaskColor
     stored StoreMaskColor;
   property  LinkName: string read FLinkName write SetLinkName
     stored StoreLinkName;
  end;

  PPropRefItem = ^TPropRefItem;
  TPropRefItem = record
   Prop: TCustomProp;
   PropName: ShortString;
   Data: PVariant;
  end;

  TPropRefList = class
  private
   FList: TList;
   function  GetCount: integer;
   function  GetPropRefItem(Index: integer): PPropRefItem;
  public
   constructor Create;
   destructor Destroy; override;
   function  AddRef(AProp: TCustomProp; const APropName: ShortString;
     AData: PVariant): integer;
   procedure DeleteRef(Index: integer);
   procedure ResolveRef(Index: integer);
   procedure ResolveAllRefs;
   procedure Clear;
   property  Count: integer read GetCount;
   property  Refs[Index: integer]: PPropRefItem read GetPropRefItem;
  end;

  TPropList = class
  private
   FOwner: TObject;
   FRefList: TPropRefList;
   FPropList: TStringList;
   FOnPropChanged: TPropChangedEvent;
   FOnPropBeforeChanged: TPropChangedEvent;
   FOnPropStored: TPropStoredEvent;
   FOnPropReadOnly: TPropReadOnlyEvent;
   function  GetPropByIndex(Index: integer): TCustomProp;
   function  GetPropsCount: integer;
   function  GetPropByName(const Name: string): TCustomProp;
   function  GetPropName(Index: integer): string;
   function  GetVisibleCount: integer;
   function  GetVisibleProp(Index: integer): TCustomProp;
   function  GetVisiblePropName(Index: integer): string;
   function  GetResolving: boolean;
  protected
   FResolveCount: integer;
   procedure DoBeforeChanged(Prop: TCustomProp);
   procedure DoChanged(Prop: TCustomProp);
   function  DoPropIsStored(Prop: TCustomProp): boolean;
   function  IsNameValid(const AName: string): boolean;
   procedure SavePropValue(Filer: TFlexFiler; const Indent: string;
     Prop: TCustomProp; const PropName: string; IsComplex: boolean);
   procedure LoadPropValue(Filer: TFlexFiler; ComplexProp: TCustomProp;
     const First: string);
  public
   constructor Create(AOwner: TObject{TFlexControl});
   destructor Destroy; override;
   procedure BeginResolve;
   procedure EndResolve;
   procedure Clear;
   function  Add(Prop: TCustomProp; const AName: string): integer;
   function  IndexOf(Prop: TCustomProp): integer;
   function  IsReadOnly(Prop: TCustomProp): boolean;
   function  VisibleIndexOf(Prop: TCustomProp): integer;
   function  GetRealIndex(VisibleIndex: integer): integer;
   function  GetVisibleIndex(RealIndex: integer): integer;
   procedure Delete(Index: integer);
   function  SaveToFiler(Filer: TFlexFiler; const Indent: string): boolean;
   procedure LoadFromFiler(Filer: TFlexFiler; const First: string;
     RefList: TPropRefList);
   property  Owner: TObject read FOwner;
   property  Count: integer read GetPropsCount;
   property  Props[const Name: string]: TCustomProp read GetPropByName; default;
   property  PropNames[Index: integer]: string read GetPropName;
   property  ByIndex[Index: integer]: TCustomProp read GetPropByIndex;
   property  VisibleCount: integer read GetVisibleCount;
   property  VisibleProps[Index: integer]: TCustomProp read GetVisibleProp;
   property  VisiblePropNames[Index: integer]: string read GetVisiblePropName;
   property  Resolving: boolean read GetResolving;
   property  OnPropChanged: TPropChangedEvent read FOnPropChanged
     write FOnPropChanged;
   property  OnPropBeforeChanged: TPropChangedEvent read FOnPropBeforeChanged
     write FOnPropBeforeChanged;
   property  OnPropStored: TPropStoredEvent read FOnPropStored
     write FOnPropStored;
   property  OnPropReadOnly: TPropReadOnlyEvent read FOnPropReadOnly
     write FOnPropReadOnly;
  end;

var
  ResolvePictureLink: TPictureLinkResolve;

procedure RegisterDefaultPropEditForm(PropClass: TCustomPropClass;
  EditFormClass: TEditFormClass);

implementation

type
  PEditFormReg = ^TEditFormReg;
  TEditFormReg = record
   PropClass: TCustomPropClass;
   EditFormClass: TEditFormClass;
  end;

var
  DefaultPropEditors: TList;

procedure RegisterDefaultPropEditForm(PropClass: TCustomPropClass;
  EditFormClass: TEditFormClass);
var Reg: PEditFormReg;
    i: integer;
begin
 if not Assigned(DefaultPropEditors) then
  DefaultPropEditors := TList.Create
 else
  for i:=0 to DefaultPropEditors.Count-1 do
   if PEditFormReg(DefaultPropEditors[i]).PropClass = PropClass then begin
    PEditFormReg(DefaultPropEditors[i]).EditFormClass := EditFormClass;
    exit;
   end;
 New(Reg);
 try
  Reg.PropClass := PropClass;
  Reg.EditFormClass := EditFormClass;
  DefaultPropEditors.Add(Reg);
 except
  Dispose(Reg);
  raise;
 end;
end;

function FindDefaultPropEditForm(PropClass: TCustomPropClass): TEditFormClass;
var i: integer;
begin
 Result := Nil;
 if Assigned(DefaultPropEditors) then
 for i:=0 to DefaultPropEditors.Count-1 do
  if PEditFormReg(DefaultPropEditors[i]).PropClass = PropClass then begin
   Result := PEditFormReg(DefaultPropEditors[i]).EditFormClass;
   break;
  end;
end;

procedure ClearRegEditForms;
var i: integer;
begin
 if not Assigned(DefaultPropEditors) then exit;
 for i:=0 to DefaultPropEditors.Count-1 do
  Dispose(PEditFormReg(DefaultPropEditors[i]));
 DefaultPropEditors.Free;
 DefaultPropEditors := Nil;
end;

// TCustomProp ///////////////////////////////////////////////////////////

constructor TCustomProp.Create(AOwner: TPropList; const AName: string);
begin
 inherited Create;
 if Assigned(AOwner) then AOwner.Add(Self, AName);
 FStyle := [ psVisible ];
 FEditFormClass := FindDefaultPropEditForm(TCustomPropClass(ClassType));
 if Assigned(FEditFormClass) then Include(FStyle, psEditForm);
end;

destructor TCustomProp.Destroy;
begin
 inherited;
end;

procedure TCustomProp.DoBeforeChanged;
begin
 if Assigned(FOwner) then FOwner.DoBeforeChanged(Self);
end;

procedure TCustomProp.DoChanged;
begin
 if Assigned(FOwner) then FOwner.DoChanged(Self);
end;

procedure TCustomProp.SetStyle(const Value: TPropStyle);
begin
 FStyle := Value;
end;

procedure TCustomProp.Setup(Canvas: TCanvas; Scale: integer = 100);
begin
 // ABSTRACT //
end;

procedure TCustomProp.GetEnumList(List: TStrings);
begin
 // ABSTRACT //
end;

function TCustomProp.GetDisplayValue: string;
begin
 // GENERIC //
 Result := '(' + ClassName + ')';
end;

procedure TCustomProp.SetDisplayValue(const Value: string);
begin
 // GENERIC //
 SetPropValue('', Value);
end;

function TCustomProp.Edit: boolean;
var EditForm: TCustomForm;
begin
 Result := False;
 if not (psEditForm in FStyle) or not Assigned(FEditFormClass) then exit;
 EditForm := FEditFormClass.Create(Nil);
 try
  EditForm.Tag := integer(Self);
  Result := EditForm.ShowModal = mrOk;
 finally
  EditForm.Free;
 end;
end;

procedure TCustomProp.GetPropNames(StrList: TStrings);
var TypeInfo: PTypeInfo;
    TypeData: PTypeData;
    PropList: PPropList;
    i: integer;
begin
 PropList := Nil;
 StrList.BeginUpdate;
 with StrList do
 try
  TypeInfo := Self.ClassInfo;
  if not Assigned(TypeInfo) then exit;
  TypeData := GetTypeData(TypeInfo);
  if not Assigned(TypeData) then exit;
  GetMem(PropList, TypeData.PropCount * SizeOf(Pointer));
  GetPropInfos(TypeInfo, PropList);
  for i:=0 to TypeData.PropCount-1 do
   StrList.Add(PropList[i].Name);
 finally
  EndUpdate;
  if Assigned(PropList) then FreeMem(PropList);
 end;
end;

function TCustomProp.GetPropValue(const PropName: string): variant;
begin
 if PropName <> '' then
  {$IFDEF FG_D5}
  Result := TypInfo.GetPropValue(Self, PropName, true)
  {$ELSE}
  Result := FlexUtils.GetPropValue(Self, PropName, true)
  {$ENDIF}
 else
  VarClear(Result);
end;

procedure TCustomProp.SetPropValue(const PropName: string; Value: variant);
begin