本例效果图:
代码文件:
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure FormPaint(Sender: TObject); procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private procedure RectToPoints; end; var Form1: TForm1; implementation {$R *.dfm} uses GDIPOBJ, GDIPAPI; var img: TGPImage; flag: Integer = -1; ClickImg: Boolean; rt: TRect; pts: array[0..7] of TPoint; x1,y1: Integer; {从矩形中获取八个点, 因要反复使用, 故提取为一个独立的过程} procedure TForm1.RectToPoints; begin pts[0] := rt.TopLeft; pts[1] := Point(rt.Left, rt.Top + (rt.Bottom - rt.Top) div 2); pts[2] := Point(rt.Left, rt.Bottom); pts[3] := Point(rt.Left + (rt.Right - rt.Left) div 2, rt.Bottom);; pts[4] := rt.BottomRight; pts[5] := Point(rt.Right, rt.Top + (rt.Bottom - rt.Top) div 2);; pts[6] := Point(rt.Right, rt.Top);; pts[7] := Point(rt.Left + (rt.Right - rt.Left) div 2, rt.Top); end; procedure TForm1.FormCreate(Sender: TObject); const ImgPath = 'c:\temp\test.png'; var w,h: Integer; begin if not FileExists(ImgPath) then Exit; img := TGPImage.Create(ImgPath); w := img.GetWidth; h := img.GetHeight; rt.Left := (ClientWidth - w) div 2; rt.Top := (ClientHeight - h) div 2; rt.Right := rt.Left + w; rt.Bottom := rt.Top + h; RectToPoints; DoubleBuffered := True; end; procedure TForm1.FormDestroy(Sender: TObject); begin img.Free; end; procedure TForm1.FormPaint(Sender: TObject); var g: TGPGraphics; p: TGPPen; i: Integer; begin g := TGPGraphics.Create(Canvas.Handle); p := TGPPen.Create(aclRed); g.DrawImage(img, MakeRect(rt)); if ClickImg then for i := 0 to Length(pts) - 1 do g.DrawRectangle(p, MakeRect(pts[i].X - 3, pts[i].Y - 3, 6, 6)); p.Free; g.Free; end; procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var i: Integer; begin flag := -1; for i := 0 to Length(pts) - 1 do if PtInRect(Bounds(pts[i].X - 3, pts[i].Y - 3, 6, 6), Point(X, Y)) then begin flag := i; Break; end; if flag = -1 then begin ClickImg := PtInRect(rt, Point(X,Y)); Repaint; end else begin x1 := X; y1 := Y; end; end; procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if flag = -1 then Exit; case flag of 0: begin Inc(rt.Left, X-x1); Inc(rt.Top, Y-y1) end; 1: begin Inc(rt.Left, X-x1) end; 2: begin Inc(rt.Left, X-x1); Inc(rt.Bottom, Y-y1) end; 3: begin Inc(rt.Bottom, Y-y1) end; 4: begin Inc(rt.Right, X-x1); Inc(rt.Bottom, Y-y1) end; 5: begin Inc(rt.Right, X-x1) end; 6: begin Inc(rt.Right, X-x1); Inc(rt.Top, Y-y1) end; 7: begin Inc(rt.Top, Y-y1) end; end; x1 := X; y1 := Y; RectToPoints; Repaint; end; procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin flag := -1; end; end.
窗体文件:
object Form1: TForm1 Left = 0 Top = 0 Caption = 'Form1' ClientHeight = 246 ClientWidth = 346 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'Tahoma' Font.Style = [] OldCreateOrder = False Position = poDesktopCenter OnCreate = FormCreate OnDestroy = FormDestroy onm ouseDown = FormMouseDown onm ouseMove = FormMouseMove onm ouseUp = FormMouseUp OnPaint = FormPaint PixelsPerInch = 96 TextHeight = 13 end