Category

Development Platform
Home > SourceCode/Document > Delphi VCL > View Code
Frame.pas
Package: delphi.rar　[view]
Upload User: fh681027
Upload Date: 2022-07-23
Package Size: 1959k
Code Size: 4k
Category:

Delphi VCL

Development Platform:

Delphi

Frame.pas：Code Content
  1. unit Frame;
  3. interface
  5. uses
  6.   Windows, Classes, Graphics, Forms, Messages,
  7.   Controls, Child, Child2, Menus, SysUtils, Dialogs,
  8.   ExtCtrls, StdActns, ActnList;
  10. type
  11.   TMainForm = class(TForm)
  12.     MainMenu1: TMainMenu;
  13.     Window1: TMenuItem;
  14.     New1: TMenuItem;
  15.     File1: TMenuItem;
  16.     N1: TMenuItem;
  17.     Exit1: TMenuItem;
  18.     Cascade1: TMenuItem;
  19.     Tile1: TMenuItem;
  20.     ArrangeIcons1: TMenuItem;
  21.     New2: TMenuItem;
  22.     Tile2: TMenuItem;
  23.     CloseAll1: TMenuItem;
  24.     Count1: TMenuItem;
  25.     Image1: TImage;
  26.     ActionList1: TActionList;
  27.     WindowArrange1: TWindowArrange;
  28.     WindowCascade1: TWindowCascade;
  29.     WindowClose1: TWindowClose;
  30.     WindowMinimizeAll1: TWindowMinimizeAll;
  31.     WindowTileHorizontal1: TWindowTileHorizontal;
  32.     WindowTileVertical1: TWindowTileVertical;
  33.     Close1: TMenuItem;
  34.     MinimizeAll1: TMenuItem;
  35.     N2: TMenuItem;
  36.     procedure New1Click(Sender: TObject);
  37.     procedure Exit1Click(Sender: TObject);
  38.     procedure New2Click(Sender: TObject);
  39.     procedure CloseAll1Click(Sender: TObject);
  40.     procedure Count1Click(Sender: TObject);
  41.     procedure FormCreate(Sender: TObject);
  42.     procedure FormDestroy(Sender: TObject);
  43.   private
  44.     { Private declarations }
  45.     Count: Integer;
  46.     OutCanvas: TCanvas;
  47.     OldWinProc, NewWinProc: Pointer;
  48.     procedure NewWinProcedure (var Msg: TMessage);
  49.   public
  50.     { Public declarations }
  51.   end;
  53. var
  54.   MainForm: TMainForm;
  56. implementation
  58. {$R *.DFM}
  60. procedure TMainForm.New1Click(Sender: TObject);
  61. var
  62.   ChildForm: TCircleChildForm;
  63. begin
  64.   Inc (Count);
  65.   ChildForm := TCircleChildForm.Create (Self);
  66.   ChildForm.Caption := ChildForm.Caption + ' ' +
  67.     IntToStr (Count);
  68.   ChildForm.Show;
  69. end;
  71. procedure TMainForm.Exit1Click(Sender: TObject);
  72. begin
  73.   Close;
  74. end;
  76. procedure TMainForm.New2Click(Sender: TObject);
  77. var
  78.   ChildForm: TBounceChildForm;
  79. begin
  80.   Inc (Count);
  81.   ChildForm := TBounceChildForm.Create (Self);
  82.   ChildForm.Caption := ChildForm.Caption + ' ' +
  83.     IntToStr (Count);
  84.   ChildForm.Show;
  85. end;
  87. procedure TMainForm.CloseAll1Click(Sender: TObject);
  88. var
  89.   I: Integer;
  90. begin
  91.   for I := 0 to MDIChildCount - 1 do
  92.     MDIChildren [I].Close;
  93. end;
  95. procedure TMainForm.Count1Click(Sender: TObject);
  96. var
  97.   NBounce, NCircle, I: Integer;
  98. begin
  99.   NBounce := 0;
  100.   NCircle := 0;
  101.   for I := 0 to MDIChildCount - 1 do
  102.     if MDIChildren [I] is TBounceChildForm then
  103.       Inc (NBounce)
  104.     else
  105.       Inc (NCircle);
  106.   MessageDlg (
  107.     Format ('There are %d child forms.'#13 +
  108.       '%d are Circle child windows and ' +
  109.       '%d are Bouncing child windows',
  110.       [MDIChildCount, NCircle, NBounce]),
  111.     mtINformation, [mbOk], 0);
  112. end;
  114. procedure TMainForm.FormCreate(Sender: TObject);
  115. begin
  116.   NewWinProc := MakeObjectInstance (NewWinProcedure);
  117.   OldWinProc := Pointer (SetWindowLong (
  118.     ClientHandle, gwl_WndProc, Cardinal (NewWinProc)));
  119.   OutCanvas := TCanvas.Create;
  120. end;
  122. procedure TMainForm.NewWinProcedure (var Msg: TMessage);
  123. var
  124.   BmpWidth, BmpHeight: Integer;
  125.   I, J: Integer;
  126. begin
  127.   // default processing first
  128.   Msg.Result := CallWindowProc (OldWinProc,
  129.     ClientHandle, Msg.Msg, Msg.wParam, Msg.lParam);
  131.   // handle background repaint
  132.   if Msg.Msg = wm_EraseBkgnd then
  133.   begin
  134.     BmpWidth := MainForm.Image1.Width;
  135.     BmpHeight := MainForm.Image1.Height;
  136.     if (BmpWidth <> 0) and (BmpHeight <> 0) then
  137.     begin
  138.       OutCanvas.Handle := Msg.wParam;
  139.       for I := 0 to MainForm.ClientWidth div BmpWidth do
  140.         for J := 0 to MainForm.ClientHeight div BmpHeight do
  141.           OutCanvas.Draw (I * BmpWidth,
  142.             J * BmpHeight, MainForm.Image1.Picture.Graphic);
  143.     end;
  144.   end;
  145. end;
  147. procedure TMainForm.FormDestroy(Sender: TObject);
  148. begin
  149.   OutCanvas.Free;
  150. end;
  152. end.