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