treeef.pas

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

unit TreeEF;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, TypInfo, ExtCtrls, Tabs, ComCtrls, Grids, Outline, Buttons,
  DsgnIntf;

type
  TTreeEditForm = class(TForm)
    TreeComp: TTreeView;
    PanelToolbar: TPanel;
    SpeedToolUpdateComp: TSpeedButton;
    SpeedToolUpdateProp: TSpeedButton;
    PanelProp: TPanel;
    TreeProp: TTreeView;
    TabSet1: TTabSet;
    SpeedToolAbout: TSpeedButton;
    NotebookEdit: TNotebook;
    SpeedEditNumOK: TSpeedButton;
    EditNum: TEdit;
    SpeedComboOK: TSpeedButton;
    ComboBox1: TComboBox;
    LabelType: TLabel;
    ColorDialog1: TColorDialog;
    EditEdit: TEdit;
    SpeedEditOK: TSpeedButton;
    SpeedComboEll: TSpeedButton;
    SpeedDefaultEll: TSpeedButton;
    FontDialog1: TFontDialog;
    Splitter1: TSplitter;
    procedure TabSet1Change(Sender: TObject; NewTab: Integer;
      var AllowChange: Boolean);
    procedure TreeCompChange(Sender: TObject; Node: TTreeNode);
    procedure TreePropChange(Sender: TObject; Node: TTreeNode);
    procedure SpeedToolUpdateCompClick(Sender: TObject);
    procedure SpeedToolUpdatePropClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure SpeedToolAboutClick(Sender: TObject);
    procedure SpeedComboOKClick(Sender: TObject);
    procedure SpeedEditNumOKClick(Sender: TObject);
    procedure SpeedEditOKClick(Sender: TObject);
    procedure SpeedComboEllClick(Sender: TObject);
    procedure SpeedDefaultEllClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
  private
    CurrentComponent: TComponent;
    CurrentProperty: PPropInfo;
  public
    procedure UpdateCompTree;
    procedure ListSubComponents (
      BaseComp: TComponent; BaseNode: TTreeNode);
    procedure UpdateProperties (
      CurrComp: TComponent; Props: Boolean);
    procedure UpdateSubProperties (Obj: TComponent;
      ClassType: TClass; BaseNode: TTreeNode; Props: Boolean);
    procedure AddToCombo (const S: String);
  end;

var
  TreeEditForm: TTreeEditForm;

implementation

{$R *.DFM}

uses
  RttiHelp;

procedure TTreeEditForm.UpdateCompTree;
var
  CurrNode: TTreeNode;
  CurrForm: TForm;
  nForm: Integer;
begin
  // show the hourglass cursor
  Screen.Cursor := crHourglass;
  // disable the output and the events
  TreeProp.Items.BeginUpdate;
  TreeComp.Items.BeginUpdate;
  TreeComp.OnChange := nil;
  TreeProp.OnChange := nil;
  try
    // empty the trees
    TreeProp.Items.Clear;
    TreeComp.Items.Clear;
    // for each form of the program
    for nForm := 0 to Screen.FormCount - 1 do
    begin
      CurrForm := Screen.Forms[nForm];
      if CurrForm <> self then
      begin
        // if the form is not the current one, show it
        CurrNode := TreeComp.Items.AddObject (
          nil, // no parent
          Format ('%s (%s)', [CurrForm.Caption, CurrForm.ClassName]),
          Pointer (CurrForm));
          // add the components of the form
          if CurrForm.ComponentCount > 0 then
            ListSubComponents (CurrForm, CurrNode);
      end;
    end;
  finally
    // remove the hourglass cursor
    Screen.Cursor := crDefault;
    // enable the output and the events
    TreeComp.OnChange := TreeCompChange;
    TreeProp.OnChange := TreePropChange;
    TreeComp.Items.EndUpdate;
    TreeProp.Items.EndUpdate;
  end;
end;

procedure TTreeEditForm.ListSubComponents (
  BaseComp: TComponent; BaseNode: TTreeNode);
var
  nComp: Integer;
  CurrNode: TTreeNode;
  CurrComp: TComponent;
begin
  // for each component owned by the current one
  // (possibly the form, but not always)
  for nComp := 0 to BaseComp.ComponentCount - 1 do
  begin
    CurrComp := BaseComp.Components [nComp];
    CurrNode := TreeComp.Items.AddChildObject (
      BaseNode,
      Format ('%s: %s', [CurrComp.Name, CurrComp.ClassName]),
      CurrComp);
    // recursively calls itself
    if CurrComp.ComponentCount > 0 then
      ListSubComponents (CurrComp, CurrNode);
  end;
end;

procedure TTreeEditForm.TreeCompChange(Sender: TObject; Node: TTreeNode);
begin
  // a new component has been selected
  NotebookEdit.ActivePage := 'Default';
  Caption := Format ('%s [ %s ]',
    ['Object Debugger', TComponent (Node.Data).Name]);
  CurrentComponent := TComponent (Node.Data);
  // update the properties window or the events window
  UpdateProperties (CurrentComponent, TabSet1.TabIndex = 0);
end;

procedure TTreeEditForm.UpdateProperties (CurrComp: TComponent; Props: Boolean);
begin
  Screen.Cursor := crHourglass;
  NotebookEdit.ActivePage := 'Default';
  TreeProp.Items.BeginUpdate;
  TreeProp.OnChange := nil;
  TreeProp.Items.Clear;
  try
    UpdateSubProperties (CurrComp, // component
      CurrComp.ClassType, // class type
      nil, // base tree node
      Props); // props or events
  finally
    // re-enable everything
    Screen.Cursor := crDefault;
    TreeProp.OnChange := TreePropChange;
    TreeProp.Items.EndUpdate;
  end;
end;

procedure TTreeEditForm.UpdateSubProperties (Obj: TComponent;
  ClassType: TClass; BaseNode: TTreeNode; Props: Boolean);
var
  PropList: TPropList;
  CurrNode: TTreeNode;
  NumberOfProps, nProp: Integer;
begin
  // get the number of properties
  NumberOfProps := GetTypeData(ClassType.ClassInfo).PropCount;
  // get the list of properties
  GetPropInfos (ClassType.ClassInfo, @PropList);

  // show the name of each property or event
  for nProp := 0 to NumberOfProps - 1 do
    // if we've asked for properties and it is not a method
    // or we've asked for a method and we find one...
    if (Props and (PropList[nProp].PropType^.Kind <> tkMethod)) or
        (not Props and (PropList[nProp].PropType^.Kind = tkMethod)) then
    begin
      // add the property
      CurrNode := TreeProp.Items.AddChildObject (
        BaseNode,
        Format ('%s: %s', [PropList[nProp].Name,
          GetPropValAsString (Obj, PropList[nProp])]),
        Pointer (PropList[nProp]));
      // if the property is a class and the object exists
      // add its subproperties (with a recursive call)
      if (PropList[nProp].PropType^.Kind = tkClass) and
          (GetOrdProp (Obj, PropList[nProp]) <> 0) then
        UpdateSubProperties (
          TComponent (GetOrdProp (Obj, PropList[nProp])),
          GetTypeData (PropList[nProp].PropType^).ClassType,
          CurrNode, Props);
    end;
end;

// UI code

procedure TTreeEditForm.TabSet1Change(Sender: TObject; NewTab: Integer;
  var AllowChange: Boolean);
begin
  // disable editing
  NotebookEdit.ActivePage := 'Default';
  SpeedDefaultEll.Visible := False;
  // update the second treeview,
  // with properties or events
  UpdateProperties (CurrentComponent, NewTab = 0);
end;

procedure TTreeEditForm.AddToCombo (const S: String);
begin
  Combobox1.Items.Add (S);
end;

procedure TTreeEditForm.TreePropChange(Sender: TObject; Node: TTreeNode);
var
  TempProp: PPropInfo;
  I: Integer;
begin
  // get the active component in the first treeview
  // (might have changed accessing to a sub-property)
  CurrentComponent := TComponent (TreeComp.Selected.Data);

  // get the selected property
  CurrentProperty := PPropInfo (Node.Data);

  // show the name of the data type in the label
  LabelType.Caption := CurrentProperty.PropType^.Name;

  // disable the special buttons
  SpeedComboEll.Visible := False;
  SpeedDefaultEll.Visible := False;

  // if it is a subproperty, select the "parent"
  // property as the current component
  if Node.Level > 0 then
  begin
    TempProp := PPropInfo (Node.Parent.Data);
    CurrentComponent := TComponent (
      GetOrdProp (CurrentComponent, TempProp));
  end;

  // set up the proper editor in the mini notebook
  // this is the starting point of the editing code
  case CurrentProperty.PropType^.Kind of
    tkInteger:
    begin
      if CurrentProperty.PropType^.Name = 'TCursor' then
      begin
        ComboBox1.Items.Clear;
        GetCursorValues (AddToCombo);
        ComboBox1.ItemIndex := Combobox1.Items.IndexOf (
          GetPropValAsString (CurrentComponent, CurrentProperty));
        NotebookEdit.ActivePage := 'Combo';
      end
      else if CurrentProperty.PropType^.Name = 'TColor' then
      begin
        ComboBox1.Items.Clear;
        GetColorValues (AddToCombo);
        ComboBox1.ItemIndex := Combobox1.Items.IndexOf (
          GetPropValAsString (CurrentComponent, CurrentProperty));
        NotebookEdit.ActivePage := 'Combo';
        SpeedComboEll.Visible := True;
      end
      else
      begin
        EditNum.Text := GetPropValAsString (
          CurrentComponent, CurrentProperty);
        NotebookEdit.ActivePage := 'NumEdit';
      end;
    end;

    tkEnumeration:
    begin
      ComboBox1.Clear;
      for I := 0 to GetTypeData(CurrentProperty.PropType^).MaxValue do
        AddToCombo (GetEnumName (CurrentProperty.PropType^, I));
      ComboBox1.ItemIndex := Combobox1.Items.IndexOf (
        GetPropValAsString (CurrentComponent, CurrentProperty));
      NotebookEdit.ActivePage := 'Combo';
    end;

    tkString, tkLString:
    begin
      EditEdit.text := GetStrProp (
        CurrentComponent, CurrentProperty);
      NotebookEdit.ActivePage := 'Edit';
    end;

    tkClass:
    begin
      if CurrentProperty.PropType^.Name = 'TFont' then
        SpeedDefaultEll.Visible := True;
      NotebookEdit.ActivePage := 'Default';
    end;

    else
      NotebookEdit.ActivePage := 'Default';  // no editing
  end;

end;

// toolbar buttons OnClick event handlers

procedure TTreeEditForm.SpeedToolUpdateCompClick(Sender: TObject);
begin
  // update the tree of components
  NotebookEdit.ActivePage := 'Default';
  UpdateCompTree;
end;

procedure TTreeEditForm.SpeedToolUpdatePropClick(Sender: TObject);
var
  Node: TTreeNode;
begin
  // update the tree of properties, if a component is selected
  Node := TreeComp.Selected;
  if Node <> nil then
  begin
    CurrentComponent := TComponent (Node.Data);
    UpdateProperties (CurrentComponent, TabSet1.TabIndex = 0);
  end
  else
    ShowMessage ('No component selected');
end;

procedure TTreeEditForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  // never close the form
  Action := caMinimize;
end;

procedure TTreeEditForm.SpeedToolAboutClick(Sender: TObject);
begin
  // Show an about box
  MessageDlg ('Object Debugger' +
    #13#13'Copyright Marco Cant