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, ExtDlgs, ComboEx, ShellCtrls, PrintersDlgs, Spin, EditBtn,
	FileCtrl, Arrow, XMLPropStorage, IniPropStorage, JsonPropStorage,
	IDEWindowIntf, ButtonPanel, typinfo;

type
	TPalettePage = (
		ppStandard,
		ppAdditional,
		ppCommonControls,
		ppDialogs,
		ppMisc,
		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', 'Dialogs', 'Misc', '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;

		ppDialogs: case anIndex of
			1: result := TOpenDialog;
			2: result := TSaveDialog;
			3: result := TSelectDirectoryDialog;
			4: result := TColorDialog;
			5: result := TFontDialog;
			6: result := TFindDialog;
			7: result := TReplaceDialog;
			8: result := TTaskDialog;
			9: result := TOpenPictureDialog;
			10: result := TSavePictureDialog;
			11: result := TCalendarDialog;
			12: result := TCalculatorDialog;
			13: result := TPrinterSetupDialog;
			14: result := TPrintDialog;
			15: result := TPageSetupDialog;
			else result := nil;
		end;

		ppMisc: case anIndex of
			1: result := TColorButton;
			2: result := TSpinEdit;
			3: result := TFloatSpinEdit;
			4: result := TArrow;
			5: result := TEditButton;
			6: result := TFileNameEdit;
			7: result := TDirectoryEdit;
			8: result := TDateEdit;
			9: result := TTimeEdit;
			10: result := TCalcEdit;
			11: result := TFileListBox;
			12: result := TFilterComboBox;
			13: result := TComboBoxEx;
			14: result := TCheckComboBox;
			15: result := TButtonPanel;
			16: result := TShellTreeView;
			17: result := TShellListView;
			18: result := TXMLPropStorage;
			19: result := TIniPropStorage;
			20: result := TJsonPropStorage;
			21: result := TIDEDialogLayoutStorage;
			else result := nil;
		end;

		else result := nil;
	end;
end;

end.