delphi 画 带箭头的线

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.