viarrow.pas

delphi用的箭头控件源码。可设置箭头角度等属性。

unit viArrow;

{

TviArrow and TviArrowEx
Version 1.0
by Ma Jun

email:[e-mail]
home page:http://go.163.com/~delphiws (in chinese)

  You are free to use TviArrow and TviArrowEx for any purpose. If you do some
  modification, please let me know.

}
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type TArrowPosition = (apLeft, apRight, apBoth);

type TArrowDirection = (adTopToTop, adTopToBottom, adBottomToTop, adBottomToBottom,
                        adLeftToLeft, adRightToRight);

type
  TviArrow = class(TGraphicControl)
  private
    fLineWidth : Word;              // 1 to ...
    fArrowThicknessRate : Word;     // 1 to ...   一般为奇数倍
    fArrowHeadLengthRate: Word;     // 1 to ...
    fArrowPosition  : TArrowPosition;    // 箭头参数，是否两端有箭头
    fArrowDirection : TArrowDirection;   // 怎样利用矩形的四个端点确定箭头线的位置

    fPoints: array[1..3] of TPoint;   // 内部使用，箭头的三个点
    fOnMouseEnter        : TNotifyEvent;
    fOnMouseLeave        : TNotifyEvent;

    procedure SetLineWidth( Value : word );
    procedure SetArrowThicknessRate( Value : Word );
    procedure SetArrowHeadLengthRate( Value : Word );
    procedure SetArrowPosition ( Value : TArrowPosition );
    procedure SetArrowDirection( Value : TArrowDirection );
    procedure Paint; override;
  protected
    { Protected declarations }
    procedure DrawArrow(StartPoint, EndPoint, ArrowHead : TPoint; Reversed : Boolean); virtual;
                        // 开始、结束点定斜率，箭头点定位置，Reverse确定是否反转
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
    { Published declarations }
    property LineWidth : Word read fLineWidth write SetLineWidth default 1;
    property ThicknessRate  : Word read fArrowThicknessRate  write SetArrowThicknessRate  default 3;
    property HeadLengthRate : Word read fArrowHeadLengthRate write SetArrowHeadLengthRate default 2;
    property ArrowPosition  : TArrowPosition read fArrowPosition write SetArrowPosition;
    property ArrowDirection : TArrowDirection read fArrowDirection write SetArrowDirection default adTopToBottom;
    property OnMouseEnter:TNotifyEvent read  FOnMouseEnter  write FOnMouseEnter;
    property OnMouseLeave:TNotifyEvent read   FOnMouseLeave write FOnMouseLeave;
    property Align;
    property Color;
    property ShowHint;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

type
  TviArrowEx = class (TviArrow)  //重载DrawArrow使对边画的方法移动到图形中央
   private
   protected
     procedure DrawArrow(StartPoint, EndPoint, ArrowHead : TPoint; Reversed : Boolean); override;
   public
   end;

procedure Register;

implementation

constructor TviArrow.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);
    Width  := 100;
    Height := 60;
    Color  := clBlack;
    fLineWidth := 1;
    fArrowThicknessRate := 10;
    fArrowHeadLengthRate:= 2;
    fArrowPosition  := apBoth;
    fArrowDirection := adTopToBottom;
end;

procedure TviArrow.SetLineWidth( Value : word );
begin
  if Value>0 then
     begin
     fLineWidth := Value;
     Invalidate;
     end;
end;

procedure TviArrow.SetArrowThicknessRate( Value : Word );
begin
  if Value>0 then
     begin
     fArrowThicknessRate := Value;
     Invalidate;
     end;
end;

procedure TviArrow.SetArrowHeadLengthRate( Value : Word );
begin
   if Value>0 then
        begin
        fArrowHeadLengthRate := Value;
        Invalidate;
        end;
end;

procedure TviArrow.SetArrowPosition ( Value : TArrowPosition );
begin
  fArrowPosition := Value;
  Invalidate;
end;

procedure TviArrow.SetArrowDirection( Value : TArrowDirection );
begin
  fArrowDirection := Value;
  Invalidate;
end;

procedure TviArrow.CMMouseEnter(var Message: TMessage);
begin
   if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
end;

procedure TviArrow.CMMouseLeave(var Message: TMessage);
begin
   if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
end;

procedure TviArrow.DrawArrow(StartPoint, EndPoint, ArrowHead : TPoint; Reversed : Boolean);
var
   // 关于变量的定义参见说明
   M, N, L, angleA, angleB : Double;
begin
   //对效果不理想的进行微调, not standard
   if fArrowDirection=adRightToRight   then
      begin
      Dec(StartPoint.x);
      Dec(EndPoint.x);
      end;
   if fArrowDirection=adBottomToBottom then
      begin
      Dec(StartPoint.y);
      Dec(EndPoint.y);
      end;

   //计算数值
   M := fLineWidth * fArrowThicknessRate;
   L := M * fArrowHeadLengthRate;
   N := sqrt( M * M / 4 + L * L );
   if EndPoint.x<>StartPoint.x then angleA := Arctan((EndPoint.y - StartPoint.y)/(EndPoint.x - StartPoint.x))
                               else angleA := PI / 2;
   angleB := Arctan( M / L / 2 );
   // 如果需要反转，加3.1415
   if Reversed then  angleA := angleA - PI;
   fPoints[1].x := ArrowHead.x;
   fPoints[1].y := ArrowHead.y;
   fPoints[2].x := ArrowHead.x + Round( N * cos( angleA + angleB ));
   fPoints[2].y := ArrowHead.y + Round( N * sin( angleA + angleB ));
   fPoints[3].x := ArrowHead.x + Round( N * cos( angleA - angleB ));
   fPoints[3].y := ArrowHead.y + Round( N * sin( angleA - angleB ));
   with Canvas do
        begin
        // 如果取两头都画箭头则画线在一次Paint中被调用两次
        Pen.Width := fLineWidth;
        Pen.Color := Color;
        MoveTo( StartPoint.x, StartPoint.y);
        LineTo( EndPoint.x,   EndPoint.y);
        // 显示箭头
        Brush.Color := Color;
        Polygon(fPoints);
        end;
end;

procedure TviArrow.Paint;
begin
  inherited Paint;
  // 画箭头
  with ClientRect do
       begin
       // 先显示连线
{       with Canvas do
            begin
            Pen.Width := fLineWidth;
            Pen.Color := Color;
            case fArrowDirection of
                adTopToTop      : begin
                                  MoveTo( Left,  Top );
                                  LineTo( Right, Top);
                                  end;
                adTopToBottom   : begin
                                  MoveTo( Left,  Top );
                                  LineTo( Right, Bottom);
                                  end;
                adBottomToTop   : begin
                                  MoveTo( Left,  Bottom );
                                  LineTo( Right, Top);
                                  end;
                adBottomToBottom: begin
                                  MoveTo( Left,  Bottom-1 );
                                  LineTo( Right, Bottom-1);
                                  end;
                adLeftToLeft    : begin
                                  MoveTo( Left, Top );
                                  LineTo( Left, Bottom);
                                  end;
                adRightToRight  : begin
                                  MoveTo( Right-1, Top );
                                  LineTo( Right-1, Bottom);
                                  end;
                end;
           end;}

       // 如果箭头在左边或两边都有，则显示左箭头,左箭头在显示时不反转
       if (fArrowPosition=apLeft) or (fArrowPosition=apBoth) then
           begin
           case fArrowDirection of
                adTopToTop      : DrawArrow(TopLeft, Point( Right, Top), TopLeft, False);
                adTopToBottom   : DrawArrow(TopLeft, BottomRight, TopLeft, False);
                adBottomToTop   : DrawArrow(Point( Left, Bottom), Point( Right, Top),
                                            Point( Left, Bottom), False);
                adBottomToBottom: DrawArrow(Point(Left,Bottom), BottomRight,
                                            Point(Left,Bottom), False);
                adLeftToLeft    : DrawArrow(TopLeft, Point(Left, Bottom),
                                            TopLeft, False);
                adRightToRight  : DrawArrow(Point(Right,Top), BottomRight,
                                            Point(Right,Top), False);
                end;
           end;

       // 如果箭头在右边或两边都有，则显示右箭头
       if (fArrowPosition=apRight) or (fArrowPosition=apBoth) then
           begin
           case fArrowDirection of
                adTopToTop      : DrawArrow(TopLeft, Point(Right,Top),
                                            Point(Right,Top), True);
                adTopToBottom   : DrawArrow(TopLeft, BottomRight,
                                            BottomRight, True);
                adBottomToTop   : DrawArrow(Point(Left,Bottom), Point(Right,Top),
                                            Point(Right, Top), True);
                adBottomToBottom: DrawArrow(Point(Left,Bottom), BottomRight,
                                            BottomRight, True);
                adLeftToLeft    : DrawArrow(TopLeft, Point(Left, Bottom),
                                            Point(Left, Bottom), True);
                adRightToRight  : DrawArrow(Point(Right,Top), BottomRight,
                                            BottomRight, True);
                end;
           end;
       end;
end;

// ---------------------  TviArrowEx -----------------------
procedure TviArrowEx.DrawArrow(StartPoint, EndPoint, ArrowHead : TPoint; Reversed : Boolean);
begin
  case ArrowDirection of
        adTopToTop, adBottomToBottom  : begin
                                        StartPoint.y := Height div 2;
                                        EndPoint.y   := StartPoint.y;
                                        ArrowHead.y  := StartPoint.y;
                                        end;
        adLeftToLeft, adRightToRight  : begin
                                        StartPoint.x := Width div 2;
                                        EndPoint.x   := StartPoint.x;
                                        ArrowHead.x  := StartPoint.x;
                                        end;
        end;
  inherited DrawArrow(StartPoint, EndPoint, ArrowHead ,Reversed);
end;

//  --------------------  Register -------------------------
procedure Register;
begin
  RegisterComponents('viPackEx', [TviArrow]);
  RegisterComponents('viPackEx', [TviArrowEx]);
end;

end.