1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
unit SimpleFrm;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LCLProc, FileUtil, Forms, Controls, Graphics, Dialogs,
StdCtrls;
type
{ TSimpleForm }
TSimpleForm = class(TForm)
Memo1: TMemo;
procedure FormPaint(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
SimpleForm: TSimpleForm;
function CreateSimpleForm(Name, Title: string; NewBounds: TRect;
DisableAutoSizing: boolean): TSimpleForm;
implementation
function CreateSimpleForm(Name, Title: string; NewBounds: TRect;
DisableAutoSizing: boolean): TSimpleForm;
begin
// first check if the form already exists
// the LCL Screen has a list of all existing forms.
// Note: Remember that the LCL allows as form names only standard
// pascal identifiers and compares them case insensitive
Result:=TSimpleForm(Screen.FindForm(Name));
if Result is TSimpleForm then begin
if DisableAutoSizing then
Result.DisableAutoSizing;
exit;
end;
// create it
Result:=TSimpleForm(TSimpleForm.NewInstance);
Result.DisableAutoSizing;
Result.Create(Application);
Result.Caption:=Title;
Result.Name:=Name;
Result.Memo1.Lines.Text:=Name;
Result.BoundsRect:=NewBounds;
if not DisableAutoSizing then
Result.EnableAutoSizing;
end;
{$R *.lfm}
{ TSimpleForm }
procedure TSimpleForm.FormPaint(Sender: TObject);
var
s: TCaption;
W, H: Integer;
begin
if Memo1.Visible then exit;
with Canvas do begin
Pen.Color:=clRed;
MoveTo(0,0);
LineTo(ClientWidth-1,0);
LineTo(ClientWidth-1,ClientHeight-1);
LineTo(0,ClientHeight-1);
LineTo(0,0);
LineTo(ClientWidth-1,ClientHeight-1);
s:=Caption;
W:=TextWidth(s);
H:=TextWidth(s);
TextOut((ClientWidth-W) div 2,(ClientHeight-H) div 2,s);
end;
end;
end.
|
