Delphi World - Мастер создания компонент
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Мастер создания компонент


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 World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования