home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MAGAZINE / MISC / PCTV2N2.ZIP / FAST.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-03-27  |  3.8 KB  |  152 lines
  1. { fast.pas -- Draw polygon by "blasting" a bitmap }
  2.  
  3. program Fast;
  4.  
  5. {$R test.res}   { Attach binary resources to .EXE file }
  6.  
  7. uses WinTypes, WinProcs, WObjects, Poly;
  8.  
  9. const
  10.  
  11.   id_Menu     = 100;    { Menu resource ID }
  12.   cm_NewShape = 101;    { Menu New Shape command ID }
  13.   cm_Quit     = 102;    { Menu Quit command ID }
  14.   numShapes   = 5;      { Number of polygons to display }
  15.  
  16. type
  17.  
  18.   TestApplication = object(TApplication)
  19.     procedure InitMainWindow; virtual;
  20.   end;
  21.  
  22.   PTestWindow = ^TestWindow;
  23.   TestWindow = object(TWindow)
  24.     PolyBits: HBitmap;        { Handle to a bitmap }
  25.     PolyShapes: PCollection;  { Collection of shapes }
  26.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  27.     destructor Done; virtual;
  28.     procedure CMNewShape(var Msg: TMessage);
  29.       virtual cm_First + cm_NewShape;
  30.     procedure CMQuit(var Msg: TMessage);
  31.       virtual cm_First + cm_Quit;
  32.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  33.       virtual;
  34.   end;
  35.  
  36.  
  37. {----- TestApplication methods -----}
  38.  
  39. {- Initialize TestApplication object's window }
  40. procedure TestApplication.InitMainWindow;
  41. begin
  42.   MainWindow := New(PTestWindow, Init(nil, 'Fast Paint Demo'));
  43.   Randomize
  44. end;
  45.  
  46.  
  47. {----- TestWindow methods -----}
  48.  
  49. {- Construct TestWindow object }
  50. constructor TestWindow.Init(AParent: PWindowsObject;
  51.  ATitle: PChar);
  52. var
  53.   I: Integer;
  54. begin
  55.   TWindow.Init(AParent, ATitle);
  56.   PolyBits := 0;  { No bitmap available yet }
  57.   PolyShapes := New(PCollection, Init(numShapes, 0));
  58.   if PolyShapes = nil then
  59.   begin
  60.     MessageBox(0, 'Not enough memory available',
  61.      'Fata Error', mb_SystemModal);
  62.     PostQuitMessage(0)
  63.   end;
  64.   Attr.Menu := LoadMenu(HInstance, PChar(id_Menu))
  65. end;
  66.  
  67. {- Dispose of TestWindow object }
  68. destructor TestWindow.Done;
  69. begin
  70.   if PolyBits <> 0 then DeleteObject(Polybits);
  71.   if PolyShapes <> nil then Dispose(PolyShapes, Done);
  72.   TWindow.Done
  73. end;
  74.  
  75. {- Execute Menu:New Shape command }
  76. procedure TestWindow.CMNewShape(var Msg: TMessage);
  77. var
  78.   P: PPolygon;
  79.   I: Integer;
  80.   R: TRect;
  81. begin
  82.   if PolyBits <> 0 then
  83.   begin
  84.     DeleteObject(PolyBits);
  85.     PolyBits := 0
  86.   end;
  87.   PolyShapes^.Freeall;
  88.   GetClientRect(HWindow, R);
  89.   for I := 0 to numShapes - 1 do
  90.   begin
  91.     P := New(PPolygon, Init(50, R.Right, R.Bottom));
  92.     if P <> nil then
  93.       PolyShapes^.Insert(P)
  94.   end;
  95.   InvalidateRect(HWindow, nil, true)
  96. end;
  97.  
  98. {- Execute Menu:Exit command }
  99. procedure TestWindow.CMQuit(var Msg: TMessage);
  100. begin
  101.   CloseWindow
  102. end;
  103.  
  104. {- Paint window's client area, showing current polygons }
  105. procedure TestWindow.Paint(PaintDC: HDC;
  106.  var PaintInfo: TPaintStruct);
  107. var
  108.   R: TRect;
  109.   MemDC: HDC;
  110.   OldBitmap: HBitmap;
  111.  
  112.   procedure DrawShape(P: PPolygon); far;
  113.   begin
  114.     P^.Draw(PaintDC)
  115.   end;
  116.  
  117. begin
  118.   if PolyShapes^.Count = 0 then Exit;  { Nothing to do }
  119.   GetClientRect(HWindow, R);
  120.   MemDC := CreateCompatibleDC(PaintDC);
  121.   if PolyBits = 0 then
  122.   begin {- Draw pattern the "hard" way and create bitmap }
  123.     PolyShapes^.ForEach(@DrawShape);
  124.     PolyBits:=CreateCompatibleBitmap(PaintDC, R.Right, R.Bottom);
  125.     OldBitmap := SelectObject(MemDC, Polybits);
  126.     BitBlt(MemDC, 0,0, R.Right, R.Bottom, PaintDC, 0,0, srcCopy)
  127.   end else with PaintInfo.rcPaint do
  128.   begin {- Redraw pattern the "easy" way using bitmap }
  129.     OldBitmap := SelectObject(MemDC, Polybits);
  130.     BitBlt(PaintDC, Left, Top, Right, Bottom, MemDC, Left, Top,
  131.      srcCopy)
  132.   end;
  133.   SelectObject(MemDC, OldBitmap);
  134.   DeleteDC(MemDC)
  135. end;
  136.  
  137. var
  138.  
  139.   FastApp: TestApplication;
  140.  
  141. begin
  142.   FastApp.Init('FastApp');
  143.   FastApp.Run;
  144.   FastApp.Done
  145. end.
  146.  
  147.  
  148. {--------------------------------------------------------------
  149.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  150.   Revision 1.00    Date: 3/26/1991
  151. ---------------------------------------------------------------}
  152.