Turbo Pascal 7.0 / TP7 / DOCDEMOS / TDWDEMOA

 {*********************************************************************
 *          Copyright (c) 1991 by Borland International, Inc.         *
 *                                                                    *
 *                           TDWDEMOA.PAS                             *
 *                                                                    *
 *  This program is the first of two buggy versions of TDWDEMO.PAS.   *
 *  It has two bugs not found in TDWDEMO.PAS. The purpose of these    *
 *  two buggy programs is to show how to use TDW to debug a simple    *
 *  Windows graphics program written in Turbo Pascal.                 *
 *********************************************************************}

uses WinProcs, WinTypes;

{$R TDWDEMO.RES}

{**************************************************************
 * Globals
 **************************************************************}
const
  szAppName = 'SimplePaint';
  id_Line       = 1;
  id_Ellipse    = 2;
  id_Rectangle  = 3;

  mid_Quit      = 100;
  mid_Line      = 201;
  mid_Ellipse   = 202;
  mid_Rectangle = 203;
  mid_Thin      = 301;
  mid_Regular   = 302;
  mid_Thick     = 303;
  mid_Red       = 304;
  mid_Green     = 305;
  mid_Black     = 306;

  { Maintains the status of the shape the user is drawing. }
  { Default is to draw with a line.                        }
  CurrentShape : Integer = id_Line;

  { Maintains the current pen width. Default width is medium. }
  PenWidth : Integer = 3;

  { Maintains the current pen color. Default color is red. }
  PenColor : TColorRef = $00FF0000;


{ Record definition to track   }
{ what shapes have been drawn. }

type
  Shape = record
    Points: Trect;         { Location of the shape.           }
    PenWidth: Integer;     { Pen width for the shape.         }
    theShape: Integer;     { Shape this structure represents. }
    PenColor: TcolorRef;   { Color of the shape.              }

    { Used to determine direction lines should be drawn. If   }
    { slope > 0 then draw from UpperLeft to LowerRight. Else  }
    { draw from LowerLeft to UpperRight.                      }
    Slope: Integer;
  end;


const
  nPoints  = 100;

  { Indicates the number of shapes the user has drawn. }
  CurrentPoint : Integer = -1;

var
  { Array that stores the shapes the user draws. }
  thisShape: array[0..nPoints - 1] of Shape;


function Min(a, b: LongInt): LongInt;
begin
  if a < b then Min := a
  else Min := b;
end;

function Max(a, b: LongInt): LongInt;
begin
  if a > b then Max := a
  else Max := b;
end;

{****************************************************************
 * procedure DrawShape
 *
 *    Draws the shape given by Shape parameter using PenWidth
 *    and PenColor in the rectangle bounded by x,y,x2,y2.  The
 *    Slope parameter is used with line shapes to determine if
 *    lines should be drawn with a negative or positive slope.
 ****************************************************************}

procedure DrawShape(HandleDC: HDC; x, y, x2, y2, Shape,
               PenWidth: Integer; PenColor: TColorRef; Slope: Integer);
var
  SaveObject: THandle;
  SaveROP: Integer;
begin

  { Create the proper pen for this shape.  Save  }
  { the previously selected object from this DC. }
  SaveObject := SelectObject(HandleDC, CreatePen(ps_Solid,
    PenWidth, PenColor));
  case Shape of
    id_Line:
      { Rectangles that save a shape's position must be stored   }
      { as upper-left and lower-right.  To draw a line from      }
      { upper-right to lower-left, the line must have a negative }
      { slope.                                                   }
      if Slope > 0 then
      begin
        MoveTo(HandleDC, x, y);
        LineTo(HandleDC, x2, y2);
      end
      else
      begin
        MoveTo(HandleDC, x, y2);
        LineTo(HandleDC, x2, y);
      end;

    id_Ellipse:
      Ellipse(HandleDC, x, y, x2, y2);

    id_Rectangle:
      Rectangle(HandleDC, x, y, x2, y2);
  end;

  { Select whatever object was currently selected when }
  { we entered this routine.                           }
  SelectObject(HandleDC, SaveObject);
end;

{***************************************************************
 * procedure DoPaint
 *    Processes wm_Paint messages.  wm_Paint is generated
 *    whenever UpdateWindow is called or another window is moved,
 *    revealing a portion of the window receiving this message.
 ***************************************************************}

procedure DoPaint(HWindow: HWnd);
var
  i, SaveROP: Integer;
  HandleDC, hMemDC: HDC;
  theRect, DestRect: TRect;
  theBitmap: HBitMap;
  ps: TPaintStruct;

begin
  if CurrentPoint >= 0 then
  begin
    HandleDC := BeginPaint(HWindow, ps);
    { Determine which rectangle on the window is invalid.  }
    { If no rectangle is marked invalid, it will be a full }
    { window repaint.                                      }
    GetUpdateRect(HWindow, theRect, False);
    if IsRectEmpty(theRect) then GetClientRect(HWindow, theRect);

    { Create a memory DC and bitmap the same size as the update rectangle. }
    hMemDC := CreateCompatibleDC(HandleDC);
    theBitmap := CreateCompatibleBitmap(HandleDC,
      theRect.Right - theRect.Left, theRect.Bottom - theRect.Top);
    SelectObject(hMemDC,theBitmap);

    { Erase the memBitmap. }
    BitBlt(hMemDC, 0, 0,
      theRect.Right - theRect.Left, theRect.Bottom - theRect.Top,
      HandleDC, 0, 0, SRCCopy);

    { Draw only those shapes that lie within the update rectangle. }
    for i := 0 to CurrentPoint do
    begin
      IntersectRect(DestRect, thisShape[i].Points, theRect);
      if not IsRectEmpty(destRect) then
        DrawShape(hMemDC,
          thisShape[i].Points.Left - theRect.Left,
          thisShape[i].Points.Top - theRect.Top,
          thisShape[i].Points.Right - theRect.Left,
          thisShape[i].Points.Bottom - theRect.Top,
          thisShape[i].theShape, thisShape[i].PenWidth,
          thisShape[i].PenColor, thisShape[i].Slope);
          { Note that when drawing the shape, the shape's     }
          { position was transformed so that the origin was   }
          { at the upper-left corner of the update rectangle. }
          { This is the point (0,0) on the bitmap that will   }
          { map onto (theRect.Left, theRect.Right).           }
    end;

    { Finally, copy the bitmap onto the update rectangle. }
    BitBlt(HandleDC, theRect.Left, theRect.Top,
      theRect.Right - theRect.Left, theRect.Bottom - theRect.Top,
      hMemDC, 0, 0, SRCCopy);

    DeleteDC(hMemDC);
    DeleteObject(theBitmap);
    ReleaseDC(HWindow, HandleDC);
    EndPaint(HWindow, ps);
  end;

end;


{*********************************************************
 * static variables oldx, oldy, mouseDown
 *    Used to maintain both the state of the mouse position
 *    and the button status between mouse messages.
 *********************************************************}

const
  Oldx: Integer = -1;
  Oldy: Integer = -1;
  MouseDown : Boolean = False;

{*****************************************************************
 * procedure DoLButtonDown
 *    DoLButtonDown process wm_LButtonDown messages, generated when
 *    the user presses the left mouse button.  This routine
 *    saves the origin of this shape, the current pen parameters,
 *    and the current shape into the shapes array.  The mouse
 *    button is also marked as pressed.
 *****************************************************************}

procedure DoLButtonDown(HWindow: HWnd; lParam: LongInt);
begin
  { Redirect all subsequent mouse movements to this }
  { window until the mouse button is released.      }
  SetCapture(HWindow);
  Inc(CurrentPoint);
  thisShape[CurrentPoint].Points.Top := HiWord(lParam);
  thisShape[CurrentPoint].Points.Left := LoWord(lParam);
  Oldy := HiWord(lParam);
  Oldx := LoWord(lParam);
  thisShape[CurrentPoint].theShape := CurrentShape;
  thisShape[CurrentPoint].PenWidth := PenWidth;
  thisShape[CurrentPoint].PenColor := PenColor;

  MouseDown := True;
end;

{*****************************************************************
 * procedure DoLButtonUp
 *    DoLButtonUp processes wm_LButtonUp messages, generated when
 *    the user releases the left mouse button.  This routine
 *    allows other windows to receive mouse messages and saves
 *    the position of the mouse as the other corner of a bounding
 *    rectangle for the shape.
 *****************************************************************}

procedure DoLButtonUp(HWindow: HWnd; lParam: LongInt);
begin
  ReleaseCapture;

  { For rectangles to work with the IntersectRect function, }
  { they must be stored as left, top, right, bottom.        }
  SetRect(thisShape[CurrentPoint].Points,
    Min(thisShape[CurrentPoint].Points.Left, LoWord(lParam)),
    Min(thisShape[CurrentPoint].Points.Top, HiWord(lParam)),
    Max(thisShape[CurrentPoint].Points.Left, LoWord(lParam)),
    Max(thisShape[CurrentPoint].Points.Top, HiWord(lParam)));

  { if the origin of the line has changed, it should be drawn }
  { from upper-right to lower left and therefore has negative }
  { slope.  Otherwise it will have positive slope.            }
  if CurrentShape = id_Line then
  begin
    if (thisShape[CurrentPoint].Points.Left = LoWord(lParam)) or
       (thisShape[CurrentPoint].Points.Top = HiWord(lParam)) then
      thisShape[CurrentPoint].Slope := -1
    else
      thisShape[CurrentPoint].Slope := 1;
  end;
  { Mark this region on the window as needing  }
  { redrawing and force an update.             }
  InvalidateRect(HWindow, @thisShape[CurrentPoint].Points, False);
  UpdateWindow(HWindow);
  MouseDown := False;
  Oldx := -1;
  Oldy := -1;
end;

var
  SaveROP: Integer;

{*********************************************************************
 * procedure DoMouseMove
 *    DoMouseMove processes wm_MouseMove messages, generated when the
 *    user moves the mouse.  When the user moves the mouse and holds the
 *    button down, this procedure draws the current shape by using the
 *    raster operation NOTXORPEN.  When this mode is used, drawing the
 *    same image twice returns the image to its original state.
 *    NOTXORPEN turns black on black white, black on white black
 *    and white on white white.
 *********************************************************************}

procedure DoMouseMove(HWindow: HWnd; lParam: LongInt);
var
  HandleDC: HDC;
begin
  if MouseDown then
  begin
    HandleDC := GetDC(HWindow);
    { Erase the old shape. }
    SaveROP := SetROP2(HandleDC, r2_NotXORPen);
    DrawShape(HandleDC, thisShape[CurrentPoint].Points.Left,
      thisShape[CurrentPoint].Points.top, Oldx, Oldy,
      thisShape[CurrentPoint].theShape,
      thisShape[CurrentPoint].PenWidth,
      thisShape[CurrentPoint].PenColor, 1);
    { At this point, the slope must be positive because }
    { the coordinates could not have been switched.     }
    { The next step is to draw the new shape.           }

    Oldx := LoWord(lParam);
    Oldy := HiWord(lParam);
    DrawShape(HandleDC, thisShape[CurrentPoint].Points.Left,
      thisShape[CurrentPoint].Points.Top, Oldx, Oldy,
      thisShape[CurrentPoint].theShape,
      thisShape[CurrentPoint].PenWidth,
      thisShape[CurrentPoint].PenColor, 1);
    SetROP2(HandleDC, SaveROP);
    ReleaseDC(HWindow, HandleDC);
  end;

end;

{********************************************************************
 * function DoWMCommand
 *    DoWMCommand processes wm_Command messages.  wm_Command
 *    is generated when the user selects something from the menu.
 *    This function changes the current state of shape selections
 *    to match the user's menu selection.
 ******************************************************************}

function DoWMCommand(wParam: Word): Integer;
begin
  DoWMCommand := 1;
  case wParam of
    mid_QUIT:
      PostQuitMessage(0);

    mid_Line:
      CurrentShape := id_Line;

    mid_Ellipse:
      CurrentShape := id_Ellipse;

    mid_Rectangle:
      CurrentShape := id_Rectangle;

    mid_Thin:
      PenWidth := 1;

    mid_Regular:
      PenWidth := 3;

    mid_Thick:
      PenWidth := 5;

    mid_Red:
      PenColor := RGB(255, 0, 0);

    mid_Green:
      PenColor := RGB(0, 255, 0);

    mid_Black:
      PenColor := RGB(0, 0, 0);
  else
    DoWMCommand := 0;
  end;

end;

{******************************************************
 * function WndProc
 * WndProc is the callback function (window proc)
 * for the Simple Paint class of windows. It
 * handles all messages received by the window
 ******************************************************}

function WndProc (HWindow : HWnd; Message: Word;
                  wParam: Word; lParam: LongInt): LongInt; export;
begin
  WndProc := 0;
  case Message of
    wm_Command:
      WndProc := DoWMCommand(wParam);

    wm_LButtonDown:
      DoLButtonDown(HWindow,lParam);

    wm_LButtonUp:
      DoLButtonUp(HWindow,lParam);

    wm_MouseMove:
      DoMouseMove(HWindow,lParam);

    wm_Paint:
      DoPaint(HWindow);
  else
    WndProc := DefWindowProc(HWindow, Message, wParam, lParam);
  end;
end;

var
  theWndClass: TWndClass;
  theMessage: TMsg;
  HWindow: HWnd;

begin

  { Register window class style if first instance of this program. }
  if hPrevInst = 0 then
  begin
    theWndClass.style := cs_HRedraw or cs_VRedraw ;
    theWndClass.lpfnWndProc := @WndProc;
    theWndClass.cbClsExtra := 0;
    theWndClass.cbWndExtra := 0;
    theWndClass.hInstance := hInstance;
    theWndClass.hIcon := LoadIcon(0, 'ide_SimplePaint');
    theWndClass.hCursor := LoadCursor(0, idc_Arrow );
    theWndClass.hbrBackground := GetStockObject(White_Brush);
    theWndClass.lpszMenuName := szAppName;
    theWndClass.lpszClassName := szAppName;

    if not RegisterClass(theWndClass) then Halt;
  end;

  { Create and display the window. }
  HWindow := CreateWindow(szAppName,'Simple Paint',
    ws_OverLappedWindow, cw_UseDefault, 0,
    cw_UseDefault, 0, 0, 0, hInstance, nil);

  ShowWindow(HWindow, CmdShow);
  UpdateWindow(HWindow);

  while GetMessage(theMessage, 0, 0, 0) do
  begin
    TranslateMessage(theMessage );
    DispatchMessage(theMessage );
  end;
end.