各位大侠,如何在Image对象已装载的图片上画矩形?(50分)

  • 主题发起人 主题发起人 johnnywww
  • 开始时间 开始时间
J

johnnywww

Unregistered / Unconfirmed
GUEST, unregistred user!
现有Image对象ImgPic1,AutoSize:=false, Strech := true,width = 305, height := 400,装载一个jpg图片,大小为1024*768

procedure TFrmMain.ImgPic1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
Rect: TRect;
begin
if shift <> [ssLeft] then
Exit;
Rect.TopLeft := PtSource;
Rect.BottomRight := PtOld;
if PtSource.X >= 0 Then
// 如果以前画有矩形框,需要清除它
DrawRect(Rect, ImgPic1);
PtOld.X := X;
PtOld.Y := Y;
// 保存鼠标按下时坐标,用于鼠标移动时画矩形框作原点
PtSource := PtOld;
// 鼠标左键被按下的标志
BoolPressed := True;
end;

procedure TFrmMain.ImgPic1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
SourceRect, DestRect: TRect;
begin
// 如果鼠标左键没有按下,那么不画矩形框
if not BoolPressed then
Exit;
SourceRect.TopLeft := PtSource;
SourceRect.BottomRight := PtOld;
PtOld.X := X;
PtOld.Y := Y;
DestRect.TopLeft := PtSource;
DestRect.BottomRight := PtOld;
// 擦除以前画的矩形框
DrawRect(SourceRect, ImgPic1);
// 重新画新的矩形框
DrawRect(DestRect, ImgPic1);
end;

procedure TFrmMain.ImgPic1MouseUp(Sender: TObject; Button: TMouseButton; Shift:
TShiftState; X, Y: Integer);
var
Rect: TRect;
begin
BoolPressed := false;
end;

{********************************************************************
Function Name: DrawRect
Purpose: 在Image对象的Bitmap的Canvas对象中以异或的方式画矩形框
Param Value:
Rect 矩形框数据
ImgDest 待画的Image对象
Return Value: 无
********************************************************************}
procedure TFrmMain.DrawRect(Rect: TRect; ImgDest: TImage);
var
Pen: TPen;
OldPen: TPen;
PicCanvas: TCanvas;
begin
// 判断Image中是否存在装载的图片,如果没有不需画矩形框
if ImgDest.Picture.Bitmap = nil then
Exit;
// 创建新的Pen对象,当鼠标移动时,画矩形框
Pen := TPen.Create;
try
Pen.Color := clYellow;
// 设置笔的模式为异或方式
Pen.Mode := pmNotXor;
PicCanvas := ImgDest.Picture.Bitmap.Canvas;
// 保存Bitmap的Canvas对象中的Pen对象
OldPen := PicCanvas.Pen;
try
// 用新的Pen对象取代,可以以异或方式画矩形框
PicCanvas.Pen := Pen;
// 设置以虚线方式画矩形
PicCanvas.Pen.Style := psDash;
PicCanvas.Rectangle(Rect);
ImgPic1.Refresh;
finally
PicCanvas.Pen := OldPen;
end;
finally
FreeAndNil(Pen);
end;
end;
 
你的方法有什么问题?
DrawRect中ImgPic1.Refresh是什么意思?
 
1.
现在图片上没有显示出矩形框
2. 我以为用refresh重新刷新会显示,没有这句也画不出矩形框
 
var
BoolPressed:boolean;
pts:array[0..1] of TPoint;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
pts[0]:= Point(X, Y);
pts[1]:= Point(X, Y);
BoolPressed:=true;
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if BoolPressed then
with Image1 do
begin
Canvas.Pen.Style:= psDot;
Canvas.Pen.Color:= clGray;
Canvas.Pen.Mode := pmNotXor;
Canvas.Rectangle(pts[0].X, pts[0].Y, pts[1].X, pts[1].Y);
Canvas.Rectangle(pts[0].X, pts[0].Y, X, Y);
pts[1] := Point(X, Y);
Canvas.Pen.Mode := pmCopy;
end;

end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
BoolPressed:=false;
end;
 
yostgxf请你装载个大的jpeg图片测试下,如果Image没有装载jpeg图片,代码就可以,装载后不行
 
请使用类似这样的代码将Picture转换为TBitmap:
if not (image1.Picture.Graphic is tbitmap) then
begin
bmp := tbitmap.Create;
try
bmp.Width := image1.Picture.Graphic.Width;
bmp.Height := image1.Picture.Graphic.Height;
bmp.Canvas.Draw(0, 0, image1.picture.graphic);
image1.Picture.Assign(bmp);
finally
bmp.Free;
end;
end;
 
多人接受答案了。
 
后退
顶部