FormShow()->FormMouseDown->FormMouseMove->FormMouseUp
初始化 鼠标按下，起点 移动鼠标 鼠标弹起 ，终点
网上下的例子：
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
const
Penwidth = 1;//画笔的粗细
Len = 20;//箭头线的长度
{说明：这两个常量应该一起变化，具体值由效果来定。
当Penwidth很小时，显示的效果不是太好}
type
TForm1 = class(TForm)
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormShow(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
xs, ys: integer;//画线开始处的坐标
xt, yt: integer;//记录鼠标前一时刻的坐标
xl, yl: integer;//记录第一条箭头线的端点坐标
xr, yr: integer;//记录第二条箭头线的端点坐标
B: boolean;//判断是否已经开始画线
implementation
{$R *.dfm}
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
{画线结尾时，将线重新填充一遍，以免有部分空白}
if not ((x = xs) and (y = ys)) then
begin
Form1.Canvas.Pen.Mode := pmCopy;
Form1.Canvas.Pen.Color := clRed;
Form1.Canvas.Pen.Width := PenWidth;
Form1.Canvas.MoveTo(xs, ys);
Form1.Canvas.LineTo(x, y);
Form1.Canvas.MoveTo(x, y);
Form1.Canvas.LineTo(xl, yl);
Form1.Canvas.MoveTo(x, y);
Form1.Canvas.LineTo(xr, yr);
end;
B := False;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
xs := x;
ys := y;
xt := x;
yt := y;
xl := -1;
yl := -1;
xr := -1;
yr := -1;
B := True;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if B then
begin
Form1.Canvas.Pen.Mode := pmNotXor;
Form1.Canvas.Pen.Color := clRed;
Form1.Canvas.Pen.Width := PenWidth;
//绘旧线
Form1.Canvas.MoveTo(xs, ys);
Form1.Canvas.LineTo(xt, yt);
//绘新线
Form1.Canvas.MoveTo(xs, ys);
Form1.Canvas.LineTo(x, y);
if xl <> -1 then
begin
Form1.Canvas.MoveTo(xt, yt);
Form1.Canvas.LineTo(xl, yl);
Form1.Canvas.MoveTo(xt, yt);
Form1.Canvas.LineTo(xr, yr);
Form1.Canvas.MoveTo(xl, yl);
Form1.Canvas.LineTo(xr, yr);
end;
//记录下原坐标
xt := x;
yt := y;
if x > xs then
begin
xl := trunc(x - Len * Cos(ArcTan((y - ys) / (x - xs)) - Pi / 6));
yl := trunc(y - Len * Sin(ArcTan((y - ys) / (x - xs)) - Pi / 6));
xr := trunc(x - Len * Cos(ArcTan((y - ys) / (x - xs)) + Pi / 6));
yr := trunc(y - Len * Sin(ArcTan((y - ys) / (x - xs)) + Pi / 6));
end
else
if x < xs then
begin
xl := trunc(x + Len * Cos(ArcTan((y - ys) / (x - xs)) - Pi / 6));
yl := trunc(y + Len * Sin(ArcTan((y - ys) / (x - xs)) - Pi / 6));
xr := trunc(x + Len * Cos(ArcTan((y - ys) / (x - xs)) + Pi / 6));
yr := trunc(y + Len * Sin(ArcTan((y - ys) / (x - xs)) + Pi / 6));
end
else
if y < ys then
begin
xl := trunc(x - Len * Sin(Pi / 6));
yl := trunc(y + Len * Cos(Pi / 6));
xr := trunc(x + Len * Sin(Pi / 6));
yr := trunc(y + Len * Cos(Pi / 6));
end
else
if y > ys then
begin
xl := trunc(x - Len * Sin(Pi / 6));
yl := trunc(y - Len * Cos(Pi / 6));
xr := trunc(x + Len * Sin(Pi / 6));
yr := trunc(y - Len * Cos(Pi / 6));
end
else
begin
xl := -1;
yl := -1;
xr := -1;
yr := -1;
end;
if xl <> -1 then
begin
Form1.Canvas.MoveTo(x, y);
Form1.Canvas.LineTo(xl, yl);
Form1.Canvas.MoveTo(x, y);
Form1.Canvas.LineTo(xr, yr);
Form1.Canvas.MoveTo(xl, yl);
Form1.Canvas.LineTo(xr, yr);
end;
end;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Form1.Color := clWhite;
Form1.Caption := '画带箭头的直线 ';
Form1.WindowState := wsMaximized;
B := False;
xt := -1;
yt := -1;
xl := -1;
yl := -1;
xr := -1;
yr := -1;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
// Form1.BorderIcons := [biSystemMenu];
end;
end.
我的代码改进版：
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
const
Penwidth = 1;//画笔的粗细
Len = 15;//箭头线的长度
{说明：这两个常量应该一起变化，具体值由效果来定。
当Penwidth很小时，显示的效果不是太好}
type
TForm1 = class(TForm)
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
xs, ys: integer;//画线开始处的坐标 start
xl, yl: integer;//记录第一条箭头线的端点坐标 left 三角形左边顶点
xr, yr: integer;//记录第二条箭头线的端点坐标 rift
xt, yt: integer;//记录鼠标前一时刻的坐标 termoei
B: boolean;//判断是否已经开始画线
implementation
{$R *.dfm}
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
B := False; //鼠标弹起，结束 画线
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
xs := x;
ys := y;
xt := x; yt := y;
xl := -1; yl := -1;
xr := -1;
yr := -1;
B := True; //鼠标按下 开始 画线
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
m ,n: array[0..2] of TPoint;
begin
if B then
begin
Form1.Canvas.Pen.Mode := pmNotXor; //pmNotXor 将旧三角形用背景色 划线，即清除旧的
Form1.Canvas.Pen.Color := clRed;
Form1.Canvas.Pen.Width := PenWidth;
if xl <> -1 then //pmNotXor 将旧三角形用背景色 划线，即
begin
Form1.Canvas.Brush.Color:=clRed; //清除 三角形
m[0]:= Point(xt, yt);
m[1]:= Point(xl, yl);
m[2]:= Point(xr, yr);
Form1.Canvas.Polygon( m);
//------------------------------------
n[0]:= Point(xs, ys);
n[1]:= Point(xl, yl);
n[2]:= Point(xr, yr);
Form1.Canvas.Polygon( n);
end;
//记录下原坐标
xt := x; yt := y;
if x > xs then
begin
xl := trunc(x - Len * Cos(ArcTan((y - ys) / (x - xs)) - Pi / 6));
yl := trunc(y - Len * Sin(ArcTan((y - ys) / (x - xs)) - Pi / 6));
xr := trunc(x - Len * Cos(ArcTan((y - ys) / (x - xs)) + Pi / 6));
yr := trunc(y - Len * Sin(ArcTan((y - ys) / (x - xs)) + Pi / 6));
end
else
if x < xs then
begin
xl := trunc(x + Len * Cos(ArcTan((y - ys) / (x - xs)) - Pi / 6));
yl := trunc(y + Len * Sin(ArcTan((y - ys) / (x - xs)) - Pi / 6));
xr := trunc(x + Len * Cos(ArcTan((y - ys) / (x - xs)) + Pi / 6));
yr := trunc(y + Len * Sin(ArcTan((y - ys) / (x - xs)) + Pi / 6));
end
else
if y < ys then
begin
xl := trunc(x - Len * Sin(Pi / 6));
yl := trunc(y + Len * Cos(Pi / 6));
xr := trunc(x + Len * Sin(Pi / 6));
yr := trunc(y + Len * Cos(Pi / 6));
end
else
if y > ys then
begin
xl := trunc(x - Len * Sin(Pi / 6));
yl := trunc(y - Len * Cos(Pi / 6));
xr := trunc(x + Len * Sin(Pi / 6));
yr := trunc(y - Len * Cos(Pi / 6));
end
else
begin
xl := -1;
yl := -1;
xr := -1;
yr := -1;
end;
if xl <> -1 then
begin
Form1.Canvas.Brush.Color:=clRed; //填充三角形
m[0]:= Point(x, y);
m[1]:= Point(xl, yl);
m[2]:= Point(xr, yr);
Form1.Canvas.Polygon( m);
//------------------------------------
n[0]:= Point(xs, ys);
n[1]:= Point(xl, yl);
n[2]:= Point(xr, yr);
Form1.Canvas.Polygon( n);
end;
end;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Form1.Color := clWhite;
Form1.Caption := '画带箭头的直线 ';
Form1.WindowState := wsMaximized;
B := False;
xt := -1; yt := -1;
xl := -1; yl := -1;
xr := -1;
yr := -1;
end;
end.
使用GDI+，更进一步了
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
const
Penwidth = 1;//画笔的粗细
Len = 15;//箭头线的长度
{说明：这两个常量应该一起变化，具体值由效果来定。
当Penwidth很小时，显示的效果不是太好}
type
TForm1 = class(TForm)
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormShow(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
xs, ys: integer;//画线开始处的坐标 start
xl, yl: integer;//记录第一条箭头线的端点坐标 left 三角形左边顶点
xr, yr: integer;//记录第二条箭头线的端点坐标 rift
xt, yt: integer;//记录鼠标前一时刻的坐标 termoei
B: boolean;//判断是否已经开始画线
implementation {$R *.dfm}
uses
GDIPAPI,GDIPOBJ; //包含这两个GDI+单元
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
B := False; //鼠标弹起，结束 画线
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
xs := x;
ys := y;
xt := x; yt := y;
xl := -1; yl := -1;
xr := -1;
yr := -1;
B := True; //鼠标按下 开始 画线
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
m : array[1..4] of TPoint;
var
g: TGPGraphics;
p: TGPPen;
sb: TGPSolidBrush;
pts: array[1..4] of TGPPoint;
begin
if B then
begin
// Form1.Canvas.Pen.Mode := pmNotXor; //pmNotXor 将旧三角形用背景色 划线，即清除旧的
// Form1.Canvas.Pen.Color := clRed;
// Form1.Canvas.Pen.Width := PenWidth;
if xl <> -1 then //pmNotXor 将旧三角形用背景色 划线，即
begin
//清除 三角形
// Form1.Canvas.Brush.Color:=clRed;
// m[1]:= Point(xt, yt);
// m[2]:= Point(xl, yl);
// m[3]:= Point(xs, ys);
// m[4]:= Point(xr, yr);
// Form1.Canvas.Polygon( m);
g := TGPGraphics.Create(Canvas.Handle);
g.SetSmoothingMode( SmoothingModeAntiAlias);{指定平滑（抗锯齿）}
p := TGPPen.Create(MakeColor(255,255,255),1);
sb := TGPSolidBrush.Create(MakeColor(255,255,255));
pts[1].X := xt;pts[1].Y := yt;
pts[2].X := xl;pts[2].Y := yl;
pts[3].X := xs; pts[3].Y := ys;
pts[4].X := xr; pts[4].Y := yr;
g.FillPolygon(sb, PGPPoint(@pts), 4); {第三个参数是顶点数}
g.DrawPolygon(p, PGPPoint(@pts), Length(pts));{第二个参数是指针类型, 需亚转换}
p.Free;
sb.Free;
g.Free;
end;
//记录下原坐标
xt := x; yt := y;
if x > xs then
begin
xl := trunc(x - Len * Cos(ArcTan((y - ys) / (x - xs)) - Pi / 6));
yl := trunc(y - Len * Sin(ArcTan((y - ys) / (x - xs)) - Pi / 6));
xr := trunc(x - Len * Cos(ArcTan((y - ys) / (x - xs)) + Pi / 6));
yr := trunc(y - Len * Sin(ArcTan((y - ys) / (x - xs)) + Pi / 6));
end
else
if x < xs then
begin
xl := trunc(x + Len * Cos(ArcTan((y - ys) / (x - xs)) - Pi / 6));
yl := trunc(y + Len * Sin(ArcTan((y - ys) / (x - xs)) - Pi / 6));
xr := trunc(x + Len * Cos(ArcTan((y - ys) / (x - xs)) + Pi / 6));
yr := trunc(y + Len * Sin(ArcTan((y - ys) / (x - xs)) + Pi / 6));
end
else
if y < ys then
begin
xl := trunc(x - Len * Sin(Pi / 6));
yl := trunc(y + Len * Cos(Pi / 6));
xr := trunc(x + Len * Sin(Pi / 6));
yr := trunc(y + Len * Cos(Pi / 6));
end
else
if y > ys then
begin
xl := trunc(x - Len * Sin(Pi / 6));
yl := trunc(y - Len * Cos(Pi / 6));
xr := trunc(x + Len * Sin(Pi / 6));
yr := trunc(y - Len * Cos(Pi / 6));
end
else
begin
xl := -1;
yl := -1;
xr := -1;
yr := -1;
end;
if xl <> -1 then
begin
// Form1.Canvas.Brush.Color:=clRed; //填充三角形
// m[1]:= Point(x, y);
// m[2]:= Point(xl, yl);
// m[3]:= Point(xs, ys);
// m[4]:= Point(xr, yr);
// Form1.Canvas.Polygon( m);
g := TGPGraphics.Create(Canvas.Handle);
g.SetSmoothingMode( SmoothingModeAntiAlias);{指定平滑（抗锯齿）}
sb := TGPSolidBrush.Create(MakeColor(255,0,255));
pts[1].X := x; pts[1].Y := y;
pts[2].X := xl ;pts[2].Y := yl;
pts[3].X := xs; pts[3].Y := ys;
pts[4].X := xr; pts[4].Y := yr;
g.FillPolygon(sb, PGPPoint(@pts), 4); {第三个参数是顶点数}
sb.Free;
g.Free;
end;
end;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Form1.Color := clWhite;
Form1.Caption := '画带箭头的直线 ';
Form1.WindowState := wsMaximized;
B := False;
xt := -1; yt := -1;
xl := -1; yl := -1;
xr := -1;
yr := -1;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
end;
end.
QQ软件的箭头：离QQ的还是有一定的距离
浙公网安备 33010602011771号