实现索套功能。 (200分)

// Extended from "How to Draw Marching Ants"
// Robert Vivrette, www.undu.co/DN960901/00000008.htm
//
// efg, May 1999.
// Modified Nov 1999.

unit ScreenMarchingAnts;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, jpeg;

type
  TFormMarchingAnts = class(TForm)
    Timer1: TTimer;
    Image1: TImage;
    Image3: TImage;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);

    procedure ImageMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ImageMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ImageMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    X1,Y1,X2,Y2 : Integer;

    procedure RemoveTheRect;
    procedure DrawTheRect;
  public
    { Public declarations }
  end;

var
  FormMarchingAnts: TFormMarchingAnts;
  Counter : Byte;
  CounterStart : Byte;
  Looper : LongInt;

implementation
{$R *.DFM}


PROCEDURE RestrictCursorToDrawingArea (CONST Image: TImage);
  VAR
    CursorClipArea: TRect;
BEGIN
  CursorClipArea := Bounds(Image.ClientOrigin.X, Image.ClientOrigin.Y,
                                          Image.Width, Image.Height);
  Windows.ClipCursor(@CursorClipArea)
END {RestrictCursorToDrawingArea};


PROCEDURE RemoveCursorRestrictions;
BEGIN
  Windows.ClipCursor(NIL)
END {RemoveCursorRestrictions};


procedure MovingDots(X,Y: Integer; TheCanvas: TCanvas); stdcall;
begin
  Inc(Looper);
{$R-}
  Counter := Counter shl 1;              // Shift the bit left one
{$R+}
  if   Counter = 0
  then Counter := 1;          // If it shifts off left, reset it
  if   (Counter and 224) > 0  // Are any of the left 3 bits set?
  then TheCanvas.Pixels[X,Y] := clWhite   // Erase the pixel
  else TheCanvas.Pixels[X,Y] := clBlack;  // Draw the pixel
end;


function NormalizeRect(R: TRect): TRect;
begin
  // This routine normalizes a rectangle. It makes sure that the Left,Top
  // coords are always above and to the left of the Bottom,Right coords.
  with R do
  BEGIN
    if   Left > Right
    then
      if   Top > Bottom
      then Result := Rect(Right,Bottom,Left,Top)
      else Result := Rect(Right,Top,Left,Bottom)
    else
      if   Top > Bottom
      then Result := Rect(Left,Bottom,Right,Top)
      else Result := Rect(Left,Top,Right,Bottom);
  END
end;


procedure TFormMarchingAnts.FormCreate(Sender: TObject);
begin
  X1 := 0;
  Y1 := 0;
  X2 := 0;
  Y2 := 0;
  Canvas.Pen.Color := Color;
  Canvas.Brush.Color := Color;
  CounterStart := 128;
  Timer1.Interval := 100;
  Timer1.Enabled := True;
  Looper := 0;
  self.DoubleBuffered:=true;
  FormMarchingAnts.ControlStyle := FormMarchingAnts.ControlStyle  + [csOpaque];
end;


procedure TFormMarchingAnts.RemoveTheRect;
var
  R : TRect;
begin
  R := NormalizeRect(Rect(X1,Y1,X2,Y2));  // Rectangle might be flipped
  InflateRect(R,1,1);                     // Make the rectangle 1 pixel larger
  InvalidateRect(Handle,@R,True);         // Mark the area as invalid
  InflateRect(R,-2,-2);                   // Now shrink the rectangle 2 pixels
  ValidateRect(Handle,@R);                // And validate this new rectangle.
  // This leaves a 2 pixel band all the way around
  // the rectangle that will be erased & redrawn
  UpdateWindow(Handle);
end;

procedure TFormMarchingAnts.DrawTheRect;
begin
  // Determines starting pixel color of Rect
  Counter := CounterStart;
  // Use LineDDA to draw each of the 4 edges of the rectangle
  LineDDA(X1,Y1,X2,Y1,@MovingDots,LongInt(Canvas));
  LineDDA(X2,Y1,X2,Y2,@MovingDots,LongInt(Canvas));
  LineDDA(X2,Y2,X1,Y2,@MovingDots,LongInt(Canvas));
  LineDDA(X1,Y2,X1,Y1,@MovingDots,LongInt(Canvas));
end;


procedure TFormMarchingAnts.Timer1Timer(Sender: TObject);
begin
  CounterStart := CounterStart shr 2;    // Shl 1 will move rect slower
  if   CounterStart = 0                  // If bit is lost, reset it
  then CounterStart := 128;
  DrawTheRect                           // Draw the rectangle
end;


// ===================================================================
// Use "quick and dirty" fix to get ants to march on top of an image

procedure TFormMarchingAnts.ImageMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  X := X + (Sender AS TImage).Left;
  Y := Y + (Sender AS TImage).Top;

  RemoveTheRect;                               // Erase any existing rectangle
  X1 := X;
  Y1 := Y;

  X2 := X;
  Y2 := Y;

  // Force mouse movement to stay within TImage
  RestrictCursorToDrawingArea( (Sender AS TImage) )
end;



procedure TFormMarchingAnts.ImageMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if ssLeft in Shift
  then  begin
    X := X + (Sender AS TImage).Left;
    Y := Y + (Sender AS TImage).top;

    RemoveTheRect;         // Erase any existing rectangle
    X2 := X; Y2 := Y;      // Save the new corner where the mouse is
    DrawTheRect;           // Draw the Rect now... don't wait for the timer!
  end;
end;


procedure TFormMarchingAnts.ImageMouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  RemoveCursorRestrictions
end;

end.