Marco Cantù 1998, Mastering Delphi 4
Project: MDIMULTI.DPR
Project Structure
MDIMULTI.DPR
program MdiMulti;
uses
Forms,
Frame in 'FRAME.PAS' {MainForm},
Child in 'CHILD.PAS' {CircleChildForm},
Child2 in 'CHILD2.PAS' {BounceChildForm};
{$R *.RES}
begin
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.
FRAME.PAS
unit Frame;
interface
uses
Windows, Classes, Graphics, Forms, Messages,
Controls, Child, Child2, Menus, SysUtils, Dialogs,
ExtCtrls, StdActns, ActnList;
type
TMainForm = class(TForm)
MainMenu1: TMainMenu;
Window1: TMenuItem;
New1: TMenuItem;
File1: TMenuItem;
N1: TMenuItem;
Exit1: TMenuItem;
Cascade1: TMenuItem;
Tile1: TMenuItem;
ArrangeIcons1: TMenuItem;
New2: TMenuItem;
Tile2: TMenuItem;
CloseAll1: TMenuItem;
Count1: TMenuItem;
Image1: TImage;
ActionList1: TActionList;
WindowArrange1: TWindowArrange;
WindowCascade1: TWindowCascade;
WindowClose1: TWindowClose;
WindowMinimizeAll1: TWindowMinimizeAll;
WindowTileHorizontal1: TWindowTileHorizontal;
WindowTileVertical1: TWindowTileVertical;
Close1: TMenuItem;
MinimizeAll1: TMenuItem;
N2: TMenuItem;
procedure New1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure New2Click(Sender: TObject);
procedure CloseAll1Click(Sender: TObject);
procedure Count1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
Count: Integer;
OutCanvas: TCanvas;
OldWinProc, NewWinProc: Pointer;
procedure NewWinProcedure (var Msg: TMessage);
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.New1Click(Sender: TObject);
var
ChildForm: TCircleChildForm;
begin
Inc (Count);
ChildForm := TCircleChildForm.Create (self);
ChildForm.Caption := ChildForm.Caption + ' ' +
IntToStr (Count);
ChildForm.Show;
end;
procedure TMainForm.Exit1Click(Sender: TObject);
begin
Close;
end;
procedure TMainForm.New2Click(Sender: TObject);
var
ChildForm: TBounceChildForm;
begin
Inc (Count);
ChildForm := TBounceChildForm.Create (self);
ChildForm.Caption := ChildForm.Caption + ' ' +
IntToStr (Count);
ChildForm.Show;
end;
procedure TMainForm.CloseAll1Click(Sender: TObject);
var
I: Integer;
begin
for I := 0 to MDIChildCount - 1 do
MDIChildren [I].Close;
end;
procedure TMainForm.Count1Click(Sender: TObject);
var
NBounce, NCircle, I: Integer;
begin
NBounce := 0;
NCircle := 0;
for I := 0 to MDIChildCount - 1 do
if MDIChildren [I] is TBounceChildForm then
Inc (NBounce)
else
Inc (NCircle);
MessageDlg (
Format ('There are %d child forms.'#13 +
'%d are Circle child windows and ' +
'%d are Bouncing child windows',
[MDIChildCount, NCircle, NBounce]),
mtINformation, [mbOk], 0);
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
NewWinProc := MakeObjectInstance (NewWinProcedure);
OldWinProc := Pointer (SetWindowLong (
ClientHandle, gwl_WndProc, Cardinal (NewWinProc)));
OutCanvas := TCanvas.Create;
end;
procedure TMainForm.NewWinProcedure (var Msg: TMessage);
var
BmpWidth, BmpHeight: Integer;
I, J: Integer;
begin
// default processing first
Msg.Result := CallWindowProc (OldWinProc,
ClientHandle, Msg.Msg, Msg.wParam, Msg.lParam);
// handle background repaint
if Msg.Msg = wm_EraseBkgnd then
begin
BmpWidth := MainForm.Image1.Width;
BmpHeight := MainForm.Image1.Height;
if (BmpWidth <> 0) and (BmpHeight <> 0) then
begin
OutCanvas.Handle := Msg.wParam;
for I := 0 to MainForm.ClientWidth div BmpWidth do
for J := 0 to MainForm.ClientHeight div BmpHeight do
OutCanvas.Draw (I * BmpWidth,
J * BmpHeight, MainForm.Image1.Picture.Graphic);
end;
end;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
OutCanvas.Free;
end;
end.
CHILD.PAS
unit Child;
interface
uses Windows, Classes, Graphics, Forms, Controls, Menus,
Dialogs, SysUtils;
type
TCircleChildForm = class(TForm)
MainMenu1: TMainMenu;
Circle1: TMenuItem;
FillColor1: TMenuItem;
BorderColor1: TMenuItem;
BorderSize1: TMenuItem;
N1: TMenuItem;
GetPosition1: TMenuItem;
ColorDialog1: TColorDialog;
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FillColor1Click(Sender: TObject);
procedure BorderColor1Click(Sender: TObject);
procedure BorderSize1Click(Sender: TObject);
procedure GetPosition1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
XCenter, YCenter: Integer;
BorderSize: Integer;
BorderColor, FillColor: TColor;
public
{ Public declarations }
end;
implementation
{$R *.DFM}
procedure TCircleChildForm.FormCreate(Sender: TObject);
begin
XCenter := - 200;
YCenter := - 200;
BorderSize := 1;
BorderColor := clBlack;
FillColor := clYellow;
end;
procedure TCircleChildForm.FormPaint(Sender: TObject);
begin
Canvas.Pen.Width := BorderSize;
Canvas.Pen.Color := BorderColor;
Canvas.Brush.Color := FillColor;
Canvas.Ellipse (XCenter-30, YCenter-30, XCenter+30, YCenter+30);
end;
procedure TCircleChildForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
XCenter := X;
YCenter := Y;
Refresh;
end;
procedure TCircleChildForm.FillColor1Click(Sender: TObject);
begin
ColorDialog1.Color := FillColor;
if ColorDialog1.Execute then
begin
FillColor := ColorDialog1.Color;
Repaint;
end;
end;
procedure TCircleChildForm.BorderColor1Click(Sender: TObject);
begin
ColorDialog1.Color := BorderColor;
if ColorDialog1.Execute then
begin
BorderColor := ColorDialog1.Color;
Repaint;
end;
end;
procedure TCircleChildForm.BorderSize1Click(Sender: TObject);
var
InputString: string;
begin
InputString := IntToStr (BorderSize);
if InputQuery ('Border', 'Insert width', InputString) then
begin
BorderSize := StrToIntDef (InputString, BorderSize);
Repaint;
end;
end;
procedure TCircleChildForm.GetPosition1Click(Sender: TObject);
begin
MessageDlg ('The center of the circle is in the position (' +
IntToStr (XCenter) + ', ' + IntToStr (YCenter) + ').',
mtInformation, [mbOk], 0);
end;
procedure TCircleChildForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action := caFree;
end;
end.
CHILD2.PAS
unit Child2;
interface
uses
Windows, Classes, Graphics, Forms,
Controls, Menus, Dialogs, StdCtrls, ExtCtrls,
SysUtils;
type
Directions = (up_right, down_right, down_left, up_left);
TBounceChildForm = class(TForm)
Timer1: TTimer;
Shape1: TShape;
MainMenu1: TMainMenu;
Square1: TMenuItem;
FillColor1: TMenuItem;
N1: TMenuItem;
GetPosition1: TMenuItem;
Movement1: TMenuItem;
Start1: TMenuItem;
Stop1: TMenuItem;
ColorDialog1: TColorDialog;
procedure Timer1Timer(Sender: TObject);
procedure FillColor1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure GetPosition1Click(Sender: TObject);
procedure Start1Click(Sender: TObject);
procedure Stop1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
Dir : Directions;
public
{ Public declarations }
end;
implementation
{$R *.DFM}
procedure TBounceChildForm.Timer1Timer(Sender: TObject);
begin
case Dir of
up_right:
begin
Shape1.Left := Shape1.Left + 3;
Shape1.Top := Shape1.Top - 3;
if Shape1.Top <= 0 then
Dir := down_right;
if Shape1.Left + Shape1.Width >= ClientWidth then
Dir := up_left;
end;
down_right:
begin
Shape1.Left := Shape1.Left + 3;
Shape1.Top := Shape1.Top + 3;
if Shape1.Top + Shape1.Height >= ClientHeight then
Dir := up_right;
if Shape1.Left + Shape1.Width >= ClientWidth then
Dir := down_left;
end;
down_left:
begin
Shape1.Left := Shape1.Left - 3;
Shape1.Top := Shape1.Top + 3;
if Shape1.Top + Shape1.Height >= ClientHeight then
Dir := up_left;
if Shape1.Left <= 0 then
Dir := down_right;
end;
up_left:
begin
Shape1.Left := Shape1.Left - 3;
Shape1.Top := Shape1.Top - 3;
if Shape1.Top <= 0 then
Dir := down_left;
if Shape1.Left <= 0 then
Dir := up_right;
end;
end;
end;
procedure TBounceChildForm.FillColor1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
Shape1.Brush.Color := ColorDialog1.Color;
end;
procedure TBounceChildForm.FormCreate(Sender: TObject);
begin
ColorDialog1.Color := Shape1.Brush.Color;
Dir := down_left;
end;
procedure TBounceChildForm.GetPosition1Click(Sender: TObject);
begin
MessageDlg ('The top-left corner of the square was in the position (' +
IntToStr (Shape1.Left) + ', ' + IntToStr (Shape1.Top) + ').',
mtInformation, [mbOk], 0);
end;
procedure TBounceChildForm.Start1Click(Sender: TObject);
begin
Timer1.Enabled := True;
Start1.Enabled := False;
Stop1.Enabled := True;
end;
procedure TBounceChildForm.Stop1Click(Sender: TObject);
begin
Timer1.Enabled := False;
Start1.Enabled := True;
Stop1.Enabled := False;
end;
procedure TBounceChildForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action := caFree;
end;
end.
FRAME.DFM
object MainForm: TMainForm
Left = 224
Top = 188
Width = 435
Height = 299
Caption = 'MDI Frame'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
FormStyle = fsMDIForm
Menu = MainMenu1
OldCreateOrder = True
WindowMenu = Window1
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 16
object Image1: TImage
Left = 16
Top = 56
Width = 153
Height = 139
AutoSize = True
Picture.Data = {...skipped...}
end
object MainMenu1: TMainMenu
Left = 16
Top = 8
object File1: TMenuItem
Caption = '&File'
GroupIndex = 1
object New1: TMenuItem
Caption = '&New Circle'
OnClick = New1Click
end
object New2: TMenuItem
Caption = 'New &Bouncing Square'
OnClick = New2Click
end
object Close1: TMenuItem
Action = WindowClose1
end
object CloseAll1: TMenuItem
Caption = 'Clo&se All'
OnClick = CloseAll1Click
end
object N1: TMenuItem
Caption = '-'
end
object Exit1: TMenuItem
Caption = '&Exit'
OnClick = Exit1Click
end
end
object Window1: TMenuItem
Caption = '&Window'
GroupIndex = 3
object Cascade1: TMenuItem
Action = WindowCascade1
end
object Tile1: TMenuItem
Action = WindowTileHorizontal1
end
object Tile2: TMenuItem
Action = WindowTileVertical1
end
object ArrangeIcons1: TMenuItem
Action = WindowArrange1
end
object MinimizeAll1: TMenuItem
Action = WindowMinimizeAll1
end
object N2: TMenuItem
Caption = '-'
end
object Count1: TMenuItem
Caption = 'Count'
OnClick = Count1Click
end
end
end
object ActionList1: TActionList
Left = 24
Top = 72
object WindowArrange1: TWindowArrange
Category = 'Window'
Caption = 'Arrange Icons'
end
object WindowCascade1: TWindowCascade
Category = 'Window'
Caption = 'Cascade'
ImageIndex = 17
end
object WindowClose1: TWindowClose
Category = 'Window'
Caption = 'Close'
end
object WindowMinimizeAll1: TWindowMinimizeAll
Category = 'Window'
Caption = 'Minimize All'
end
object WindowTileHorizontal1: TWindowTileHorizontal
Category = 'Window'
Caption = 'Tile Horizontal'
ImageIndex = 15
end
object WindowTileVertical1: TWindowTileVertical
Category = 'Window'
Caption = 'Tile Vertical'
ImageIndex = 16
end
end
end
CHILD.DFM
object CircleChildForm: TCircleChildForm
Left = 223
Top = 148
Width = 361
Height = 213
Caption = 'MDI Child'
Color = clTeal
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
FormStyle = fsMDIChild
Menu = MainMenu1
Position = poDefault
Visible = True
OnClose = FormClose
OnCreate = FormCreate
OnMouseDown = FormMouseDown
OnPaint = FormPaint
PixelsPerInch = 96
TextHeight = 13
object MainMenu1: TMainMenu
Left = 8
Top = 8
object Circle1: TMenuItem
Caption = '&Circle'
GroupIndex = 2
object FillColor1: TMenuItem
Caption = '&Fill Color...'
OnClick = FillColor1Click
end
object BorderColor1: TMenuItem
Caption = '&Border Color...'
OnClick = BorderColor1Click
end
object BorderSize1: TMenuItem
Caption = 'Border &Size...'
OnClick = BorderSize1Click
end
object N1: TMenuItem
Caption = '-'
end
object GetPosition1: TMenuItem
Caption = '&Get Position'
OnClick = GetPosition1Click
end
end
end
object ColorDialog1: TColorDialog
Ctl3D = True
Left = 40
Top = 8
end
end
CHILD2.DFM
object BounceChildForm: TBounceChildForm
Left = 418
Top = 289
AutoScroll = False
Caption = 'Bouncing Square'
ClientHeight = 126
ClientWidth = 243
Color = clAqua
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
FormStyle = fsMDIChild
Menu = MainMenu1
Position = poDefault
Visible = True
OnClose = FormClose
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 16
object Shape1: TShape
Left = 40
Top = 48
Width = 30
Height = 30
Brush.Color = clFuchsia
Pen.Color = clBlue
Pen.Width = 2
Shape = stSquare
end
object Timer1: TTimer
Interval = 200
OnTimer = Timer1Timer
Left = 8
Top = 8
end
object MainMenu1: TMainMenu
Left = 40
Top = 8
object Square1: TMenuItem
Caption = '&Square'
GroupIndex = 2
object FillColor1: TMenuItem
Caption = '&Fill Color...'
OnClick = FillColor1Click
end
object N1: TMenuItem
Caption = '-'
end
object GetPosition1: TMenuItem
Caption = '&Get Position'
OnClick = GetPosition1Click
end
end
object Movement1: TMenuItem
Caption = '&Movement'
GroupIndex = 2
object Start1: TMenuItem
Caption = '&Start'
Enabled = False
OnClick = Start1Click
end
object Stop1: TMenuItem
Caption = 'S&top'
OnClick = Stop1Click
end
end
end
object ColorDialog1: TColorDialog
Ctl3D = True
Left = 72
Top = 8
end
end
Copyright Marco Cantù 1998