peparade.pas

Delphi高级开发指南是开发程序的好帮手

unit PeParade;

interface

uses
  DsgnIntf, StdCtrls, SysUtils, Windows,
  Graphics, Classes, Controls, TypInfo, Forms;

type
  // special button component to test the editors
  TDdhDummyButton = class (TButton)
  end;

  TDdhDummyLabel = class (TLabel)
  end;

  // uppercase string property editor
  TUpperProperty = class (TStringProperty)
  public
    function GetValue: string; override;
    procedure SetValue (const Value: string); override;
  end;

  // paValueList demo: list of integers
  TNumListProperty = class (TIntegerProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure GetValues(Proc: TGetStrProc); override;
  end;

  // paReadOnly + paSorted: list of hints
  THintListProperty = class (TStringProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure GetValues(Proc: TGetStrProc); override;
  end;

  // paSubProperties: the sub-colors
  TSubColorProperty = class (TColorProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure GetProperties(Proc: TGetPropEditProc); override;
  end;

  // paDialog: the integer spin editor
  TDialogIntProperty = class (TIntegerProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure Edit; override;
  end;

  // paAutoUpdate: the jumping component
  TAutoIntegerProperty = class (TIntegerProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
  end;

// hack //

type
  THackColorElementProperty = class
  private
    FDesigner: TFormDesigner;
    FPropList: PInstPropList;
    FPropCount: Integer;
    fElement: Integer;
    function GetPrivateDirectory: string;
    procedure SetPropEntry(Index: Integer; AInstance: TComponent;
      APropInfo: PPropInfo);
  protected
    constructor Create(Element: Integer; ADesigner: TFormDesigner;
      AInstance: TComponent; APropInfo: PPropInfo);
    function GetPropInfo: PPropInfo;
    function GetFloatValue: Extended;
    function GetFloatValueAt(Index: Integer): Extended;
    function GetMethodValue: TMethod;
    function GetMethodValueAt(Index: Integer): TMethod;
    function GetOrdValue: Longint;
    function GetOrdValueAt(Index: Integer): Longint;
    function GetStrValue: string;
    function GetStrValueAt(Index: Integer): string;
    function GetVarValue: Variant;
    function GetVarValueAt(Index: Integer): Variant;
    procedure Modified;
    procedure SetFloatValue(Value: Extended);
    procedure SetMethodValue(const Value: TMethod);
    procedure SetOrdValue(Value: Longint);
    procedure SetStrValue(const Value: string);
    procedure SetVarValue(const Value: Variant);
  public
    destructor Destroy; override;
    procedure Activate; virtual;
    function AllEqual: Boolean; virtual;
    procedure Edit; virtual;
    function GetAttributes: TPropertyAttributes; virtual;
    function GetComponent(Index: Integer): TPersistent;
    function GetEditLimit: Integer; virtual;
    function GetName: string; virtual;
    procedure GetProperties(Proc: TGetPropEditProc); virtual;
    function GetPropType: PTypeInfo;
    function GetValue: string; virtual;
    procedure GetValues(Proc: TGetStrProc); virtual;
    procedure Initialize; virtual;
    procedure Revert;
    procedure SetValue(const Value: string); virtual;
    function ValueAvailable: Boolean;
    property Designer: TFormDesigner read FDesigner;
    property PrivateDirectory: string read GetPrivateDirectory;
    property PropCount: Integer read FPropCount;
    property Value: string read GetValue write SetValue;
  end;

procedure Register;

//////////////////////////////////////////////////

implementation

uses
  PefSpin, Consts;

// TUpperProperty class

function TUpperProperty.GetValue: string;
begin
  // show the value as uppercase
  Result := UpperCase (inherited GetValue);
end;

procedure TUpperProperty.SetValue (const Value: string);
begin
  // force the string to uppercase when saving
  inherited SetValue (UpperCase (Value));
end;

// TNumListProperty class

function TNumListProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paValueList];
end;

procedure TNumListProperty.GetValues(Proc: TGetStrProc);
var
  I: Integer;
begin
  I := 10;
  while I <= 300 do
  begin
    Proc (IntToStr (I));
    I := I + 10;
  end;
end;

// THintListProperty class

function THintListProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paValueList, paReadOnly, paSortList];
end;

procedure THintListProperty.GetValues(Proc: TGetStrProc);
begin
  Proc ('Press the button, please');
  Proc ('You are kindly requested to press me');
  Proc ('I''m a button');
  Proc ('Do NOT press me!');
  Proc ('The ' + (GetComponent(0) as TComponent).Name
    + ' button');
end;

// TSubColorProperty class

(* non working version
type
  TColorElementProperty = class (TIntegerProperty)
  private
    fElement: Integer;
    fSubColP: TSubColorProperty;
  public
    constructor Create (Element: Integer;
      Designer: TFormDesigner; PropCount: Integer);
    function GetName: string; override;
    function GetValue: string; override;
    procedure SetValue(const Value: string); override;
  end;*)

// changed...
constructor THackColorElementProperty.Create(
  Element: Integer; ADesigner: TFormDesigner;
  AInstance: TComponent; APropInfo: PPropInfo);
begin
  // store the value
  FDesigner := ADesigner;
  // there is only one component
  FPropCount := 1;
  GetMem (FPropList, 1 * SizeOf(TInstProp));
  // with the following description
  with FPropList^[0] do
  begin
    Instance := AInstance;
    PropInfo := APropInfo;
  end;
  // this is the editor code
  FElement := Element;
end;

destructor THackColorElementProperty.Destroy;
begin
  if FPropList <> nil then
    FreeMem(FPropList, FPropCount * SizeOf(TInstProp));
end;

procedure THackColorElementProperty.Activate;
begin
end;

function THackColorElementProperty.AllEqual: Boolean;
begin
  Result := FPropCount = 1;
end;

procedure THackColorElementProperty.Edit;
type
  TGetStrFunc = function(const Value: string): Integer of object;
var
  I: Integer;
  Values: TStringList;
  AddValue: TGetStrFunc;
begin
  Values := TStringList.Create;
  Values.Sorted := paSortList in GetAttributes;
  try
    AddValue := Values.Add;
    GetValues(TGetStrProc(AddValue));
    if Values.Count > 0 then
    begin
      I := Values.IndexOf(Value) + 1;
      if I = Values.Count then I := 0;
      Value := Values[I];
    end;
  finally
    Values.Free;
  end;
end;

function THackColorElementProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paMultiSelect, paRevertable];
end;

function THackColorElementProperty.GetComponent(Index: Integer): TPersistent;
begin
  Result := FPropList^[Index].Instance;
end;

function THackColorElementProperty.GetFloatValue: Extended;
begin
  Result := GetFloatValueAt(0);
end;

function THackColorElementProperty.GetFloatValueAt(Index: Integer): Extended;
begin
  with FPropList^[Index] do Result := GetFloatProp(Instance, PropInfo);
end;

function THackColorElementProperty.GetMethodValue: TMethod;
begin
  Result := GetMethodValueAt(0);
end;

function THackColorElementProperty.GetMethodValueAt(Index: Integer): TMethod;
begin
  with FPropList^[Index] do Result := GetMethodProp(Instance, PropInfo);
end;

function THackColorElementProperty.GetEditLimit: Integer;
begin
  Result := 255;
end;

// changed...
function THackColorElementProperty.GetName: string;
begin
  case fElement of
    0: Result := 'Red';
    1: Result := 'Green';
    2: Result := 'Blue';
  end;
end;

function THackColorElementProperty.GetOrdValue: Longint;
begin
  Result := GetOrdValueAt(0);
end;

function THackColorElementProperty.GetOrdValueAt(Index: Integer): Longint;
begin
  with FPropList^[Index] do Result := GetOrdProp(Instance, PropInfo);
end;

function THackColorElementProperty.GetPrivateDirectory: string;
begin