lazarus-tutorials/compbrowser/comp_browser_main.pas

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;

type
	TPalettePage = (ppStandard, ppAdditional, ppCommonControls, ppOtherPagesNotListedHere);
	{ TForm1 }

 TForm1 = class(TForm)
		seViewer: TSynEdit;
		tvComps: TTreeView;
		procedure FormCreate(Sender: TObject);
		procedure tvCompsChange(Sender: TObject; Node: TTreeNode);
	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;
	public

	end;

 const
	 MaxComponentsOnAPage = 21; // AdditionalPage
	 PageNames : array[TPalettePage] of shortstring =
		 ('Standard', 'Additional', 'Common Controls', 'Other unlisted pages');

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]);
	LoadTreeView;
end;

procedure TForm1.tvCompsChange(Sender: TObject; Node: TTreeNode);
begin
	DisplayComponentInfo(Node);
end;

procedure TForm1.LoadTreeView;
var aNode: TTreeNode;
	palPage: TPalettePage;
	i: integer;
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)
						);
				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;
end;

function TForm1.GetComponentClass(
	aPage: TPalettePage;
	anIndex: word
): 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;
		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;
		end;
		else result := nil;
	end;
end;

end.