Power-Programmierung/CD1.mdf/pascal/tpw/docdemos/tdodemob.pas

Pascal/Delphi Source File | 1991-05-20 | 13KB | 329 lines

{***********************************************************************
 *  Copyright (c) 1991 - Borland International.
 *
 *  File: TDODEMOB.PAS
 *
 *  Buggy version of the TDODEMO.PAS that shows how to use TDW to
 *  debug an Object Windows application.
 *
 *  The Color Scribble program lets the user draw on the screen in
 *  any of four colors: red, green, blue, and black. This version
 *  contains several bugs that you can use TDW to find and Turbo Pascal
 *  for Windows to correct. For more information, see the Turbo Debugger
 *  User's Guide and read the section on debugging an Object Windows
 *  application.
 ***********************************************************************}

program CScribble;

{$R TDODEMO.RES} { Include resource file having menu definition. }

uses  WinTypes, WinProcs, WObjects;

const
  PenWidth   = 1;          { Width of Scribble line.      }
  MenuID     = 100;        { ID of menu in resource file. }
  IconID     = 100;        { ID of Icon in resource file. }
  RedMenu    = 101;        { Value of Pen|Red menu.       }
  GreenMenu  = 102;        { Value of Pen|Green menu.     }
  BlueMenu   = 103;        { Value of Pen|Blue menu.      }
  BlackMenu  = 104;        { Value of Pen|Black menu.     }

type
{ --------------------------------------------------------
  CScribbleApplication type.
  -------------------------------------------------------- }
 CScribbleApplication = object(TApplication)
   procedure InitMainWindow; virtual; { Creates main window }
 end;


type
{ --------------------------------------------------------
  ScribbleWindow type.
  -------------------------------------------------------- }

  PScribbleWindow = ^ScribbleWindow;
  ScribbleWindow = object(TWindow)
    HandleDC: HDC;        { Display context for drawing.          }
              { Preserves value while dragging mouse. }
    ButtonDown: Boolean;  { left-button-down flag }

    constructor Init(aParent: PWindowsObject; aTitle: PChar);

      { Virtual method that gets called when the left mouse      }
      {    button is clicked in the window.  This method sets up    }
      {    the window for scribbling by creating a display context. }
    procedure WMLButtonDown(var Msg: TMessage); virtual WM_LBUTTONDOWN;

      { Virtual method that gets called when the left mouse     }
      {    button is released in the window.  This method releases }
      {    the display context that is used for drawing.           }
    procedure WMLButtonUp(var Msg: TMessage); virtual WM_LBUTTONUP;

      { Virtual method that gets called when the mouse is   }
      { moved anywhere in the window.  If the left mouse    }
      { button is pressed, the window will be scribbled in. }
    procedure WMMouseMove(var Msg: TMessage); virtual WM_MOUSEMOVE;

      { Virtual method that gets called when the right mouse button }
      {    is clicked in the window.  It clears the window by invali-  }
      {    dating the window, causing a WM_PAINT message to be sent.   }
    procedure WMRButtonDown(var Msg: TMessage); virtual WM_RBUTTONDOWN;

  end;


{ --------------------------------------------------------
  CScribbleWindow type.
  -------------------------------------------------------- }
  PCScribbleWindow = ^CScribbleWindow;
  CScribbleWindow = object(ScribbleWindow)
    thePen: HPen;  { Pen that is used for drawing in color }

      { Adds a menu to the window and }
      { initializes the pen to black. }
    constructor Init(aParent: PWindowsObject; ATitle: PChar);

    destructor Done; virtual;   { Disposes of the pen. }

      { Virtual method that gets called when user      }
      { selects Pen.Red from the menu bar. Disposes   }
      { of the current pen and creates a red pen.      }
    procedure SelectRedPen(var Msg: TMessage);
      virtual cm_First + RedMenu;

      { Virtual method that gets called when user      }
      { selects Pen.Green from the menu bar. Disposes }
      { of the current pen and creates a green pen.    }
    procedure SelectGreenPen(var Msg: TMessage);
      virtual cm_First + GreenMenu;

      { Virtual method that gets called when user      }
      { selects Pen.Blue from the menu bar. Disposes  }
      { of the current pen and creates a blue pen.     }
    procedure SelectBluePen(var Msg: TMessage);
      virtual cm_First + BlueMenu;

      { Virtual method that gets called when user       }
      { selects Pen.Black from the menu bar. Disposes  }
      { of the current pen and creates a black pen.     }
    procedure SelectBlackPen(var Msg: TMessage);
      virtual cm_First + BlackMenu;

      { Method that gets called when the user presses the         }
      { left mouse button.  Selects pen into the display context. }
    procedure WMLButtonDown(var Msg: TMessage);
      virtual WM_LBUTTONDOWN;

      { Method to change the window class of the Scribble Window. }
      {    Allows program to have an Icon associated with the        }
      {    main window                                               }
    procedure GetWindowClass(var AWndClass: TWndClass);virtual;

      { Returns a unique name for this class of window.  Needed }
      {    because this class has a unique icon associated through }
      {    GetWindowClass method                                   }
    function GetClassName: PChar;virtual;

  end;

{*****************************************************************
 * ScribbleWindow constructor.
 *****************************************************************}
constructor ScribbleWindow.Init(aParent: PWindowsObject; aTitle: PChar);
begin
  TWindow.Init(aParent, aTitle);
  ButtonDown := False;
end;

{*****************************************************************
 * procedure ScribbleWindow.WMLButtonDown
 *
 * Process WM_LBUTTONDOWN messages by creating a display context and
 * marking mouse as being pressed.  Also tell Windows to send
 * all mouse messages to window.
 *****************************************************************}
procedure ScribbleWindow.WMLButtonDown(var Msg: TMessage);
begin
  if not ButtonDown then
  begin
    ButtonDown := True;  { Mark mouse button as being     }
             { pressed so when mouse movement }
             { occurs, a line will be drawn.  }

    MoveTo(HandleDC, Msg.LParamLo, { Move drawing point to location }
       Msg.LParamHi);          { where mouse was pressed.       }

  end;
end;

{*****************************************************************
 * procedure ScribbleWindow.WM_Mousemove
 *
 * Process WM_MOUSEMOVE messages by drawing a line if the
 * mouse button is marked as being pressed.
 *****************************************************************}
procedure ScribbleWindow.WMMouseMove(var Msg: TMessage);
begin
  if ButtonDown then  { If the mouse button is currently down        }
    LineTo(HandleDC, Msg.LParamLo, Msg.LParamHi);
              { Draw a line to where the mouse is presently. }
end;

{*****************************************************************
 * procedure ScribbleWindow.WM_LBUTTONUP
 *
 * Process WM_LBUTTONUP messages by allowing other applications
 * to receive mouse messages, releasing the display context, and
 * marking the mouse button as not being pressed.
 *****************************************************************}
procedure ScribbleWindow.WMLButtonUp(var Msg: TMessage);
begin
  if ButtonDown then
  begin
    ReleaseDC(hWindow, handleDC); { Release display context created   }
                          { by WMLButtonDown method.          }
    ButtonDown := False;          { Mark mouse button as not pressed. }
  end;
end;

{*****************************************************************
 * procedure ScribbleWindow.WMRButtonDown
 *
 * Process WM_RBUTTONDOWN messages by erasing the window.
 ***************************************************************** }
procedure ScribbleWindow.WMRButtonDown(var Msg: TMessage);
begin
  UpdateWindow(HWindow);  { Causes WM_PAINT message }
                          { to be sent to window.   }
end;

{*****************************************************************
 * CScribbleWindow constructor.
 *****************************************************************}
constructor CScribbleWindow.Init(aParent: PWindowsObject; ATitle:PChar);
begin
 ScribbleWindow.Init(aParent,ATitle);      { Call parent constructor.  }
 Attr.Menu := LoadMenu(HInstance,          { Attach menu from resource }
         MAKEINTRESOURCE(MenuID)); { file to window.           }

 thePen := CreatePen(PS_SOLID,PenWidth,    {Initialize pen to black.   }
             RGb(0, 0, 0));
end;

{*****************************************************************
 * CScribbleWindow destructor.
 *****************************************************************}
destructor CScribbleWindow.Done;
begin
  TWindow.Done;         { Call standard OWL destructor for a window. }
  DeleteObject(thePen); { Dispose of pen that was created. }
end;

{*****************************************************************
 * procedure CScribbleWindow.SelectRedPen
 *
 * Create a red pen in response to a "Red" selection from
 * Pen menu.
 *****************************************************************}
procedure CScribbleWindow.SelectRedPen(var Msg: TMessage);
begin
  DeleteObject(thePen);                { Dispose of the current pen }
  thePen := CreatePen(PS_SOLID, PenWidth, RGB(255, 0, 0));
end;

{*****************************************************************
 * procedure CScribbleWindow.SelectGreenPen
 *
 * Create a green pen in response to a "Green" selection from
 * Pen menu.
 *****************************************************************}
procedure CScribbleWindow.SelectGreenPen(var Msg: TMessage);
begin
  DeleteObject(thePen);                 { Dispose of the current pen }
  thePen := CreatePen(PS_SOLID, PenWidth, RGB(0, 255, 0));
end;

{*****************************************************************
 * procedure CScribbleWindow.SelectBluePen
 *
 * Create a blue pen in response to a "Blue" selection from
 * Pen menu.
 *****************************************************************}
procedure CScribbleWindow.SelectBluePen(var Msg: TMessage);
begin
  DeleteObject(thePen);                 { Dispose of the current pen }
  thePen := CreatePen(PS_SOLID, PenWidth, RGB(0, 0, 255));
end;

{*****************************************************************
 * procedure CScribbleWindow.SelectBlackPen
 *
 * Create a black pen in response to a "Black" selection from
 * Pen menu.
 *****************************************************************}
procedure CScribbleWindow.SelectBlackPen(var Msg: TMessage);
begin
  DeleteObject(thePen); { Dispose of the current pen }
  thePen := CreatePen(PS_SOLID, PenWidth, RGB(0, 0, 0));
end;

{*****************************************************************
 * procedure CScribbleWindow.WM_LButtonDown
 *
 * Select a colored pen into the display context.
 *****************************************************************}
procedure CScribbleWindow.WMLButtonDown(var Msg: TMessage);
begin
  ScribbleWindow.WMLButtonDown(Msg); { Call ScribbleWindow   }
                                     { WMLButtonDown method. }
  SelectObject(handleDC, thePen);    { Select pen into display context. }
end;

{*****************************************************************
 * procedure CScribbleWindow.GetWindowClass
 *
 * Changes the window icon to a custom icon
 *****************************************************************}
procedure CScribbleWindow.GetWindowClass(var AWndClass: TWndClass);
begin
  ScribbleWindow.GetWindowClass(AWndClass); { Get the ScribbleWindow }
                        { class                  }
  AWndClass.hIcon := LoadIcon(HInstance,MakeIntResource(IconID));
                        { Attach a resource to }
                        {  the window          }
end;

{*****************************************************************
 * function CScribbleWindow.GetClassName: PChar;
 *
 * Returns a unique class name for the Color Scribble window class.
 *****************************************************************}
function CScribbleWindow.GetClassName: PChar;
begin
  GetClassName := 'ColorScribble';
end;

{*****************************************************************
 * procedure CScribbleApplication.InitMainWindow
 *
 * Initialize a Color Scribble window for the main window.
 *****************************************************************}
procedure CScribbleApplication.InitMainWindow;
begin
  MainWindow := New(PCScribbleWindow, Init(nil, 'Scribble With Color!'));
end;


{*** Program begins here ***}

var
  CSApp: CScribbleApplication;

begin
  CSApp.Init('CScribble');
  CSApp.Run;
  CSApp.Done;
end.