home *** CD-ROM | disk | FTP | other *** search
/ Delphi Developer's Kit 1996 / Delphi Developer's Kit 1996.iso / power / rbanding / rband.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-12-22  |  4.2 KB  |  149 lines
  1. unit Rband;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, Menus;
  8.  
  9. type
  10.   TBandStyle = (rbRect,rbEllipse,rbControl);
  11.   TForm1 = class(TForm)
  12.     MainMenu1: TMainMenu;
  13.     Type1: TMenuItem;
  14.     Rectangle1: TMenuItem;
  15.     Ellipse1: TMenuItem;
  16.     Lines: TMenuItem;
  17.     N1: TMenuItem;
  18.     Exit1: TMenuItem;
  19.     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
  20.       Shift: TShiftState; X, Y: Integer);
  21.     procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  22.       Y: Integer);
  23.     procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
  24.       Shift: TShiftState; X, Y: Integer);
  25.     procedure Rectangle1Click(Sender: TObject);
  26.     procedure Ellipse1Click(Sender: TObject);
  27.     procedure LinesClick(Sender: TObject);
  28.     procedure FormShow(Sender: TObject);
  29.     procedure Exit1Click(Sender: TObject);
  30.   private
  31.     GotMouse : boolean;
  32.     Anchor,
  33.     Rover    : TPoint;
  34.     BandStyle : TBandStyle;
  35.     procedure MakeARubber(OnWhat : TCanvas; X, Y : integer);
  36.   public
  37.     { Public declarations }
  38.   end;
  39.  
  40. var
  41.   Form1: TForm1;
  42.  
  43. implementation
  44.  
  45. {$R *.DFM}
  46.  
  47. procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  48.   Shift: TShiftState; X, Y: Integer);
  49. begin
  50.   SetCapture(Handle);  { WIN API function, grabs all mouse actions to this window }
  51.   GotMouse := TRUE;    { need to keep track of who has teh mouse }
  52.   Anchor.X := X; Anchor.Y := Y;  { where we started from }
  53.   Rover := Anchor;               { where we are now}
  54.   Canvas.MoveTo(X,Y);
  55. end;
  56.  
  57. procedure TForm1.MakeARubber(OnWhat : TCanvas; X, Y : integer);
  58.  
  59. begin
  60.   with OnWhat do
  61.   begin
  62.     SetROP2(Handle,R2_NOTXORPEN);  { use to Raster Op codes to make the rubberband }
  63.     Pen.Style := psDot;
  64.     Brush.Style := bsClear;        { don't fill the interior of the shape, please }
  65.     case BandStyle of
  66.       rbRect : begin               { make dull old boxes ... }
  67.                  Rectangle(Anchor.X,Anchor.Y,Rover.X,Rover.Y);
  68.                  Rover.X := X; Rover.Y := Y;
  69.                  Rectangle(Anchor.X,Anchor.Y,Rover.X,Rover.Y);
  70.                end;
  71.    rbEllipse : begin               { make pretty circles...}
  72.                  Ellipse(Anchor.X,Anchor.Y,Rover.X,Rover.Y);
  73.                  Rover.X := X; Rover.Y := Y;
  74.                  Ellipse(Anchor.X,Anchor.Y,Rover.X,Rover.Y);
  75.                end;
  76.    rbControl : begin               { Connect the dots }
  77.                  MoveTo(Anchor.X,Anchor.Y);
  78.                  LineTo(Rover.X,Rover.Y);
  79.                  Rover.X := X; Rover.Y := Y;
  80.                  MoveTo(Anchor.X,Anchor.Y);
  81.                  LineTo(Rover.X,Rover.Y);
  82.                end;
  83.      end;  { CASE }
  84.   end;
  85. end;
  86.  
  87. procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  88.   Y: Integer);
  89. begin
  90.   if GotMouse then MakeARubber(Canvas,X,Y);
  91. end;
  92.  
  93. procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  94.   Shift: TShiftState; X, Y: Integer);
  95. begin
  96.   if GotMouse then
  97.   begin
  98.     MakeARubber(Canvas,X,Y);  { this deletes old shape, makes current one }
  99.     ReleaseCapture; GotMouse := FALSE;
  100.     with Canvas do
  101.     begin
  102.       SetROP2(Handle,R2_COPYPEN);
  103.       Pen.Style := psSolid;
  104.       case BandStyle of
  105.            rbRect : Rectangle(Anchor.X,Anchor.Y,Rover.X,Rover.Y);
  106.         rbEllipse : Ellipse(Anchor.X,Anchor.Y,Rover.X,Rover.Y);
  107.         rbControl : begin MoveTo(Anchor.X,Anchor.Y); LineTo(Rover.X,Rover.Y); end;
  108.       end;  { CASE }
  109.     end;
  110.   end;
  111. end;
  112.  
  113. procedure TForm1.Rectangle1Click(Sender: TObject);
  114. begin
  115.   BandStyle := rbRect;
  116.   Rectangle1.Checked := TRUE;
  117.   Ellipse1.Checked := FALSE;
  118.   Lines.Checked := FALSE;
  119. end;
  120.  
  121. procedure TForm1.Ellipse1Click(Sender: TObject);
  122. begin
  123.   BandStyle := rbEllipse;
  124.   Rectangle1.Checked := FALSE;
  125.   Ellipse1.Checked := TRUE;
  126.   Lines.Checked := FALSE;
  127. end;
  128.  
  129. procedure TForm1.LinesClick(Sender: TObject);
  130. begin
  131.   BandStyle := rbControl;
  132.   Rectangle1.Checked := FALSE;
  133.   Ellipse1.Checked := FALSE;
  134.   Lines.Checked := TRUE;
  135. end;
  136.  
  137. procedure TForm1.FormShow(Sender: TObject);
  138. begin
  139.   Rectangle1Click(Sender);
  140. end;
  141.  
  142. procedure TForm1.Exit1Click(Sender: TObject);
  143. begin
  144.   if GotMouse then ReleaseCapture;  { be polite, make sure }
  145.   Close;
  146. end;
  147.  
  148. end.
  149.