怎样在程序中实现拖动圆形图像，要求实现图像拖动的实时效果，也就是运动轨迹

Question

怎样在程序中实现拖动圆形图像，要求实现图像拖动的实时效果，也就是运动轨迹

Answer 1

当然可以,但要求图象跟随鼠标移动，就像CAD和大部分的图像软件一样

Answer 2

别人做的例子
放置一个Image(TImage)，其Align为alClient，放ClipImg(TImage)，
其Align先设为alClient，然后改回alNone。
设计一下菜单有CutCmd, CopyCmd, PasteCmd
写代码如下：
  ...
  private
  ...
    StartX,StartY,EndX,EndY:Integer;
    MouseDown:Boolean;
  ...
procedure TMainFrm.ImageMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin  //开始选择
  if not MouseDown then begin
    if ClipImg.Visible then RestoreImage;
    MouseDown:=True;
    StartX:=X;
    StartY:=Y;
    EndX:=X;
    EndY:=Y;
    DrawFrame;
  end;
end;procedure TMainFrm.ImageMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin  //选择过程
  if MouseDown then begin
    DrawFrame;
    EndX:=X;
    EndY:=Y;
    DrawFrame;
  end;
end;procedure TMainFrm.ImageMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin   //结束选择
  if MouseDown then begin
    MouseDown:=False;
    if (StartX=EndX) and (StartY=EndY) then begin
      DrawFrame;
      ClipImg.Visible:=False;
    end else begin
      with ClipImg,Canvas do begin
        Width:=EndX-StartX;
        Height:=EndY-StartY;
        CopyRect(Rect(0,0,Width,Height),
            Image.Canvas,
            Rect(StartX,StartY,EndX,EndY));
        Visible:=True;
        Left:=StartX;
        Top:=StartY;
      end;
      with Image.Canvas do begin
        Brush.Color:=clWhite;
        Brush.Style:=bsSolid;
        FillRect(Rect(StartX,StartY,EndX,EndY));
      end;
    end;
  end;
end;procedure TMainFrm.FormCreate(Sender: TObject);
var
  Bmp:TBitmap;
begin
  ClipImg.Visible:=False;
  with Image,Canvas do begin
    Brush.Color:=clWhite;
    FillRect(ClientRect);
  end;
end;procedure TMainFrm.DrawFrame;
begin  //在Image上画一个选择框
  with Image.Canvas do begin
    Brush.Style:=bsClear;
    Pen.Color:=clAqua;
    Pen.Mode:=pmXor;
    Rectangle(StartX,StartY,EndX,EndY);
  end;
end;procedure TMainFrm.CopyCmdClick(Sender: TObject);
var
  Bmp:TBitmap;
begin   //复制图片
  Bmp:=TBitmap.Create;
  try
    DrawClipFrame;
    Bmp.Width:=ClipImg.Width;
    Bmp.Height:=ClipImg.Height;
    Bmp.Canvas.Draw(0,0,ClipImg.Picture.Bitmap);
    ClipBoard.Assign(Bmp);
    DrawClipFrame;
  finally
    Bmp.Free;
  end;
end;procedure TMainFrm.CutCmdClick(Sender: TObject);
begin  //剪切图片
  CopyCmdClick(Sender);
  ClipImg.Visible:=False;
end;procedure TMainFrm.PasteCmdClick(Sender: TObject);
var
  Bmp:TBitmap;
begin  //粘贴图片
  if ClipBoard.HasFormat(CF_BITMAP) then begin
    if ClipImg.Visible then RestoreImage;
    Bmp:=TBitmap.Create;
    try
      Bmp.Assign(ClipBoard);
      with ClipImg do begin
        Width:=Bmp.Width;
        Height:=Bmp.Height;
        Canvas.Draw(0,0,Bmp);
        Visible:=True;
        Left:=0;
        Top:=0;
      end;
      DrawClipFrame;
    finally
      Bmp.Free;
    end;        
  end;
end;procedure TMainFrm.DrawClipFrame;
begin  //在ClipImg上画一个选择框
  with ClipImg,Canvas do begin
    Brush.Style:=bsClear;
    Pen.Color:=clAqua;
    Pen.Mode:=pmXor;
    Rectangle(ClientRect);
  end;
end;procedure TMainFrm.RestoreImage;
begin   //恢复图像
  DrawClipFrame;
  with ClipImg do
    Image.Canvas.CopyRect(
        Rect(Left,Top,Left+Width,Top+Height),
        ClipImg.Canvas,
        Rect(0,0,Width,Height));
end;procedure TMainFrm.ClipImgMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin  //开始移动选择部分
  if not MouseDown then begin
    MouseDown:=True;
    StartX:=X;
    StartY:=Y;
  end;
end;procedure TMainFrm.ClipImgMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin  //移动选择部分过程
  if MouseDown then begin
    ClipImg.Left:=ClipImg.Left+X-StartX;
    ClipImg.Top:=ClipImg.Top+Y-StartY;
  end;
end;procedure TMainFrm.ClipImgMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin  //结束移动选择部分
  if MouseDown then MouseDown:=False;
end;
...

Answer 3

I have a sample, please mailto: [email protected]