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