1
0
lazarus-tutorials/compbrowser/comp_browser_main.pas

370 lines
8.2 KiB
ObjectPascal
Raw Normal View History

2021-10-12 15:51:51 -04:00
unit comp_browser_main;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ComCtrls, Menus,
Buttons, StdCtrls, ExtCtrls, ActnList, MaskEdit, grids, CheckLst, PairSplitter,
ColorBox, ValEdit, SynHighlighterPosition, strutils, SynEdit, DateTimePicker,
PopupNotifier, typinfo;
2021-10-12 15:51:51 -04:00
type
TPalettePage = (ppStandard, ppAdditional, ppCommonControls, ppOtherPagesNotListedHere);
2021-10-12 15:51:51 -04:00
{ TForm1 }
TForm1 = class(TForm)
seViewer: TSynEdit;
tvComps: TTreeView;
procedure FormCreate(Sender: TObject);
procedure tvCompsChange(Sender: TObject; Node: TTreeNode);
2021-10-12 15:51:51 -04:00
private
compClass: TComponentClass;
Hiliter: TSynPositionHighlighter;
atrUL, atrBD: TtkTokenKind;
lineNo: integer;
procedure LoadTreeView;
procedure DisplayComponentInfo(aNode: TTreeNode);
procedure DisplayPageInfo(aNode: TTreeNode);
procedure DisplayComponentData;
procedure DisplayComponentHierarchy(aNode: TTreeNode);
procedure DisplayComponentProperties;
function GetAncestorCount(aClass: TClass): integer;
function GetComponentClass(aPage: TPalettePage; anIndex: word): TComponentClass;
2021-10-12 15:51:51 -04:00
public
end;
const
MaxComponentsOnAPage = 21; // AdditionalPage
PageNames : array[TPalettePage] of shortstring =
('Standard', 'Additional', 'Common Controls', 'Other unlisted pages');
2021-10-12 15:51:51 -04:00
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
hiliter := TSynPositionHighlighter.Create(Self);
seViewer.Highlighter := hiliter;
atrUL := hiliter.CreateTokenID('atrUL', clBlue, clNone, [fsBold, fsUnderline]);
atrBD := hiliter.CreateTokenID('atrBD', clBlack, clNone, [fsBold]);
2021-10-12 15:51:51 -04:00
LoadTreeView;
end;
procedure TForm1.tvCompsChange(Sender: TObject; Node: TTreeNode);
begin
DisplayComponentInfo(Node);
end;
2021-10-12 15:51:51 -04:00
procedure TForm1.LoadTreeView;
var aNode: TTreeNode;
palPage: TPalettePage;
i: integer;
2021-10-12 15:51:51 -04:00
begin
tvComps.BeginUpdate;
for palPage := High(TPalettePage) downto Low(TPalettePage) do
begin
aNode := tvComps.Items.AddFirst(nil, PageNames[palPage]);
for i := 1 to MaxComponentsOnAPage do
begin
compClass := GetComponentClass(palPage, i);
if Assigned(compClass) then
tvComps.Items.AddChildObject(
aNode,
compClass.ClassName,
TObject(compClass)
);
2021-10-12 15:51:51 -04:00
end;
end;
tvComps.EndUpdate;
tvComps.Selected := tvComps.Items[0];
end;
procedure TForm1.DisplayComponentInfo(aNode: TTreeNode);
begin
seViewer.Lines.Clear;
hiliter.ClearAllTokens;
lineNo := 0;
case aNode.Level of
0: begin
seViewer.Lines.Add('');
seViewer.Lines.Add(' (' + aNode.Text + ' Page)');
end
else
begin
compClass := TComponentClass(aNode.Data);
DisplayPageInfo(aNode);
DisplayComponentData;
DisplayComponentHierarchy(aNode);
DisplayComponentProperties;
end;
end;
end;
procedure TForm1.DisplayPageInfo(aNode: TTreeNode);
var s: string;
begin
seViewer.Lines.Add('');
inc(lineNo);
s := ' Palette Page: ' + aNode.Parent.Text;
hiliter.AddToken(lineNo, 1, tkText);
hiliter.AddToken(lineNo, Length(s), atrUL);
seViewer.Lines.Add(s);
inc(lineNo);
seViewer.Lines.Add('');
inc(lineNo);
end;
procedure TForm1.DisplayComponentData;
var st: string;
begin
st := ' ' + compClass.ClassName;
HiLiter.AddToken(lineNo, 1, tkText);
HiLiter.AddToken(lineNo, Length(st), atrUL);
seViewer.Lines.Add(st);
inc(lineNo);
seViewer.Lines.Add('');
inc(lineNo);
seViewer.Lines.Add(
Format(' ''%s'' is declared in the %s unit', [
compClass.ClassName,
compClass.UnitName
])
);
inc(lineNo);
seViewer.Lines.Add(
Format(' InstanceSize is : %d bytes', [compClass.InstanceSize])
);
inc(lineNo);
seViewer.Lines.Add('');
inc(lineNo);
end;
procedure TForm1.DisplayComponentHierarchy(aNode: TTreeNode);
var
sl: TStringList;
step: integer = 1;
ancestorCount : integer = 0;
i: integer;
s: string;
aClass: TClass;
function Plural(aCount: integer): string;
begin
case aCount of
1: result := '';
else result := 'es';
end;
end;
begin
ancestorCount := GetAncestorCount(compClass);
s := Format(
' %s class hierarchy [%d ancestor class%s]',
[compClass.ClassName, ancestorCount, Plural(ancestorCount)]
);
hiliter.AddToken(lineNo, 1, tkText);
hiliter.AddToken(lineNo, Length(s), atrBD);
seViewer.Lines.Add(s);
inc(lineNo);
aClass := TClass(aNode.Data);
if Assigned(aClass.ClassParent) then
begin
sl := TStringList.Create;
try
while Assigned(aClass.ClassParent) do
begin
sl.Add(DupeString(' ', step) + aClass.ClassName);
aClass := aClass.ClassParent;
inc(step, 2);
end;
sl.Add(DupeString(' ', step) + aClass.ClassName);
for i := sl.Count -1 downto 0 do
begin
seViewer.Lines.Add(sl[i]);
inc(lineNo);
end;
finally
sl.Free;
end;
end
else
begin
seViewer.Lines.Add(' (No parent class)');
inc(lineNo);
end;
end;
procedure TForm1.DisplayComponentProperties;
var
aPPI: PPropInfo;
aPTI: PTypeInfo;
aPTD: PTypeData;
aPropList: PPropList;
sortSL: TStringList;
i: integer;
s: string;
begin
seViewer.Lines.Add('');
inc(LineNo);
aPTI := PTypeInfo(compClass.ClassInfo);
aPTD := GetTypeData(aPTI);
s := Format(
' %s has %d published properties:',
[aPTI^.Name, aPTD^.PropCount]
);
hiliter.AddToken(lineNo, 1, tkText);
hiliter.AddToken(lineNo, Length(s), atrBD);
seViewer.Lines.Add(s);
inc(lineNo);
if (aPTD^.PropCount = 0)
then seViewer.Lines.Add(' (no published properties)')
else
begin
GetMem(aPropList, SizeOf(PPropInfo^) * aPTD^.PropCount);
sortSL := TStringList.Create;
sortSL.Sorted := true;
try
GetPropInfos(aPTI, aPropList);
for i := 0 to aPTD^.PropCount - 1 do
begin
aPPI := aPropList^[i];
sortSL.AddObject(Format(
' %s: %s',
[aPPI^.Name, aPPI^.PropType^.Name]
), TObject(Pointer(Length(aPPI^.Name))));
end;
for i := 0 to sortSL.Count - 1 do
begin
seViewer.Lines.Add(sortSL[i]);
hiliter.AddToken(lineNo, Succ(Integer(Pointer(sortSL.Objects[i]))), atrBD);
hiliter.AddToken(lineNo, Length(sortSL[i]), tkText);
inc(lineNo);
end;
finally
FreeMem(aPropList, SizeOf(PPropInfo) * aPTD^.PropCount);
sortSL.Free;
end;
end;
end;
function TForm1.GetAncestorCount(aClass: TClass): integer;
begin
result := 0;
if not Assigned(aClass.ClassParent)
then Exit
else
begin
while Assigned(aClass.ClassParent) do
begin
inc(result);
aClass := aClass.ClassParent;
end;
end;
2021-10-12 15:51:51 -04:00
end;
function TForm1.GetComponentClass(
aPage: TPalettePage;
anIndex: word
2021-10-12 15:51:51 -04:00
): TComponentClass;
begin
case aPage of
ppStandard: case anIndex of
1: result := TMainMenu;
2: result := TPopupMenu;
3: result := TButton;
4: result := TLabel;
5: result := TEdit;
6: result := TMemo;
7: result := TToggleBox;
8: result := TCheckBox;
9: result := TRadioButton;
10: result := TListBox;
11: result := TComboBox;
12: result := TScrollBar;
13: result := TGroupBox;
14: result := TRadioGroup;
15: result := TCheckGroup;
16: result := TPanel;
17: result := TFrame;
18: result := TActionList;
else result := nil;
end;
ppAdditional: case anIndex of
1: result := TBitBtn;
2: result := TSpeedbutton;
3: result := TStaticText;
4: result := TImage;
5: result := TShape;
6: result := TBevel;
7: result := TPaintBox;
8: result := TNotebook;
9: result := TlabeledEdit;
10: result := TSplitter;
11: result := TTrayIcon;
12: result := TMaskEdit;
13: result := TCheckListBox;
14: result := TScrollBox;
15: result := TApplicationProperties;
16: result := TStringGrid;
17: result := TDrawGrid;
18: result := TPairSplitter;
19: result := TColorBox;
20: result := TColorListBox;
21: result := TValueListEditor;
else result := nil;
2021-10-12 15:51:51 -04:00
end;
ppCommonControls: case anIndex of
1: result := TTrackBar;
2: result := TProgressBar;
3: result := TTreeView;
4: result := TListView;
5: result := TStatusBar;
6: result := TToolBar;
7: result := TCoolBar;
8: result := TUpDown;
9: result := TPageControl;
10: result := TTabControl;
11: result := THeaderControl;
12: result := TImageList;
13: result := TPopupNotifier;
14: result := TDateTimePicker;
else result := nil;
2021-10-12 15:51:51 -04:00
end;
else result := nil;
2021-10-12 15:51:51 -04:00
end;
end;
end.