画好看的箭头线
2018-06-17 18:55:37来源：未知 阅读 ()
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的还是有一定的距离
标签：
版权申明：本站文章部分自网络，如有侵权，请联系：west999com@outlook.com
特别注意：本站所有转载文章言论不代表本站观点，本站所提供的摄影照片，插画，设计作品，如需使用，请与原作者联系，版权归原作者所有
相关文章
- 去除win7桌面图标小箭头.bat 2018-06-17
- 每个人都应该看的--怎样管理您的知识 2018-06-17
- UML速记 2018-06-17
- 如何在delphi 中画带箭头的直线（改自网上一位论坛版主的vb 2008-04-10
IDC资讯： 主机资讯 注册资讯 托管资讯 vps资讯 网站建设
网站运营： 建站经验 策划盈利 搜索优化 网站推广 免费资源
网络编程： Asp.Net编程 Asp编程 Php编程 Xml编程 Access Mssql Mysql 其它
服务器技术： Web服务器 Ftp服务器 Mail服务器 Dns服务器 安全防护
软件技巧： 其它软件 Word Excel Powerpoint Ghost Vista QQ空间 QQ FlashGet 迅雷
网页制作： FrontPages Dreamweaver Javascript css photoshop fireworks Flash
热门词条
最新资讯
热门关注
热门标签