unit
MAIN;
interface
uses
Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus,
StdCtrls, Dialogs, Buttons, Messages, ExtCtrls, ComCtrls, StdActns,
ActnList, ToolWin, ImgList;
type
TMainForm
=
class
(TForm)
MainMenu1: TMainMenu;
Window1: TMenuItem;
Help1: TMenuItem;
WindowCascadeItem: TMenuItem;
WindowTileItem: TMenuItem;
WindowArrangeItem: TMenuItem;
HelpAboutItem: TMenuItem;
OpenDialog: TOpenDialog;
WindowMinimizeItem: TMenuItem;
StatusBar: TStatusBar;
ActionList1: TActionList;
FileExit1: TAction;
WindowCascade1: TWindowCascade;
WindowTileHorizontal1: TWindowTileHorizontal;
WindowArrangeAll1: TWindowArrange;
WindowMinimizeAll1: TWindowMinimizeAll;
HelpAbout1: TAction;
WindowTileVertical1: TWindowTileVertical;
WindowTileItem2: TMenuItem;
ImageList1: TImageList;
CoolBar1: TCoolBar;
ToolBar1: TToolBar;
ToolButton12: TToolButton;
ToolButton13: TToolButton;
ToolButton14: TToolButton;
ToolButton15: TToolButton;
ToolButton16: TToolButton;
ToolButton17: TToolButton;
ToolButton18: TToolButton;
ToolButton1: TToolButton;
Image1: TImage;
ToolButton2: TToolButton;
FileNew1: TAction;
ToolButton3: TToolButton;
procedure
FileNew1Execute(Sender: TObject);
procedure
FileOpen1Execute(Sender: TObject);
procedure
HelpAbout1Execute(Sender: TObject);
procedure
FileExit1Execute(Sender: TObject);
private
{
Private declarations
}
FOldWndProc: TFarProc;
FNewWndProc: TFarProc;
procedure
CreateMDIChild(
const
Name:
string
);
procedure
ClientWndProc(
var
Message: TMessage);
protected
procedure
DrawBG(DC: HDC);
virtual
;
procedure
CreateWnd;
override
;
public
{
Public declarations
}
end
;
var
MainForm: TMainForm;
implementation
{
$R *.dfm
}
uses
CHILDWIN, about;
procedure
TMainForm.ClientWndProc(
var
Message: TMessage);
var
R: TRECT;
procedure
Default;
begin
with
Message
do
Result :
=
CallWindowProc(FOldWndProc, ClientHandle, Msg, wParam, lParam);
end
;
var
PS: TPaintStruct;
begin
R :
=
ClientRect;
case
Message.Msg
of
WM_PAINT:
begin
BeginPaint(ClientHandle, PS);
try
Canvas.Lock;
try
Canvas.Handle :
=
PS.hdc;
try
Paint;
if
ControlCount
>
0
then
PaintControls(PS.hdc, Controls[
0
]);
finally
Canvas.Handle :
=
0
;
end
;
finally
Canvas.Unlock;
end
;
finally
EndPaint(ClientHandle, PS);
end
;
end
;
WM_ERASEBKGND:
begin
DrawBG(TWMEraseBkGnd(Message).DC);
Message.Result :
=
1
;
end
;
WM_VSCROLL, WM_HSCROLL:
begin
InvalidateRect(ClientHandle, @R, true);
Default;
end
;
WM_SIZE:
begin
InvalidateRect(ClientHandle, @R, true);
Default;
end
;
else
Default;
end
;
end
;
procedure
TMainForm.CreateMDIChild(
const
Name:
string
);
var
Child: TMDIChild;
begin
{
create a new MDI child window
}
Child :
=
TMDIChild.Create(Application);
Child.Caption :
=
Name;
if
FileExists(Name)
then
Child.Memo1.Lines.LoadFromFile(Name);
end
;
procedure
TMainForm.FileNew1Execute(Sender: TObject);
begin
CreateMDIChild(
'
NONAME
'
+
IntToStr(MDIChildCount
+
1
));
end
;
procedure
TMainForm.FileOpen1Execute(Sender: TObject);
begin
if
OpenDialog.Execute
then
CreateMDIChild(OpenDialog.FileName);
end
;
procedure
TMainForm.HelpAbout1Execute(Sender: TObject);
begin
AboutBox.ShowModal;
end
;
procedure
TMainForm.CreateWnd;
begin
inherited
;
FNewWndProc :
=
Forms.MakeObjectInstance(ClientWndProc);
FOldWndProc :
=
Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(FNewWndProc));
end
;
procedure
TMainForm.DrawBG(DC: HDC);
var
myRect: TRect;
str:
string
;
NewFont, OldFont: Integer;
FontStyle, FontItalic, FontUnderline, FontStrikeout: Integer;
begin
if
Brush.Color
<>
clNone
then
FillRect(DC, ClientRect, Brush.Handle);
SetBkMode(DC, TRANSPARENT);
SetTextColor(DC, clRed);
//
Set font
FontStyle :
=
FW_BOLD;
FontItalic :
=
1
;
FontUnderline :
=
0
;
FontStrikeout :
=
0
;
NewFont :
=
CreateFont(
50
,
0
,
0
,
0
, FontStyle, FontItalic,
FontUnderline, FontStrikeout, DEFAULT_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
DEFAULT_PITCH,
'
Arial
'
);
OldFont :
=
SelectObject(DC, NewFont);
str :
=
'
GMT
'
;
myRect :
=
Rect(Width
-
200
,
Height
-
200
,
Width
-
20
,
Height
-
20
);
DrawText(DC, PChar(str), Length(str), myRect, DT_CENTER
or
DT_VCENTER);
SelectObject(DC, OldFont);
DeleteObject(NewFont);
end
;
procedure
TMainForm.FileExit1Execute(Sender: TObject);
begin
Close;
end
;
end
.