下面是一个画箭头线的控件，可以直接编译到组件面板上。
你要自己画线，可以参考 procedure TJetLine.Paint; 过程。
{=======================================================================================================================
JetLine Unit
Copyright ?1995-2003 by Gentle Software, Inc. All Rights Reserved.
=======================================================================================================================}
unit JetLine;
interface
uses
{$IFDEF USE_CS}
CSIntf,
{$ENDIF}
Classes,
{&RF}
Controls,
Graphics,
Messages,
SysUtils,
Windows;
type
{===============================}
{== TJetLine Class Declaration ==}
{===============================}
TJetLineSlope = ( lsDown, lsUp );
TJetShowArrows = ( saNone, saStart, saEnd, saBoth );
TJetLine = class( TGraphicControl )
private
FBorderWidth: Integer;
FStartPoint: TPoint;
FEndPoint: TPoint;
FLineColor: TColor;
FLineSlope: TJetLineSlope;
FLineStyle: TPenStyle;
FLineWidth: Integer;
FArrowLength: Integer;
FShowArrows: TJetShowArrows;
FOnMouseEnter: TNotifyEvent;
FOnMouseLeave: TNotifyEvent;
procedure CMHitTest( var Msg: TCMHitTest ); message cm_HitTest;
procedure CMMouseEnter( var Msg: TMessage ); message cm_MouseEnter;
procedure CMMouseLeave( var Msg: TMessage ); message cm_MouseLeave;
protected
procedure Loaded; override;
procedure Paint; override;
procedure UpdateSize;
procedure Resize; override;
function GetYFromX( X: Integer; Offset: TPoint ): Integer;
function PointOnLine( P: TPoint ): Boolean;
procedure SetEndPoints;
{ Event Dispatch Methods }
procedure MouseEnter; dynamic;
procedure MouseLeave; dynamic;
{ Property Access Methods }
procedure SetArrowLength( Value: Integer ); virtual;
procedure SetLineColor( Value: TColor ); virtual;
procedure SetLineSlope( Value: TJetLineSlope ); virtual;
procedure SetLineStyle( Value: TPenStyle ); virtual;
procedure SetLineWidth( Value: Integer ); virtual;
procedure SetShowArrows( Value: TJetShowArrows ); virtual;
public
constructor Create( AOwner: TComponent ); override;
published
property ArrowLength: Integer
read FArrowLength
write SetArrowLength
default 10;
property LineColor: TColor
read FLineColor
write SetLineColor
default clWindowText;
property LineSlope: TJetLineSlope
read FLineSlope
write SetLineSlope
default lsDown;
property LineStyle: TPenStyle
read FLineStyle
write SetLineStyle
default psSolid;
property LineWidth: Integer
read FLineWidth
write SetLineWidth
default 1;
property ShowArrows: TJetShowArrows
read FShowArrows
write SetShowArrows
default saNone;
property OnMouseEnter: TNotifyEvent
read FOnMouseEnter
write FOnMouseEnter;
property OnMouseLeave: TNotifyEvent
read FOnMouseLeave
write FOnMouseLeave;
{ Inherited Properties & Events }
property DragKind;
property DragCursor;
property DragMode;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
end;
procedure Register;
implementation
{&RT}
{=====================}
{== TJetLine Methods ==}
{=====================}
procedure Register;
begin
RegisterComponents('Jetcore', [TJetLine]);
end;
constructor TJetLine.Create( AOwner: TComponent );
begin
inherited Create( AOwner );
FBorderWidth := 10;
FLineSlope := lsDown;
SetEndPoints;
{&RCI}
FLineColor := clWindowText;
FLineWidth := 1;
FLineStyle := psSolid;
FArrowLength := 10;
FShowArrows := saNone;
end;
procedure TJetLine.Loaded;
begin
inherited Loaded;
SetEndPoints;
end;
procedure TJetLine.Paint;
var
Theta, Alpha, Beta: Extended;
A, B, SP, EP: TPoint;
begin
// Theta is the slope of the line
SP := FStartPoint;
EP := FEndPoint;
if EP.X <> SP.X then
Theta := ArcTan( ( EP.Y - SP.Y ) / ( EP.X - SP.X ) )
else
Theta := Pi / 2;
if FShowArrows <> saNone then
begin
// Adjust End Points if there are Arrows
A.X := Round( ( FArrowLength div 2 ) * Cos( Theta ) );
A.Y := Round( ( FArrowLength div 2 ) * Sin( Theta ) );
if ( FLineSlope = lsUp ) and ( Theta = Pi / 2 ) then
A := Point( -A.X, -A.Y );
if ( FShowArrows = saStart ) or ( FShowArrows = saBoth ) then
begin
Inc( SP.X, A.X );
Inc( SP.Y, A.Y );
end;
if ( FShowArrows = saEnd ) or ( FShowArrows = saBoth ) then
begin
Dec( EP.X, A.X );
Dec( EP.Y, A.Y );
end;
end;
// This is needed so that correct background color shows through for non-solid LineStyles
Canvas.Brush.Style := bsClear;
Canvas.Pen.Color := FLineColor;
Canvas.Pen.Style := FLineStyle;
Canvas.Pen.Width := FLineWidth;
// Draw Line
Canvas.MoveTo( SP.X, SP.Y );
Canvas.LineTo( EP.X, EP.Y );
// Draw Arrows
if FShowArrows <> saNone then
begin
Alpha := Theta - ( Pi / 8 );
Beta := Theta + ( Pi / 8 );
A.X := Round( FArrowLength * Cos( Alpha ) );
A.Y := Round( FArrowLength * Sin( Alpha ) );
B.X := Round( FArrowLength * Cos( Beta ) );
B.Y := Round( FArrowLength * Sin( Beta ) );
if ( FLineSlope = lsUp ) and ( Theta = Pi / 2 ) then
begin
A := Point( -A.X, -A.Y );
B := Point( -B.X, -B.Y );
end;
Canvas.Brush.Color := FLineColor;
Canvas.Pen.Width := 1;
if ( FShowArrows = saStart ) or ( FShowArrows = saBoth ) then
begin
Canvas.Polygon( [ Point( FStartPoint.X, FStartPoint.Y ),
Point( FStartPoint.X + B.X, FStartPoint.Y + B.Y ),
Point( FStartPoint.X + A.X, FStartPoint.Y + A.Y ) ] );
end;
if ( FShowArrows = saEnd ) or ( FShowArrows = saBoth ) then
begin
Canvas.Polygon( [ Point( FEndPoint.X, FEndPoint.Y ),
Point( FEndPoint.X - B.X, FEndPoint.Y - B.Y ),
Point( FEndPoint.X - A.X, FEndPoint.Y - A.Y ) ] );
end;
end; { if FShowArrows <> saNone }
end; {= TJetLine.Paint =}
function TJetLine.GetYFromX( X: Integer; Offset: TPoint ): Integer;
begin
Result := Round( ( ( FEndPoint.Y - FStartPoint.Y ) / ( FEndPoint.X - FStartPoint.X ) * ( X - FStartPoint.X + Offset.X ) ) +
( FStartPoint.Y + Offset.Y ) );
end;
function TJetLine.PointOnLine( P: TPoint ): Boolean;
var
Y1, Y2, Threshold: Integer;
R: TRect;
procedure Swap( var A, B: Integer );
var
Temp: Integer;
begin
Temp := A;
A := B;
B := Temp;
end;
begin {= TJetLine.PointOnLine =}
Threshold := FLineWidth div 2;
if Threshold < 4 then
Threshold := 4;
// Check to see if P is in the border area
R := ClientRect;
InflateRect( R, -FBorderWidth + Threshold, -FBorderWidth + Threshold );
if not PtInRect( R, P ) then
begin
Result := False;
Exit;
end;
if FStartPoint.X <> FEndPoint.X then
begin
case FLineSlope of
lsDown:
begin
Y1 := GetYFromX( P.X, Point( Threshold, -Threshold ) );
Y2 := GetYFromX( P.X, Point( -Threshold, Threshold ) );
end;
lsUp:
begin
Y1 := GetYFromX( P.X, Point( -Threshold, -Threshold ) );
Y2 := GetYFromX( P.X, Point( Threshold, Threshold ) );
end;
end;
if Y2 < Y1 then
Swap( Y1, Y2 );
Result := ( P.Y >= Y1 ) and ( P.Y <= Y2 );
end
else
begin
// Must be a vertical line
Result := Abs( P.X - FStartPoint.X ) <= Threshold;
end;
end; {= TJetLine.PointOnLine =}
procedure TJetLine.CMHitTest( var Msg: TCMHitTest );
begin
// Need to determine if P is on the actual line
if PointOnLine( Point( Msg.XPos, Msg.YPos ) ) then
Msg.Result := HTCLIENT
else
Msg.Result := HTNOWHERE;
end;
procedure TJetLine.MouseEnter;
begin
if Assigned( FOnMouseEnter ) then
FOnMouseEnter( Self );
end;
procedure TJetLine.CMMouseEnter( var Msg: TMessage );
begin
inherited;
{$IFDEF VCL70_OR_HIGHER}
if csDesigning in ComponentState then
Exit;
{$ENDIF}
MouseEnter;
{&RV}
end;
procedure TJetLine.MouseLeave;
begin
if Assigned( FOnMouseLeave ) then
FOnMouseLeave( Self );
end;
procedure TJetLine.CMMouseLeave( var Msg: TMessage );
begin
inherited;
MouseLeave;
end;
procedure TJetLine.UpdateSize;
begin
if Width < ( 2 * FBorderWidth ) then
Width := 2 * FBorderWidth;
if Height < ( 2 * FBorderWidth ) then
Height := 2 * FBorderWidth;
end;
procedure TJetLine.Resize;
begin
inherited Resize;
UpdateSize;
{&RV}
SetEndPoints;
end;
procedure TJetLine.SetEndPoints;
begin
case FLineSlope of
lsDown:
begin
FStartPoint := Point( FBorderWidth, FBorderWidth );
FEndPoint := Point( Width - FBorderWidth, Height - FBorderWidth );
end;
lsUp:
begin
FStartPoint := Point( FBorderWidth, Height - FBorderWidth );
FEndPoint := Point( Width - FBorderWidth, FBorderWidth );
end;
end;
end;
procedure TJetLine.SetArrowLength( Value: Integer );
begin
if FArrowLength <> Value then
begin
FArrowLength := Value;
FBorderWidth := Value div 2;
UpdateSize;
SetEndPoints;
Invalidate;
end;
end;
procedure TJetLine.SetLineColor( Value: TColor );
begin
if FLineColor <> Value then
begin
FLineColor := Value;
Invalidate;
end;
end;
procedure TJetLine.SetLineSlope( Value: TJetLineSlope );
begin
if FLineSlope <> Value then
begin
FLineSlope := Value;
SetEndPoints;
Invalidate;
end;
end;
procedure TJetLine.SetLineStyle( Value: TPenStyle );
begin
if FLineStyle <> Value then
begin
FLineStyle := Value;
Invalidate;
end;
end;
procedure TJetLine.SetLineWidth( Value: Integer );
begin
if FLineWidth <> Value then
begin
if FShowArrows <> saNone then
begin
if Value mod 2 = 0 then
begin
if FLineWidth < Value then
Inc( Value )
else
Dec( Value );
end;
end;
FLineWidth := Value;
Invalidate;
end;
end;
procedure TJetLine.SetShowArrows( Value: TJetShowArrows );
begin
if FShowArrows <> Value then
begin
FShowArrows := Value;
Invalidate;
end;
end;
{&RUIF}
end.
