德尔福线组件

Question

我正在寻找一个线组件。

我看过几个例子，但是他们没有启用

• 以任何角度绘制的线，或
• 使用不同的线条模式 - 点/划线
• 等等

我希望能够做一些类似于 MS word 中的 INSERT/SHAPES/LINE 的事情，我可以在一端捕获 anchor 并以任何角度拖动...

这是我找到的一个:TLine v.1.0

但它只能让我画水平线或垂直线，而不是 17 度角的线..

这link是我想做的事情，在行尾有 anchor ，所以我可以在运行时单击它们并拖动行

有谁知道一个组件(免费软件)

• 可以做我想做的或
• 帮助将上面的转换成我想要的，或者
• 任何可能有帮助的建议..

提前致谢...

Answer 1

我知道您找到了一个组件，但它缺少您想要的一些属性。好吧，我看了一下 TShape 是如何制作的，并提出了以下尝试:

更新:

添加了属性 AutoAngle 和 Backwards。

unit Line;

interface

uses
  Windows, Classes, Controls, Graphics, StdCtrls, Math;

type
  TLine = class(TGraphicControl)
  private
    FAlignment: TAlignment;
    FAngle: Integer;
    FAutoAngle: Boolean;
    FLayout: TTextLayout;
    FPen: TPen;
    function DiagonalAngle: Integer;
    function GetBackwards: Boolean;
    function GetExtends(LimitWidth, LimitHeight: Integer): TRect;
    procedure PenChanged(Sender: TObject);
    procedure SetAlignment(Value: TAlignment);
    procedure SetAngle(Value: Integer);
    procedure SetAutoAngle(Value: Boolean);
    procedure SetBackwards(Value: Boolean);
    procedure SetLayout(Value: TTextLayout);
    procedure SetPen(Value: TPen);
  protected
    procedure AdjustSize; override;
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    procedure Paint; override;
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Align;
    property Alignment: TAlignment read FAlignment write SetAlignment
      default taCenter;
    property Anchors;
    property Angle: Integer read FAngle write SetAngle;
    property AutoAngle: Boolean read FAutoAngle write SetAutoAngle
      default True;
    property AutoSize;
    property Backwards: Boolean read GetBackwards write SetBackwards
      stored False;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Layout: TTextLayout read FLayout write SetLayout default tlCenter;
    property OnContextPopup;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
    property ParentShowHint;
    property Pen: TPen read FPen write SetPen;
    property ShowHint;
    property Visible;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TLine]);
end;

{ TLine }

procedure TLine.AdjustSize;
begin
  if AutoSize then
    FAutoAngle := False;
  inherited AdjustSize;
end;

function TLine.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
  with GetExtends(NewWidth, NewHeight) do
  begin
    NewWidth := Right;
    NewHeight := Bottom;
  end;
  Result := True;
end;

constructor TLine.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  Width := 65;
  Height := 65;
  FPen := TPen.Create;
  FPen.OnChange := PenChanged;
  FAlignment := taCenter;
  FLayout := tlCenter;
  FAutoAngle := True;
end;

destructor TLine.Destroy;
begin
  FPen.Free;
  inherited Destroy;
end;

function TLine.DiagonalAngle: Integer;
begin
  if Width = FPen.Width then
    Result := 90
  else if Height = FPen.Width then
    Result := 0
  else
    if Backwards then
      Result := 180 - Round(RadToDeg(ArcTan(Height / Width)))
    else
      Result := Round(RadToDeg(ArcTan(Height / Width)));
end;

function TLine.GetBackwards: Boolean;
begin
  Result := FAngle > 90;
end;

function TLine.GetExtends(LimitWidth, LimitHeight: Integer): TRect;
begin
  Result.Left := 0;
  Result.Top := 0;
  if FAngle = 0 then
  begin
    Result.Right := LimitWidth;
    Result.Bottom := FPen.Width;
  end
  else if FAngle = 90 then
  begin
    Result.Right := FPen.Width;
    Result.Bottom := LimitHeight;
  end
  else
  begin
    Result.Right := Min(LimitWidth,
      Round(LimitHeight / Abs(Tan(DegToRad(FAngle)))));
    Result.Bottom := Min(LimitHeight,
      Round(LimitWidth * Abs(Tan(DegToRad(FAngle)))));
  end;
end;

procedure TLine.Paint;
var
  R: TRect;
begin
  Canvas.Pen.Assign(FPen);
  Canvas.Brush.Style := bsClear;
  R := GetExtends(Width, Height);
  case FAlignment of
    taCenter:
      OffsetRect(R, (Width - R.Right) div 2, 0);
    taRightJustify:
      OffsetRect(R, Width - R.Right, 0);
  end;
  case FLayout of
    tlCenter:
      OffsetRect(R, 0, (Height - R.Bottom) div 2);
    tlBottom:
      OffsetRect(R, 0, Height - R.Bottom);
  end;
  if FAngle = 0 then
  begin
    Canvas.MoveTo(R.Left, R.Top + FPen.Width div 2);
    Canvas.LineTo(R.Right, R.Top + FPen.Width div 2);
  end
  else if FAngle = 90 then
  begin
    Canvas.MoveTo(R.Left + FPen.Width div 2, R.Top);
    Canvas.LineTo(R.Left + FPen.Width div 2, R.Bottom);
  end
  else if FAngle < 90 then
  begin
    Canvas.MoveTo(R.Left, R.Bottom);
    Canvas.LineTo(R.Right, R.Top);
  end
  else
  begin
    Canvas.MoveTo(R.Left, R.Top);
    Canvas.LineTo(R.Right, R.Bottom);
  end;
end;

procedure TLine.PenChanged(Sender: TObject);
begin
  AdjustSize;
  Invalidate;
end;

procedure TLine.Resize;
begin
  if FAutoAngle then
    Angle := DiagonalAngle;
  inherited Resize;
end;

procedure TLine.SetAlignment(Value: TAlignment);
begin
  if FAlignment <> Value then
  begin
    FAlignment := Value;
    Invalidate;
  end;
end;

procedure TLine.SetAngle(Value: Integer);
begin
  while Value < 0 do
    Inc(Value, 180);
  while Value >= 180 do
    Dec(Value, 180);
  if FAngle <> Value then
  begin
    FAngle := Value;
    if FAngle <> DiagonalAngle then
      FAutoAngle := False;
    if AutoSize then
      AdjustSize;
    Invalidate;
  end;
end;

procedure TLine.SetAutoAngle(Value: Boolean);
begin
  if FAutoAngle <> Value then
  begin
    FAutoAngle := Value;
    if FAutoAngle then
    begin
      AutoSize := False;
      Angle := DiagonalAngle;
    end;
  end;
end;

procedure TLine.SetBackwards(Value: Boolean);
begin
  if Backwards <> Value then
    Angle := 180 - FAngle;
end;

procedure TLine.SetLayout(Value: TTextLayout);
begin
  if FLayout <> Value then
  begin
    FLayout := Value;
    Invalidate;
  end;
end;

procedure TLine.SetPen(Value: TPen);
begin
  FPen.Assign(Value);
end;

end.