unit viArrow;
{
TviArrow and TviArrowEx
Version 1.0
by Ma Jun
email:junma@126.com
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.
应该可以了吧!