如何在图象上用鼠标拉框？

Question

哪个有在图象上用鼠标拉框的程序啊？能不能给我发一份？（目的是要对拉框的区域进行图象处理和识别）。

Answer 1

是想象在资源管理器里画一个选择框吗？放一个TShape，把它设成空心的，边框为虚线的，根据鼠标的抬起按下移动控制它的隐藏和位置就行了

Answer 2

dephi自己的demo中有画图的例子,可以参考.

Answer 3

正好几年前写过类似程序，用的就是Shape，这是比较容易实现的方法，找出代码供参考//以下三段代码实现拉框procedure Tmain.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if nowname='' then
    exit;
  //右键取消图片裁剪
  if button<>mbLeft then
    begin
      shape1.Tag:=0;
      shape1.Visible:=false;
      shape1.Width:=0;
      shape1.Height:=0;
      shape1.Left:=0;
      shape1.Top:=0;
      StatusBar1.Panels[0].Text := '';
      StatusBar1.Panels[1].Text := '';
      StatusBar1.Panels[2].Text := '';
      StatusBar1.Panels[3].Text := '';
      exit;
    end;
  //左键开始图片裁剪
  //image1.tag=1为在裁剪状态中
  if shape1.Tag=0 then
    begin
      shape1.Tag:=1;
      image1.Tag:=1;
      x0:=image1.Left;
      y0:=image1.top;
      StartX := X;
      StartY := Y;
      shape1.Left:=X;
      shape1.Top:=Y;
      shape1.Width:=1;
      shape1.Height:=1;
      shape1.Visible:=true;
    end;
end;procedure Tmain.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  x1,y1,x2,y2:integer;
begin
  if shape1.Tag=0 then
    image1.Hint:='点击左键并移动可截取图像'
  else
    image1.Hint:='单击右键取消截取图像';
  if image1.Tag=0 then
    exit;
  if x>image1.Width then
    x:=image1.width;
  if y>image1.height then
    y:=image1.height;
  if x<0 then
    x:=0;
  if y<0 then
    y:=0;
  if not shape1.Visible then
    shape1.Visible:=true;
  if (x>startx) and (y>starty) then
    begin
      x1:=startx;
      y1:=starty;
      x2:=x;
      y2:=y;
    end
  else
  if (x>startx) and (y<starty) then
    begin
      x1:=startx;
      y1:=y;
      x2:=x;
      y2:=starty;
    end
  else
  if (x<startx) and (y<starty) then
    begin
      x1:=x;
      y1:=y;
      x2:=startx;
      y2:=starty;
    end
  else
  if (x<startx) and (y>starty) then
    begin
      x1:=startx;
      y1:=y;
      x2:=x;
      y2:=starty;
    end
  else
    begin
      shape1.Visible:=false;
    end;
  if shape1.Visible then
    begin
      shape1.top:=y1+y0;
      shape1.Left:=x1+x0;
      shape1.Width:=x2-x1;
      shape1.Height:=y2-y1;
      StatusBar1.Panels[0].Text := '上边距: ' + IntToStr(y1);
      StatusBar1.Panels[2].Text := '高度: ' + IntToStr(y2-y1);
      StatusBar1.Panels[1].Text := '左边距: ' + IntToStr(x1);
      StatusBar1.Panels[3].Text := '宽度: ' + IntToStr(x2-x1);
    end;
end;procedure Tmain.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  image1.Tag:=0;
end;//以下代码取Shape框住的图像procedure Tmain.Shape1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  rect1:Trect;
  ltop,lleft,lright,lbottom:integer;
  bitmap:Tbitmap;
begin
  StatusBar1.Panels[0].Text := '';
  StatusBar1.Panels[1].Text := '';
  StatusBar1.Panels[2].Text := '';
  StatusBar1.Panels[3].Text := '';
  if button<>mbLeft then
    begin
      shape1.Tag:=0;
      shape1.Visible:=false;
      shape1.Width:=0;
      shape1.Height:=0;
      shape1.Left:=0;
      shape1.Top:=0;
      exit;
    end;
  if button=mbLeft then
    begin
      if nowname='' then
        exit;
      if shape1.Tag=1 then
        begin
          image2.Width:=shape1.width;
          image2.Height:=shape1.height;
          lleft:=shape1.left-x0;
          ltop:=shape1.top-y0;
          lright:=lleft+shape1.width;
          lbottom:=ltop+shape1.height;
          rect1:=Rect(lleft,ltop,lright,lbottom);          image2.Canvas.CopyMode:=cmSrcCopy;
          image2.Canvas.CopyRect(image2.ClientRect,image1.Canvas,rect1);          bitmap:=Tbitmap.create;
          bitmap.Width:=shape1.width;
          bitmap.Height:=shape1.height;
          bitmap.Canvas.CopyMode:=cmSrcCopy;
          bitmap.Canvas.CopyRect(bitmap.Canvas.ClipRect,image2.Canvas,image2.ClientRect);          if FileExists(runpath+'\aa.bmp') then
            try
              DeleteFile(runpath+'\aa.bmp')
            except
            end;          bitmap.SaveToFile(runpath+'\aa.bmp');
          FileSetAttr(runpath+'\aa.bmp',faHidden);          bitmap.Free;          image7.Width:=shape1.width;
          image7.Height:=shape1.height;
          image7.Picture.Bitmap.LoadFromFile(runpath+'\aa.bmp');          psize;          image1.Width:=shape1.width;
          image1.Height:=shape1.height;
          image1.Canvas.CopyMode:=cmSrcCopy;
          image1.Canvas.CopyRect(image1.ClientRect,image2.Canvas,image2.ClientRect);
          shape1.Tag:=0;
          shape1.Visible:=false;
          shape1.Width:=0;
          shape1.Height:=0;
          shape1.Left:=0;
          shape1.Top:=0;
          trackbar1.Position:=100;
          speedbutton5.Tag:=1;
        end;
    end;
end;

Answer 4

类似于Delphi在设计期选中组件的时候，用鼠标托拽出来的框吗？如果是，采用Canvas的DrawFocusRect（）函数吧。

Answer 5

用到DrawFocusRect
例如下private
    { Private declarations }
    OldX,
    OldY,
    OldLeft,
    OldTop   : Integer;
    ScreenDC : HDC;
    MoveRect : TRect;
    Moving   : Boolean;
  public
    { Public declarations }
  end;var
  Form1: TForm1;implementation{$R *.DFM}procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    SetCapture(Panel1.Handle);
    ScreenDC := GetDC(0);
    OldX := X;
    OldY := Y;
    OldLeft := X;
    OldTop := Y;
    MoveRect := BoundsRect;
    DrawFocusRect(ScreenDC,MoveRect);
    Moving := True;
  end;
end;procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if Moving then begin
    DrawFocusRect(ScreenDC,MoveRect);
    OldX := X;
    OldY := Y;
    MoveRect := Rect(Left+OldX-OldLeft,Top+OldY-OldTop,
                     Left+Width+OldX-OldLeft,Top+Height+OldY-OldTop);
    DrawFocusRect(ScreenDC,MoveRect);
  end;
end;procedure TForm1.Panel1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    ReleaseCapture;
    DrawFocusRect(ScreenDC,MoveRect);
    Left := Left+X-OldLeft;
    Top := Top+Y-OldTop;
    ReleaseDC(0,ScreenDC);
    Moving := False;
  end;
end;