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.