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.