flexprops.pas

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

/////////////////////////////////////////////////////////
//                                                     //
//    FlexGraphics library                             //
//    Copyright (c) 2002-2003, FlexGraphics software.  //
//                                                     //
//    Properties support                               //
//                                                     //
/////////////////////////////////////////////////////////

unit FlexProps;

{$I FlexDefs.inc}

interface

uses
  Windows, Classes, Graphics, Forms, Controls, SysUtils,
  Dialogs, TypInfo, Jpeg, {$IFDEF FG_D6} Variants, {$ENDIF}
  FlexUtils;

{$TYPEINFO ON}

type
  TPropType = ( ptSimple, ptComplex, ptStrList, ptHexData );

  TPropStyleItem = ( psReadOnly, psVisible, psDontStore, psNonVisual,
                     psDisplayEdit, psEditForm, psScalable, psRef );
  TPropStyle = set of TPropStyleItem;

  TPropList = class;
  TCustomProp = class;

  TEditFormClass = class of TCustomForm;
  TCustomPropClass = class of TCustomProp;

  TPropChangedEvent = procedure(Sender: TObject; Prop: TCustomProp) of object;
  TPropStoredEvent = procedure(Sender: TObject; Prop: TCustomProp;
    var IsStored: boolean) of object;
  TPropReadOnlyEvent = procedure(Sender: TObject; Prop: TCustomProp;
    var IsReadOnly: boolean) of object;
  TPictureLinkResolve = procedure(Sender: TObject; const LinkName: string;
    APicture: TPicture);

  TCustomProp = class
  private
   FOwner: TPropList;
   FStyle: TPropStyle;
   FEditFormClass: TEditFormClass;
   procedure SetStyle(const Value: TPropStyle);
  protected
   FPropType: TPropType;
   FIsEnum: boolean;
   function  GetDisplayValue: string; virtual;
   procedure SetDisplayValue(const Value: string); virtual;
   procedure DoBeforeChanged; virtual;
   procedure DoChanged; virtual;
   procedure GetPropNames(StrList: TStrings);
   procedure SetPropValue(const PropName: string; Value: Variant); virtual;
   function  GetPropValue(const PropName: string): Variant; virtual;
   function  GetPropType(const PropName: string): TPropType; virtual;
  public
   constructor Create(AOwner: TPropList; const AName: string);
   destructor Destroy; override;
   procedure Setup(Canvas: TCanvas; Scale: integer = 100); virtual;
   function  Edit: boolean; virtual;
   procedure GetEnumList(List: TStrings); virtual;
   property  Owner: TPropList read FOwner write FOwner;
   property  Style: TPropStyle read FStyle write SetStyle;
   property  PropType: TPropType read FPropType;
   property  DisplayValue: string read GetDisplayValue write SetDisplayValue;
   property  IsEnum: boolean read FIsEnum;
   property  EditFormClass: TEditFormClass read FEditFormClass
     write FEditFormClass;
  end;

  TEnumProp = class(TCustomProp)
  private
   FEnumIndex: integer;
   FEnumList: TStrings;
   function  GetEnumCount: integer;
  protected
   function  GetDisplayValue: string; override;
   procedure SetEnumIndex(Value: integer); virtual;
   property  EnumList: TStrings read FEnumList write FEnumList;
  public
   constructor Create(AOwner: TPropList; const AName: string);
   destructor Destroy; override;
   procedure SetPropValue(const PropName: string; Value: Variant); override;
   function  GetPropValue(const PropName: string): Variant; override;
   function  AddItem(const s: string): integer;
   procedure GetEnumList(List: TStrings); override;
   property  EnumIndex: integer read FEnumIndex write SetEnumIndex;
   property  EnumCount: integer read GetEnumCount;
  end;

  TBoolProp = class(TEnumProp)
  private
   procedure SetValue(Value: boolean);
   function  GetValue: boolean;
  public
   constructor Create(AOwner: TPropList; const AName: string);
   property  Value: boolean read GetValue write SetValue;
  end;

  TGetIntEvent = procedure(Sender: TObject; out Value: integer) of object;

  TIntProp = class(TCustomProp)
  private
   FValue: integer;
   FOnGetValue: TGetIntEvent;
   procedure SetValue(Value: integer);
   function  GetValue: integer;
  protected
   function  GetDisplayValue: string; override;
   procedure SetDisplayValue(const Value: string); override;
  public
   constructor Create(AOwner: TPropList; const AName: string);
   procedure SetPropValue(const PropName: string; Value: Variant); override;
   function  GetPropValue(const PropName: string): Variant; override;
   property  Value: integer read GetValue write SetValue;
   property  SavedValue: integer read FValue;
   property  OnGetValue: TGetIntEvent read FOnGetValue write FOnGetValue;
  end;

  TLongWordProp = class(TCustomProp)
  private
   FValue: LongWord;
   procedure SetValue(Value: LongWord);
  protected
   function  GetDisplayValue: string; override;
   procedure SetDisplayValue(const Value: string); override;
  public
   constructor Create(AOwner: TPropList; const AName: string);
   procedure SetPropValue(const PropName: string; Value: Variant); override;
   function  GetPropValue(const PropName: string): Variant; override;
   property  Value: LongWord read FValue write SetValue;
  end;

  TGetStringEvent = procedure(Sender: TObject; out s: string) of object;

  TStrProp = class(TCustomProp)
  private
   FValue: string;
   FOnGetString: TGetStringEvent;
   procedure SetValue(const Value: string);
   function  GetValue: string;
  protected
   function  GetDisplayValue: string; override;
  public
   constructor Create(AOwner: TPropList; const AName: string);
   procedure SetPropValue(const PropName: string; Value: Variant); override;
   function  GetPropValue(const PropName: string): Variant; override;
   property  Value: string read GetValue write SetValue;
   property  SavedValue: string read FValue;
   property  OnGetString: TGetStringEvent read FOnGetString write FOnGetString;
  end;

  TStrListProp = class(TCustomProp)
  private
   FStrList: TStringList;
   procedure SetText(const Value: TCaption);
   function  GetLine(Index: integer): string;
   function  GetLinesCount: integer;
   function  GetText: TCaption;
   procedure SetLine(Index: integer; const Value: string);
   function  GetName(Index: integer): string;
   function  GetValue(const Name: string): string;
   function  GetValueByIndex(Index: integer): string;
   procedure SetValue(const Name, Value: string);
   procedure SetValueByIndex(Index: integer; const Value: string);
   procedure SetName(Index: integer; const Value: string);
  protected
   function  GetDisplayValue: string; override;
  public
   constructor Create(AOwner: TPropList; const AName: string);
   destructor Destroy; override;
   procedure SetPropValue(const PropName: string; Value: Variant); override;
   function  GetPropValue(const PropName: string): Variant; override;
   procedure Assign(Source: TStrings);
   procedure AssignTo(Dest: TStrings);
   procedure Clear;
   function  Add(const s: string): integer;
   function  Insert(Index: Integer; const S: string): boolean;
   procedure Delete(Index: integer);
   function  IndexOf(const s: string): integer;
   function  IndexOfName(const s: string): integer;
   property  LinesCount: integer read GetLinesCount;
   property  Lines[Index: integer]: string read GetLine write SetLine; default;
   property  Names[Index: integer]: string read GetName write SetName;
   property  Values[const Name: string]: string read GetValue write SetValue;
   property  ValuesByIndex[Index: integer]: string read GetValueByIndex
     write SetValueByIndex;
   property  Text: TCaption read GetText write SetText;
  end;

  TUserDataProp = class(TStrListProp);

  TPropDataEvent = procedure(Sender: TObject; var Value: Variant) of object;

  TDataProp = class(TCustomProp)
  private
   FOnGetPropData: TPropDataEvent;
   FOnSetPropData: TPropDataEvent;
  protected
   function  GetDisplayValue: string; override;
  public
   constructor Create(AOwner: TPropList; const AName: string);
   procedure SetPropValue(const PropName: string; Value: Variant); override;
   function  GetPropValue(const PropName: string): Variant; override;
   property  OnGetPropData: TPropDataEvent read FOnGetPropData
     write FOnGetPropData;
   property  OnSetPropData: TPropDataEvent read FOnSetPropData
     write FOnSetPropData;
  end;

  TBrushMethod = ( bmHatch, bmGradient, bmBitmap );

  TBrushProp = class(TCustomProp)
  private
   FBrush: TBrush;
   FMethod: TBrushMethod;
   FGradStyle: TGradientStyle;
   FGradBeginColor: TColor;
   FGradEndColor: TColor;
   FBitmap: TBitmap;
   FBitmapMasked: boolean;
   FBitmapMaskColor: TColor;
   function  GetColor: TColor;
   function  GetStyle: TBrushStyle;
   procedure SetColor(const Value: TColor);
   procedure SetStyle(const Value: TBrushStyle);
   procedure SetGradBeginColor(const Value: TColor);
   procedure SetGradEndColor(const Value: TColor);
   procedure SetGradStyle(const Value: TGradientStyle);
   function  GetIsPaintAlternate: boolean;
   procedure SetBitmap(const Value: TBitmap);
   procedure SetBitmapMaskColor(const Value: TColor);
   procedure SetBitmapMasked(const Value: boolean);   
   procedure SetMethod(const Value: TBrushMethod);
   function  GetIsClear: boolean;
   function  StoreBitmap: Boolean;
   function  StoreBeginColor: Boolean;
   function  StoreEndColor: Boolean;
   function  StoreGradStyle: Boolean;
   function  StoreMethod: Boolean;
   function  StoreStyle: Boolean;
   function  StoreColor: Boolean;
   function  StoreBitmapMasked: Boolean;
   function  StoreBitmapMaskColor: Boolean;
  protected
   function  GetDisplayValue: string; override;
   procedure BitmapChange(Sender: TObject); virtual; 
  public
   constructor Create(AOwner: TPropList; const AName: string);
   destructor Destroy; override;
   procedure Setup(Canvas: TCanvas; Scale: integer = 100); override;
   procedure Translate(const TranslateInfo: TTranslateInfo); virtual;
   function  GetPropType(const PropName: string): TPropType; override;
   function  GetPropValue(const PropName: string): Variant; override;
   procedure SetPropValue(const PropName: string; Value: Variant); override;
   procedure PaintAlternate(Canvas: TCanvas; var PaintRect: TRect;
     const RefreshRect: TRect);
   property  IsPaintAlternate: boolean read GetIsPaintAlternate;
   property  IsClear: boolean read GetIsClear;
  published
   property  Method: TBrushMethod read FMethod write SetMethod
     stored StoreMethod;
   property  Color: TColor read GetColor write SetColor stored StoreColor;
   property  Style: TBrushStyle read GetStyle write SetStyle stored StoreStyle;
   property  Bitmap: TBitmap read FBitmap write SetBitmap stored StoreBitmap;
   property  BitmapMasked: boolean read FBitmapMasked write SetBitmapMasked
     stored StoreBitmapMasked;
   property  BitmapMaskColor: TColor read FBitmapMaskColor
     write SetBitmapMaskColor stored StoreBitmapMaskColor;
   property  GradStyle: TGradientStyle read FGradStyle write SetGradStyle
     stored StoreGradStyle;
   property  GradBeginColor: TColor read FGradBeginColor write SetGradBeginColor
     stored StoreBeginColor;
   property  GradEndColor: TColor read FGradEndColor write SetGradEndColor
     stored StoreEndColor;
  end;

  TPenProp = class(TCustomProp)
  private
   FPen: TPen;
   function  GetColor: TColor;
   function  GetStyle: TPenStyle;
   procedure SetColor(const Value: TColor);
   procedure SetStyle(const Value: TPenStyle);
   function  GetWidth: integer;
   procedure SetWidth(const Value: integer);
   function  GetActiveWidth: integer;
   function  GetMode: TPenMode;
   procedure SetMode(const Value: TPenMode);
   function  StoreColor: Boolean;
   function  StoreMode: Boolean;
   function  StoreStyle: Boolean;
   function  StoreWidth: Boolean;
  protected
   function  GetDisplayValue: string; override;
  public
   constructor Create(AOwner: TPropList; const AName: string);
   destructor Destroy; override;
   procedure Setup(Canvas: TCanvas; Scale: integer = 100); override;
   property  ActiveWidth: integer read GetActiveWidth;
  published
   property  Color: TColor read GetColor write SetColor stored StoreColor;
   property  Style: TPenStyle read GetStyle write SetStyle stored StoreStyle;
   property  Mode: TPenMode read GetMode write SetMode stored StoreMode;
   property  Width: integer read GetWidth write SetWidth stored StoreWidth;
  end;

  TFontProp = class(TCustomProp)
  private
   FFont: TFont;
   FFontHeight: integer; 
   function  GetCharset: TFontCharset;
   function  GetHandle: HFont;
   function  GetSize: Integer;
   function  GetName: TFontName;
   function  GetPitch: TFontPitch;
   function  GetStyle: TFontStyles;
   function  GetColor: TColor;
   function  GetPixelsPerInch: Integer;
   procedure SetCharset(const Value: TFontCharset);
   procedure SetColor(const Value: TColor);
   procedure SetHandle(const Value: HFont);
   procedure SetHeight(const Value: Integer);
   procedure SetName(const Value: TFontName);
   procedure SetPitch(const Value: TFontPitch);
   procedure SetSize(const Value: Integer);
   procedure SetStyle(const Value: TFontStyles);
   procedure SetPixelsPerInch(const Value: Integer);
   function  StoreCharset: Boolean;
   function  StoreColor: Boolean;
   function  StorePitch: Boolean;
   function  StoreStyle: Boolean;