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;
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;