home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / tpw / docdemos / tdwdemob.pas < prev    next >
Pascal/Delphi Source File  |  1991-05-20  |  15KB  |  446 lines
  1.  {*********************************************************************
  2.  *          Copyright (c) 1991 by Borland International, Inc.         *
  3.  *                                                                    *
  4.  *                           TDWDEMOB.PAS                             *
  5.  *                                                                    *
  6.  *  This program is the second of two buggy versions of TDWDEMO.PAS.  *
  7.  *  It has only one of the two bugs in TDWDEMOA.PAS; the first bug    *
  8.  *  from that program is corrected in this one. The purpose of these  *
  9.  *  two buggy programs is to show how to use TDW to debug a simple    *
  10.  *  Windows graphics program written in Turbo Pascal.                 *
  11.  *********************************************************************}
  12.  
  13. uses WinProcs, WinTypes;
  14.  
  15. {$R TDWDEMO.RES}
  16.  
  17. {**************************************************************
  18.  * Globals
  19.  **************************************************************}
  20. const
  21.   szAppName = 'SimplePaint';
  22.   id_Line       = 1;
  23.   id_Ellipse    = 2;
  24.   id_Rectangle  = 3;
  25.  
  26.   mid_Quit      = 100;
  27.   mid_Line      = 201;
  28.   mid_Ellipse   = 202;
  29.   mid_Rectangle = 203;
  30.   mid_Thin      = 301;
  31.   mid_Regular   = 302;
  32.   mid_Thick     = 303;
  33.   mid_Red       = 304;
  34.   mid_Green     = 305;
  35.   mid_Black     = 306;
  36.  
  37.   { Maintains the status of the shape the user is drawing. }
  38.   { Default is to draw with a line.                        }
  39.   CurrentShape : Integer = id_Line;
  40.  
  41.   { Maintains the current pen width. Default width is medium. }
  42.   PenWidth : Integer = 3;
  43.  
  44.   { Maintains the current pen color. Default color is red. }
  45.   PenColor : TColorRef = $00FF0000;
  46.  
  47.  
  48. { Record definition to track   }
  49. { what shapes have been drawn. }
  50.  
  51. type
  52.   Shape = record
  53.     Points: Trect;         { Location of the shape.           }
  54.     PenWidth: Integer;     { Pen width for the shape.         }
  55.     theShape: Integer;     { Shape this structure represents. }
  56.     PenColor: TcolorRef;   { Color of the shape.              }
  57.  
  58.     { Used to determine direction lines should be drawn. If   }
  59.     { slope > 0 then draw from UpperLeft to LowerRight. Else  }
  60.     { draw from LowerLeft to UpperRight.                      }
  61.     Slope: Integer;
  62.   end;
  63.  
  64.  
  65. const
  66.   nPoints  = 100;
  67.  
  68.   { Indicates the number of shapes the user has drawn. }
  69.   CurrentPoint : Integer = -1;
  70.  
  71. var
  72.   { Array that stores the shapes the user draws. }
  73.   thisShape: array[0..nPoints - 1] of Shape;
  74.  
  75.  
  76. function Min(a, b: LongInt): LongInt;
  77. begin
  78.   if a < b then Min := a
  79.   else Min := b;
  80. end;
  81.  
  82. function Max(a, b: LongInt): LongInt;
  83. begin
  84.   if a > b then Max := a
  85.   else Max := b;
  86. end;
  87.  
  88. {****************************************************************
  89.  * procedure DrawShape
  90.  *
  91.  *    Draws the shape given by Shape parameter using PenWidth
  92.  *    and PenColor in the rectangle bounded by x,y,x2,y2.  The
  93.  *    Slope parameter is used with line shapes to determine if
  94.  *    lines should be drawn with a negative or positive slope.
  95.  ****************************************************************}
  96.  
  97. procedure DrawShape(HandleDC: HDC; x, y, x2, y2, Shape,
  98.                PenWidth: Integer; PenColor: TColorRef; Slope: Integer);
  99. var
  100.   SaveObject: THandle;
  101.   SaveROP: Integer;
  102. begin
  103.  
  104.   { Create the proper pen for this shape.  Save  }
  105.   { the previously selected object from this DC. }
  106.   SaveObject := SelectObject(HandleDC, CreatePen(ps_Solid,
  107.     PenWidth, PenColor));
  108.   case Shape of
  109.     id_Line:
  110.       { Rectangles that save a shape's position must be stored   }
  111.       { as upper-left and lower-right.  To draw a line from      }
  112.       { upper-right to lower-left, the line must have a negative }
  113.       { slope.                                                   }
  114.       if Slope > 0 then
  115.       begin
  116.         MoveTo(HandleDC, x, y);
  117.         LineTo(HandleDC, x2, y2);
  118.       end
  119.       else
  120.       begin
  121.         MoveTo(HandleDC, x, y2);
  122.         LineTo(HandleDC, x2, y);
  123.       end;
  124.  
  125.     id_Ellipse:
  126.       Ellipse(HandleDC, x, y, x2, y2);
  127.  
  128.     id_Rectangle:
  129.       Rectangle(HandleDC, x, y, x2, y2);
  130.   end;
  131.  
  132.   { Select whatever object was currently selected when }
  133.   { we entered this routine.                           }
  134.   SelectObject(HandleDC, SaveObject);
  135. end;
  136.  
  137. {***************************************************************
  138.  * procedure DoPaint
  139.  *    Processes wm_Paint messages.  wm_Paint is generated
  140.  *    whenever UpdateWindow is called or another window is moved,
  141.  *    revealing a portion of the window receiving this message.
  142.  ***************************************************************}
  143.  
  144. procedure DoPaint(HWindow: HWnd);
  145. var
  146.   i, SaveROP: Integer;
  147.   HandleDC, hMemDC: HDC;
  148.   theRect, DestRect: TRect;
  149.   theBitmap: HBitMap;
  150.   ps: TPaintStruct;
  151.  
  152. begin
  153.   HandleDC := BeginPaint(HWindow, ps);
  154.  
  155.   if CurrentPoint >= 0 then
  156.   begin
  157.     { Determine which rectangle on the window is invalid.  }
  158.     { If no rectangle is marked invalid, it will be a full }
  159.     { window repaint.                                      }
  160.     GetUpdateRect(HWindow, theRect, False);
  161.     if IsRectEmpty(theRect) then GetClientRect(HWindow, theRect);
  162.  
  163.     { Create a memory DC and bitmap the same size as the update rectangle. }
  164.     hMemDC := CreateCompatibleDC(HandleDC);
  165.     theBitmap := CreateCompatibleBitmap(HandleDC,
  166.       theRect.Right - theRect.Left, theRect.Bottom - theRect.Top);
  167.     SelectObject(hMemDC,theBitmap);
  168.  
  169.     { Erase the memBitmap. }
  170.     BitBlt(hMemDC, 0, 0,
  171.       theRect.Right - theRect.Left, theRect.Bottom - theRect.Top,
  172.       HandleDC, 0, 0, SRCCopy);
  173.  
  174.     { Draw only those shapes that lie within the update rectangle. }
  175.     for i := 0 to CurrentPoint do
  176.     begin
  177.       IntersectRect(DestRect, thisShape[i].Points, theRect);
  178.       if not IsRectEmpty(destRect) then
  179.         DrawShape(hMemDC,
  180.           thisShape[i].Points.Left - theRect.Left,
  181.           thisShape[i].Points.Top - theRect.Top,
  182.           thisShape[i].Points.Right - theRect.Left,
  183.           thisShape[i].Points.Bottom - theRect.Top,
  184.           thisShape[i].theShape, thisShape[i].PenWidth,
  185.           thisShape[i].PenColor, thisShape[i].Slope);
  186.           { Note that when drawing the shape, the shape's     }
  187.           { position was transformed so that the origin was   }
  188.           { at the upper-left corner of the update rectangle. }
  189.           { This is the point (0,0) on the bitmap that will   }
  190.           { map onto (theRect.Left, theRect.Right).           }
  191.     end;
  192.  
  193.     { Finally, copy the bitmap onto the update rectangle. }
  194.     BitBlt(HandleDC, theRect.Left, theRect.Top,
  195.       theRect.Right - theRect.Left, theRect.Bottom - theRect.Top,
  196.       hMemDC, 0, 0, SRCCopy);
  197.  
  198.     DeleteDC(hMemDC);
  199.     DeleteObject(theBitmap);
  200.   end;
  201.  
  202.     ReleaseDC(HWindow, HandleDC);
  203.     EndPaint(HWindow, ps);
  204. end;
  205.  
  206.  
  207. {*********************************************************
  208.  * static variables oldx, oldy, mouseDown
  209.  *    Used to maintain both the state of the mouse position
  210.  *    and the button status between mouse messages.
  211.  *********************************************************}
  212.  
  213. const
  214.   Oldx: Integer = -1;
  215.   Oldy: Integer = -1;
  216.   MouseDown : Boolean = False;
  217.  
  218. {*****************************************************************
  219.  * procedure DoLButtonDown
  220.  *    DoLButtonDown process wm_LButtonDown messages, generated when
  221.  *    the user presses the left mouse button.  This routine
  222.  *    saves the origin of this shape, the current pen parameters,
  223.  *    and the current shape into the shapes array.  The mouse
  224.  *    button is also marked as pressed.
  225.  *****************************************************************}
  226.  
  227. procedure DoLButtonDown(HWindow: HWnd; lParam: LongInt);
  228. begin
  229.   { Redirect all subsequent mouse movements to this }
  230.   { window until the mouse button is released.      }
  231.   SetCapture(HWindow);
  232.   Inc(CurrentPoint);
  233.   thisShape[CurrentPoint].Points.Top := HiWord(lParam);
  234.   thisShape[CurrentPoint].Points.Left := LoWord(lParam);
  235.   Oldy := HiWord(lParam);
  236.   Oldx := LoWord(lParam);
  237.   thisShape[CurrentPoint].theShape := CurrentShape;
  238.   thisShape[CurrentPoint].PenWidth := PenWidth;
  239.   thisShape[CurrentPoint].PenColor := PenColor;
  240.  
  241.   MouseDown := True;
  242. end;
  243.  
  244. {*****************************************************************
  245.  * procedure DoLButtonUp
  246.  *    DoLButtonUp processes wm_LButtonUp messages, generated when
  247.  *    the user releases the left mouse button.  This routine
  248.  *    allows other windows to receive mouse messages and saves
  249.  *    the position of the mouse as the other corner of a bounding
  250.  *    rectangle for the shape.
  251.  *****************************************************************}
  252.  
  253. procedure DoLButtonUp(HWindow: HWnd; lParam: LongInt);
  254. begin
  255.   ReleaseCapture;
  256.  
  257.   { For rectangles to work with the IntersectRect function, }
  258.   { they must be stored as left, top, right, bottom.        }
  259.   SetRect(thisShape[CurrentPoint].Points,
  260.     Min(thisShape[CurrentPoint].Points.Left, LoWord(lParam)),
  261.     Min(thisShape[CurrentPoint].Points.Top, HiWord(lParam)),
  262.     Max(thisShape[CurrentPoint].Points.Left, LoWord(lParam)),
  263.     Max(thisShape[CurrentPoint].Points.Top, HiWord(lParam)));
  264.  
  265.   { if the origin of the line has changed, it should be drawn }
  266.   { from upper-right to lower left and therefore has negative }
  267.   { slope.  Otherwise it will have positive slope.            }
  268.   if CurrentShape = id_Line then
  269.   begin
  270.     if (thisShape[CurrentPoint].Points.Left = LoWord(lParam)) or
  271.        (thisShape[CurrentPoint].Points.Top = HiWord(lParam)) then
  272.       thisShape[CurrentPoint].Slope := -1
  273.     else
  274.       thisShape[CurrentPoint].Slope := 1;
  275.   end;
  276.   { Mark this region on the window as needing  }
  277.   { redrawing and force an update.             }
  278.   InvalidateRect(HWindow, @thisShape[CurrentPoint].Points, False);
  279.   UpdateWindow(HWindow);
  280.   MouseDown := False;
  281.   Oldx := -1;
  282.   Oldy := -1;
  283. end;
  284.  
  285. var
  286.   SaveROP: Integer;
  287.  
  288. {*********************************************************************
  289.  * procedure DoMouseMove
  290.  *    DoMouseMove processes wm_MouseMove messages, generated when the
  291.  *    user moves the mouse.  When the user moves the mouse and holds the
  292.  *    button down, this procedure draws the current shape by using the
  293.  *    raster operation NOTXORPEN.  When this mode is used, drawing the
  294.  *    same image twice returns the image to its original state.
  295.  *    NOTXORPEN turns black on black white, black on white black
  296.  *    and white on white white.
  297.  *********************************************************************}
  298.  
  299. procedure DoMouseMove(HWindow: HWnd; lParam: LongInt);
  300. var
  301.   HandleDC: HDC;
  302. begin
  303.   if MouseDown then
  304.   begin
  305.     HandleDC := GetDC(HWindow);
  306.     { Erase the old shape. }
  307.     SaveROP := SetROP2(HandleDC, r2_NotXORPen);
  308.     DrawShape(HandleDC, thisShape[CurrentPoint].Points.Left,
  309.       thisShape[CurrentPoint].Points.top, Oldx, Oldy,
  310.       thisShape[CurrentPoint].theShape,
  311.       thisShape[CurrentPoint].PenWidth,
  312.       thisShape[CurrentPoint].PenColor, 1);
  313.     { At this point, the slope must be positive because }
  314.     { the coordinates could not have been switched.     }
  315.     { The next step is to draw the new shape.           }
  316.  
  317.     Oldx := LoWord(lParam);
  318.     Oldy := HiWord(lParam);
  319.     DrawShape(HandleDC, thisShape[CurrentPoint].Points.Left,
  320.       thisShape[CurrentPoint].Points.Top, Oldx, Oldy,
  321.       thisShape[CurrentPoint].theShape,
  322.       thisShape[CurrentPoint].PenWidth,
  323.       thisShape[CurrentPoint].PenColor, 1);
  324.     SetROP2(HandleDC, SaveROP);
  325.     ReleaseDC(HWindow, HandleDC);
  326.   end;
  327.  
  328. end;
  329.  
  330. {********************************************************************
  331.  * function DoWMCommand
  332.  *    DoWMCommand processes wm_Command messages.  wm_Command
  333.  *    is generated when the user selects something from the menu.
  334.  *    This function changes the current state of shape selections
  335.  *    to match the user's menu selection.
  336.  ******************************************************************}
  337.  
  338. function DoWMCommand(wParam: Word): Integer;
  339. begin
  340.   DoWMCommand := 1;
  341.   case wParam of
  342.     mid_QUIT:
  343.       PostQuitMessage(0);
  344.  
  345.     mid_Line:
  346.       CurrentShape := id_Line;
  347.  
  348.     mid_Ellipse:
  349.       CurrentShape := id_Ellipse;
  350.  
  351.     mid_Rectangle:
  352.       CurrentShape := id_Rectangle;
  353.  
  354.     mid_Thin:
  355.       PenWidth := 1;
  356.  
  357.     mid_Regular:
  358.       PenWidth := 3;
  359.  
  360.     mid_Thick:
  361.       PenWidth := 5;
  362.  
  363.     mid_Red:
  364.       PenColor := RGB(255, 0, 0);
  365.  
  366.     mid_Green:
  367.       PenColor := RGB(0, 255, 0);
  368.  
  369.     mid_Black:
  370.       PenColor := RGB(0, 0, 0);
  371.   else
  372.     DoWMCommand := 0;
  373.   end;
  374.  
  375. end;
  376.  
  377. {******************************************************
  378.  * function WndProc
  379.  * WndProc is the callback function (window proc)
  380.  * for the Simple Paint class of windows. It
  381.  * handles all messages received by the window
  382.  ******************************************************}
  383.  
  384. function WndProc (HWindow : HWnd; Message: Word;
  385.                   wParam: Word; lParam: LongInt): LongInt; export;
  386. begin
  387.   WndProc := 0;
  388.   case Message of
  389.     wm_Command:
  390.       WndProc := DoWMCommand(wParam);
  391.  
  392.     wm_LButtonDown:
  393.       DoLButtonDown(HWindow,lParam);
  394.  
  395.     wm_LButtonUp:
  396.       DoLButtonUp(HWindow,lParam);
  397.  
  398.     wm_MouseMove:
  399.       DoMouseMove(HWindow,lParam);
  400.  
  401.     wm_Paint:
  402.       DoPaint(HWindow);
  403.   else
  404.     WndProc := DefWindowProc(HWindow, Message, wParam, lParam);
  405.   end;
  406. end;
  407.  
  408. var
  409.   theWndClass: TWndClass;
  410.   theMessage: TMsg;
  411.   HWindow: HWnd;
  412.  
  413. begin
  414.  
  415.   { Register window class style if first instance of this program. }
  416.   if hPrevInst = 0 then
  417.   begin
  418.     theWndClass.style := cs_HRedraw or cs_VRedraw ;
  419.     theWndClass.lpfnWndProc := @WndProc;
  420.     theWndClass.cbClsExtra := 0;
  421.     theWndClass.cbWndExtra := 0;
  422.     theWndClass.hInstance := hInstance;
  423.     theWndClass.hIcon := LoadIcon(0, 'ide_SimplePaint');
  424.     theWndClass.hCursor := LoadCursor(0, idc_Arrow );
  425.     theWndClass.hbrBackground := GetStockObject(White_Brush);
  426.     theWndClass.lpszMenuName := szAppName;
  427.     theWndClass.lpszClassName := szAppName;
  428.  
  429.     if not RegisterClass(theWndClass) then Halt;
  430.   end;
  431.  
  432.   { Create and display the window. }
  433.   HWindow := CreateWindow(szAppName,'Simple Paint',
  434.     ws_OverLappedWindow, cw_UseDefault, 0,
  435.     cw_UseDefault, 0, 0, 0, hInstance, nil);
  436.  
  437.   ShowWindow(HWindow, CmdShow);
  438.   UpdateWindow(HWindow);
  439.  
  440.   while GetMessage(theMessage, 0, 0, 0) do
  441.   begin
  442.     TranslateMessage(theMessage );
  443.     DispatchMessage(theMessage );
  444.   end;
  445. end.
  446.