Мастер создания компонент

Delphi , Компоненты и Классы , Создание компонент

unit ExpCompF;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, StdCtrls, ComCtrls, Buttons, ExtCtrls, Menus, FileCtrl, ExptIntf;

type
  // expert form
  TCompWizForm = class(TForm)
    PageControl1: TPageControl;
    SheetMain: TTabSheet;
    SheetProperties: TTabSheet;
    SheetSingle: TTabSheet;
    Label1: TLabel;
    EditClassName: TEdit;
    Label2: TLabel;
    Label3: TLabel;
    EditUnitName: TEdit;
    StringGridProps: TStringGrid;
    Label4: TLabel;
    Label5: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    EditPropName: TEdit;
    CheckRead: TCheckBox;
    CheckWrite: TCheckBox;
    EditDefault: TEdit;
    RadioAccess: TRadioGroup;
    BtnRevert: TBitBtn;
    BtnPrev: TBitBtn;
    BtnNext: TBitBtn;
    PopupGrid: TPopupMenu;
    NewProperty1: TMenuItem;
    RemoveProperty1: TMenuItem;
    Label6: TLabel;
    LabelPropNo: TLabel;
    SheetPreview: TTabSheet;
    MemoPreview: TMemo;
    Panel1: TPanel;
    BitBtnGenerate: TBitBtn;
    BitBtnClose: TBitBtn;
    BitBtnExit: TBitBtn;
    ComboParentClass: TComboBox;
    ComboPage: TComboBox;
    ComboTypeName: TComboBox;
    procedure FormCreate(Sender: TObject);
    procedure StringGridPropsSelectCell(Sender: TObject; Col, Row: Longint;
      var CanSelect: Boolean);
    procedure PageControl1Change(Sender: TObject);
    procedure BtnPrevClick(Sender: TObject);
    procedure NewProperty1Click(Sender: TObject);
    procedure RemoveProperty1Click(Sender: TObject);
    procedure BtnNextClick(Sender: TObject);
    procedure BtnRevertClick(Sender: TObject);
    procedure EditClassNameExit(Sender: TObject);
    procedure PageControl1Changing(Sender: TObject;
      var AllowChange: Boolean);
    procedure BitBtnGenerateClick(Sender: TObject);
    procedure BitBtnCloseClick(Sender: TObject);
  private
    CurrProp, TotProps: Integer;
    function GetProp(Prop: Integer): string;
    function GetType(Prop: Integer): string;
    function GetRead(Prop: Integer): string;
    function GetWrite(Prop: Integer): string;
    function GetAccess(Prop: Integer): string;
    function GetDefault(Prop: Integer): string;
    function PropertyDefinition(I: Integer): string;
  public
    procedure UpdateSingle;
    procedure UpdateGrid;
    procedure FillMemo;
  end;

  // standard expert
  TExtCompExp = class(TIExpert)
  public
    function GetStyle: TExpertStyle; override;
    function GetName: string; override;
    function GetAuthor: string; override;
    function GetComment: string; override;
    function GetPage: string; override;
    function GetGlyph: HICON; override;
    function GetState: TExpertState; override;
    function GetIDString: string; override;
    function GetMenuText: string; override;
    procedure Execute; override;
  end;

  // project expert
  TPrjExtCompExp = class(TExtCompExp)
  public
    function GetStyle: TExpertStyle; override;
    function GetName: string; override;
    function GetIDString: string; override;
  end;

var
  CompWizForm: TCompWizForm;

procedure Register;

implementation

{$R *.DFM}

uses
  Registry;

// extended component expert form

function TCompWizForm.GetProp(Prop: Integer): string;
begin
  Result := StringGridProps.Cells[0, Prop];
end;

function TCompWizForm.GetType(Prop: Integer): string;
begin
  Result := StringGridProps.Cells[1, Prop];
end;

function TCompWizForm.GetRead(Prop: Integer): string;
begin
  Result := StringGridProps.Cells[2, Prop];
end;

function TCompWizForm.GetWrite(Prop: Integer): string;
begin
  Result := StringGridProps.Cells[3, Prop];
end;

function TCompWizForm.GetAccess(Prop: Integer): string;
begin
  Result := StringGridProps.Cells[4, Prop];
end;

function TCompWizForm.GetDefault(Prop: Integer): string;
begin
  Result := StringGridProps.Cells[5, Prop];
end;

procedure TCompWizForm.UpdateSingle;
begin
  LabelPropNo.Caption := IntToStr(CurrProp);
  EditPropName.Text := GetProp(CurrProp);
  ComboTypeName.Text := GetType(CurrProp);
  EditDefault.Text := GetDefault(CurrProp);
  CheckRead.Checked := GetRead(CurrProp) <> '';
  CheckWrite.Checked := GetWrite(CurrProp) <> '';
  if GetAccess(CurrProp) <> '' then
    RadioAccess.ItemIndex :=
      RadioAccess.Items.IndexOf(GetAccess(CurrProp));
end;

procedure TCompWizForm.UpdateGrid;
begin
  with StringGridProps do
  begin
    Cells[0, CurrProp] := EditPropName.Text;
    Cells[1, CurrProp] := ComboTypeName.Text;
    if CheckRead.Checked then
      Cells[2, CurrProp] := 'Get' + EditPropName.Text
    else
      Cells[2, CurrProp] := '';
    if CheckWrite.Checked then
      Cells[3, CurrProp] := 'Set' + EditPropName.Text
    else
      Cells[3, CurrProp] := '';
    if RadioAccess.ItemIndex >= 0 then
      Cells[4, CurrProp] := RadioAccess.Items[
        RadioAccess.ItemIndex];
    Cells[5, CurrProp] := EditDefault.Text;
    Row := CurrProp;
  end;
end;

procedure TCompWizForm.FormCreate(Sender: TObject);
var
  nMod, nComp: Integer;
  CompClass: TClass;
  Reg: TRegistry;
begin
  with StringGridProps do
  begin
    Cells[0, 0] := 'property';
    Cells[1, 0] := 'type';
    Cells[2, 0] := 'read';
    Cells[3, 0] := 'write';
    Cells[4, 0] := 'access';
    Cells[5, 0] := 'default';
  end;
  CurrProp := 1;
  TotProps := 1;
  PageControl1.ActivePage := SheetMain;

  // get the list of palette pages
  Reg := TRegistry.Create;
  if Reg.OpenKey(
    'Software\Borland\Delphi\3.0\Palette',
    False) then
    Reg.GetValueNames(ComboPage.Items);
  Reg.Free;

  // special code for the expert
  if ToolServices <> nil then
  begin
    // get the list of installed components
    // plus their parent classes
    for nMod := 0 to
      ToolServices.GetModuleCount - 1 do
      for nComp := 0 to
        ToolServices.GetComponentCount(nMod) - 1 do
      begin
        ComboParentClass.Items.Add(
          ToolServices.GetComponentName(nMod, nComp));
        try
          CompClass := FindClass(ToolServices.
            GetComponentName(nMod, nComp)).ClassParent;
          while (CompClass <> TComponent) and
            (ComboParentClass.Items.IndexOf(
            CompClass.ClassName) = -1) do
          begin
            ComboParentClass.Items.Add(
              CompClass.ClassName);
            CompClass := CompClass.ClassParent;
          end;
        except on E: Exception do
            ShowMessage(E.Message);
        end;
      end;
  end; // end of special expert code
end;

procedure TCompWizForm.StringGridPropsSelectCell(Sender: TObject; Col,
  Row: Longint; var CanSelect: Boolean);
begin
  if (Row <> 0) then
    CurrProp := Row;
end;

procedure TCompWizForm.PageControl1Change(Sender: TObject);
begin
  if PageControl1.ActivePage = SheetSingle then
    UpdateSingle
  else
    UpdateGrid;
  if PageControl1.ActivePage = SheetPreview then
    FillMemo;
end;

procedure TCompWizForm.BtnPrevClick(Sender: TObject);
begin
  UpdateGrid;
  if CurrProp > 1 then
  begin
    Dec(CurrProp);
    UpdateSingle;
  end;
end;

procedure TCompWizForm.NewProperty1Click(Sender: TObject);
begin
  Inc(TotProps);
  StringGridProps.RowCount := StringGridProps.RowCount + 1;
end;

procedure TCompWizForm.RemoveProperty1Click(Sender: TObject);
var
  I: Integer;
begin
  if MessageDlg('Are you sure you want to delete the ' +
    StringGridProps.Cells[0, CurrProp] + ' property?',
    mtConfirmation, [mbYes, mbNo], 0) = idYes then
    // set the line to ''
    for I := 0 to 5 do
      StringGridProps.Cells[I, CurrProp] := '';
end;

procedure TCompWizForm.BtnNextClick(Sender: TObject);
begin
  UpdateGrid;
  if CurrProp < TotProps then
  begin
    Inc(CurrProp);
    UpdateSingle;
  end
  else if MessageDlg('Do you want to add a new property?',
    mtConfirmation, [mbYes, mbNo], 0) = idYes then
  begin
    NewProperty1Click(self);
    Inc(CurrProp);
    UpdateSingle;
  end;
end;

procedure TCompWizForm.BtnRevertClick(Sender: TObject);
begin
  // re-update the value, loosing changes
  UpdateSingle;
end;

function TCompWizForm.PropertyDefinition(I: Integer): string;
begin
  Result := 'property ' + GetProp(I) +
    ': ' + GetType(I);
  if GetRead(I) <> '' then
    Result := Result + ' read ' + GetRead(I)
  else
    Result := Result + ' read f' + GetProp(I);
  if GetWrite(I) <> '' then
    Result := Result + ' write ' + GetWrite(I)
  else
    Result := Result + ' write f' + GetProp(I);
  if GetDefault(I) <> '' then
    Result := Result + ' default ' + GetDefault(I);
  Result := Result + ';'
end;

procedure TCompWizForm.FillMemo;
var
  I: Integer;
begin
  with MemoPreview.Lines do
  begin
    Clear;
    BeginUpdate;
    // intestation
    Add('unit ' + EditUnitName.Text + ';');
    Add('');
    Add('interface');
    Add('');
    Add('uses');
    Add('  Windows, Messages, SysUtils, Classes, Graphics,');
    Add('  Controls, Forms, Dialogs, StdCtrls;');
    Add('');
    Add('type');
    Add('  ' + EditClassName.Text +
      ' = class(' + ComboParentClass.Text + ')');
    Add('  private');
    // add a field for each property
    Add('    {data fields for properties}');
    for I := 1 to TotProps do
      if GetProp(I) <> '' then
        Add('    f' + GetProp(I) + ': ' +
          GetType(I) + ';');

    // add get functions and set procedures
    Add('  protected');
    Add('    {set and get methods}');
    for I := 1 to TotProps do
    begin
      if GetRead(I) <> '' then
        Add('    function ' + GetRead(I) +
          ': ' + GetType(I) + ';');
      if GetWrite(I) <> '' then
        Add('    procedure ' + GetWrite(I) +
          '(Value: ' + GetType(I) + ');');
    end;

    // add public and published properties,
    // plus the constructor
    Add('  public');
    for I := 1 to TotProps do
      if (GetProp(I) <> '') and
        (GetAccess(I) = 'public') then
        Add('    ' + PropertyDefinition(I));
    Add('    constructor Create (AOwner: TComponent); override;');
    Add('  published');
    for I := 1 to TotProps do
      if (GetProp(I) <> '') and
        (GetAccess(I) = 'published') then
        Add('    ' + PropertyDefinition(I));
    Add('  end;');
    Add('');
    Add('procedure Register;');
    Add('');
    Add('implementation');
    Add('');

    // constructor
    Add('constructor ' + EditClassName.Text +
      '.Create (AOwner: TComponent);');
    Add('begin');
    Add('  inherited Create (AOwner);');
    Add('  // set default values');
    for I := 1 to TotProps do
      if (GetProp(I) <> '') and (GetDefault(I) <> '') then
        Add('  f' + GetProp(I) + ' := ' + GetDefault(I) + ';');
    Add('end;');
    Add('');
    // rough code of the functions
    Add('{property access functions}');
    Add('');
    for I := 1 to TotProps do
    begin
      if GetRead(I) <> '' then
      begin
        Add('function ' + EditClassName.Text + '.' +
          GetRead(I) + ': ' + GetType(I) + ';');
        Add('begin');
        Add('  Result := f' + GetProp(I) + ';');
        Add('end;');
        Add('');
      end;
      if GetWrite(I) <> '' then
      begin
        Add('procedure ' + EditClassName.Text + '.' +
          GetWrite(I) + '(Value: ' + GetType(I) + ');');
        Add('begin');
        Add('  if Value <> f' + GetProp(I) + ' then');
        Add('  begin');
        Add('    f' + GetProp(I) + ' := Value;');
        Add('    // to do: add side effect as: Invalidate;');
        Add('  end;');
        Add('end;');
        Add('');
      end;
    end;
    Add('{registration procedure}');
    Add('');
    Add('procedure Register;');
    Add('begin');
    Add('  RegisterComponents (''' + ComboPage.Text +
      ''', [' + EditClassName.Text + ']);');
    Add('end;');
    Add('');
    Add('end.');
    EndUpdate;
  end;
end;

procedure TCompWizForm.EditClassNameExit(Sender: TObject);
begin
  // copies the initial part of the class name
  // (8 characters, but not the initial 'T')
  if EditUnitName.Text = '' then
    EditUnitName.Text := Copy(EditClassName.Text, 2, 8);
end;

procedure TCompWizForm.PageControl1Changing(Sender: TObject;
  var AllowChange: Boolean);
begin
  if PageControl1.ActivePage = SheetMain then
    if (EditClassName.Text = '') or (ComboParentClass.Text = '')
      or (ComboPage.Text = '') then
    begin
      AllowChange := False;
      MessageDlg('You must fill the main form data first',
        mtError, [mbOK], 0);
    end;
end;

procedure TCompWizForm.BitBtnGenerateClick(Sender: TObject);
var
  Directory, Filename: string;
begin
  if SelectDirectory(Directory,
    [sdAllowCreate, sdPerformCreate, sdPrompt], 0) then
  begin
    Filename := Directory + '\' +
      EditUnitName.Text + '.pas';
    // checks if the file already exists
    if not FileExists(Filename) then
      // save the file
      MemoPreview.Lines.SaveToFile(Filename)
    else
      MessageDlg('The file ' + Filename +
        ' already exists'#13#13 +
        'Choose a new unit name in the Main page'#13 +
        'or select a new directory for the file',
        mtError, [mbOK], 0);

    // special code for the expert
    if ToolServices <> nil then
      // open the component file as a project
      ToolServices.OpenProject(Filename);
  end;
end;

procedure TCompWizForm.BitBtnCloseClick(Sender: TObject);
begin
  // alternative code (modal expert form - main window)
  if MessageDlg('Are you sure you want to quit the'#13 +
    'Extended Component Wizard, loosing your work?',
    mtConfirmation, [mbYes, mbNo], 0) = mrYes then
  begin
    ModalResult := mrCancel;
    Close;
  end;
end;

// ***********************************
// standard + project component expert
// ***********************************

function TExtCompExp.GetStyle: TExpertStyle;
begin
  Result := esStandard;
end;

function TPrjExtCompExp.GetStyle: TExpertStyle;
begin
  Result := esProject;
end;

function TExtCompExp.GetName: string;
begin
  Result := 'Standard Extended Component Wizard'
end;

function TPrjExtCompExp.GetName: string;
begin
  Result := 'Project Extended Component Wizard'
end;

function TExtCompExp.GetAuthor: string;
begin
  Result := 'Marco and Tim';
end;

function TExtCompExp.GetComment: string;
begin
  Result := 'Extended Component Wizard';
end;

function TExtCompExp.GetPage: string;
begin
  Result := 'Projects';
end;

function TExtCompExp.GetGlyph: HICON;
begin
  Result := LoadIcon(HInstance,
    MakeIntResource('EXTCOMPEXP'));
end;

function TExtCompExp.GetState: TExpertState;
begin
  Result := [esEnabled];
end;

function TExtCompExp.GetIDString: string;
begin
  Result := 'DDHandbook.ExtCompExp'
end;

function TPrjExtCompExp.GetIDString: string;
begin
  Result := 'DDHandbook.PrjExtCompExp';
end;

function TExtCompExp.GetMenuText: string;
begin
  Result := '&Extended Component Wizard...';
end;

procedure TExtCompExp.Execute;
begin
  // try closing the project
  if ToolServices.CloseProject then
  begin
    CompWizForm := TCompWizForm.Create(Application);
    try
      CompWizForm.ShowModal;
    finally
      CompWizForm.Free;
    end;
  end;
end;

// include icon
{$R ECEICON.RES}

// registration

procedure Register;
begin
  RegisterLibraryExpert(TExtCompExp.Create);
  RegisterLibraryExpert(TPrjExtCompExp.Create);
end;

end.

Статья Мастер создания компонент раздела Компоненты и Классы Создание компонент может быть полезна для разработчиков на Delphi и FreePascal.

Комментарии и вопросы

:: Главная :: Создание компонент ::