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