Delphi 2.0 - Programmer's Utilities Power Pack/Delphi 2.0 Programmer's Utilities Power Pack.iso/s_to_z/xtool/xtreg.pas

Pascal/Delphi Source File | 1996-09-15 | 7.0 KB | 250 lines

unit Xtreg;

interface

uses Classes, SysUtils, DsgnIntf, Consts;

procedure Register;

implementation

uses Db, DbTables, DbNextNo, DSDesign, TypInfo, Toolbar;

{ ======================================================================= }
{ design stuff for TButtonBmp                                             }
{ ======================================================================= }
type
  TButtonEntry = record
    Value : TButtonBmp;
    Name  : PChar;
  end;

const
  _Buttons: array[0..34] of TButtonEntry = (
   (Value: bbExit;         Name: 'bbExit'),
   (Value: bbCalender;     Name: 'bbCalender'),
   (Value: bbCopy;         Name: 'bbCopy'),
   (Value: bbScissor;      Name: 'bbScissor'),
   (Value: bbCut;          Name: 'bbCut'),
   (Value: bbFont;         Name: 'bbFont'),
   (Value: bbHelp;         Name: 'bbHelp'),
   (Value: bbIdea;         Name: 'bbIdea'),
   (Value: bbLetter;       Name: 'bbLetter'),
   (Value: bbLink;         Name: 'bbLink'),
   (Value: bbOpen;         Name: 'bbOpen'),
   (Value: bbFile;         Name: 'bbFile'),
   (Value: bbKey;          Name: 'bbKey'),
   (Value: bbNotebook;     Name: 'bbNotebook'),
   (Value: bbClipBrd;      Name: 'bbClipBrd'),
   (Value: bbPhone;        Name: 'bbPhone'),
   (Value: bbPrint;        Name: 'bbPrint'),
   (Value: bbSave;         Name: 'bbSave'),
   (Value: bbFloppy;       Name: 'bbFloppy'),
   (Value: bbSearch;       Name: 'bbSearch'),
   (Value: bbRuler;        Name: 'bbRuler'),
   (Value: bbTimer;        Name: 'bbTimer'),
   (Value: bbWaste;        Name: 'bbWaste'),
   (Value: bbUndo;         Name: 'bbUndo'),
   (Value: bbClear;        Name: 'bbClear'),
   (Value: bbBrowse;       Name: 'bbBrowse'),
   (Value: bbCancel;       Name: 'bbCancel'),
   (Value: bbTrash;        Name: 'bbTrash'),
   (Value: bbFirst;        Name: 'bbFirst'),
   (Value: bbNew;          Name: 'bbNew'),
   (Value: bbLast;         Name: 'bbLast'),
   (Value: bbNext;         Name: 'bbNext'),
   (Value: bbOk;           Name: 'bbOk'),
   (Value: bbPrinter;      Name: 'bbPrinter'),
   (Value: bbPrior;        Name: 'bbPrior'));

{ ----------------------------------------------------------------------- }

procedure GetButtonValues(Proc: TGetStrProc);
var
  I: Integer;
begin
  for I := Low(_Buttons) to High(_Buttons) do
    Proc(StrPas(_Buttons[I].Name));
end;

{ ----------------------------------------------------------------------- }

function ButtonToIdent(Button: Integer; var Ident: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := Low(_Buttons) to High(_Buttons) do
    if _Buttons[I].Value = Button then
    begin
      Result := True;
      Ident := StrPas(_Buttons[I].Name);
      Exit;
    end;
end;

function ButtonToString(Button: TButtonBmp): string;
begin
  if not ButtonToIdent(Button, Result) then
    Result:=IntToStr(Button);
end;

{ ----------------------------------------------------------------------- }

function IdentToButton(const Ident: string; var Button: Integer): Boolean;
var
  I: Integer;
  Text: array[0..63] of Char;
begin
  Result := False;
  StrPLCopy(Text, Ident, SizeOf(Text) - 1);
  for I := Low(_Buttons) to High(_Buttons) do
    if StrIComp(_Buttons[I].Name, Text) = 0 then
    begin
      Result := True;
      Button:= _Buttons[I].Value;
      Exit;
    end;
end;

{ ----------------------------------------------------------------------- }

function StringToButton(S: string): TButtonBmp;
var
  L: Longint;
  E: Integer;
begin
  if not IdentToButton(S, Integer(Result)) then
  begin
    Val(S, L, E);
    if E <> 0 then raise Exception.Create(LoadStr(SInvalidInteger));
    if (L < Low(TButtonBmp)) or (L > High(TButtonBmp)) then
      raise Exception.Create(
        FmtLoadStr(SOutOfRange, [Low(TButtonBmp), High(TButtonBmp)]));
    Result := TButtonBmp(L);
  end;
end;



{ TButtonProperty
  Property editor for the TBmpIndex type.  Displays the button
  as a btnXXXX value if one exists, otherwise displays the value as integer.
  Also allows the btnXXX value to be picked from a list. }
type
  TButtonProperty = class(TIntegerProperty)
  public
    function  GetAttributes: TPropertyAttributes; override;
    function  GetValue: string; override;
    procedure GetValues(Proc: TGetStrProc); override;
    procedure SetValue(const Value: string); override;
  end;


{ TButtonProperty }

function TButtonProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paMultiSelect, paValueList];
end;

function TButtonProperty.GetValue: string;
begin
  Result := ButtonToString(TButtonBmp(GetOrdValue));
end;

procedure TButtonProperty.GetValues(Proc: TGetStrProc);
begin
  GetButtonValues(Proc);
end;

procedure TButtonProperty.SetValue(const Value: string);
var
  NewValue: Integer;
begin
  if IdentToButton(Value, NewValue) then
    SetOrdValue(NewValue)
  else inherited SetValue(Value);
end;

{ TDBStringProperty }

type
  TDBStringProperty = class(TStringProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure GetValueList(List: TStrings); virtual; abstract;
    procedure GetValues(Proc: TGetStrProc); override;
  end;

function TDBStringProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paValueList, paSortList, paMultiSelect];
end;

procedure TDBStringProperty.GetValues(Proc: TGetStrProc);
var
  I: Integer;
  Values: TStringList;
begin
  Values := TStringList.Create;
  try
    GetValueList(Values);
    for I := 0 to Values.Count - 1 do Proc(Values[I]);
  finally
    Values.Free;
  end;
end;

{ TDataFieldProperty }

type
  TDataFieldProperty = class(TDBStringProperty)
  public
    function GetDataSourcePropName: string; virtual;
    procedure GetValueList(List: TStrings); override;
  end;

function TDataFieldProperty.GetDataSourcePropName: string;
begin
  Result := 'DataSource';
end;

procedure TDataFieldProperty.GetValueList(List: TStrings);
var
  Instance: TComponent;
  PropInfo: PPropInfo;
  DataSource: TDataSource;
begin
  Instance := GetComponent(0);
  PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, GetDataSourcePropName);
  if (PropInfo <> nil) and (PropInfo^.PropType^.Kind = tkClass) then
  begin
    DataSource := TObject(GetOrdProp(Instance, PropInfo)) as TDataSource;
    if (DataSource <> nil) and (DataSource.DataSet <> nil) then
      DataSource.DataSet.GetFieldNames(List);
  end;
end;

{ TNextNoFieldProperty }

type
  TNextNoFieldProperty = class(TDataFieldProperty)
  public
    function GetDataSourcePropName: string; override;
  end;

function TNextNoFieldProperty.GetDataSourcePropName: string;
begin
  Result := 'NextNoSource';
end;

procedure Register;
begin
  RegisterPropertyEditor(TypeInfo(string), TDbNextNo, 'KeyField', TNextNoFieldProperty);
  RegisterPropertyEditor(TypeInfo(string), TDbNextNo, 'NoField', TNextNoFieldProperty);
  RegisterPropertyEditor(TypeInfo(TButtonBmp), nil, 'Button', TButtonProperty);
end;

end.