advline.pas

像VB中在设计时的直线控件

{                            line component                           }    
{*********************************************************************}
{  Copyright (C) 2004 by                                              }
{  Xi'an Electronic Engineering Research Institute(XEERI)             }
{  Version 1.0                                                        }
{  Write By Qixh                                                      }
{  2003/11/02                                                         }

unit advline;

interface

uses WinTypes,extctrls, WinProcs, Messages, SysUtils, Classes, Controls,
     Forms, Graphics;

type
  qixhdirection=(LeftToRight,RightToLeft);
type
  TLine = class(TGraphicControl)
  private
    Fx1,Fx2,Fy1,Fy2,Fwide:integer;
    Fpen: Tpen;
    FDirection:qixhdirection;
    procedure Setpen(Value: Tpen);
    procedure setx1(value:integer);
    procedure sety1(value:integer);
    procedure setx2(value:integer);
    procedure sety2(value:integer);
    procedure setwide(value:integer);
    procedure setdirection(value:qixhdirection);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    procedure StyleChanged(Sender: TObject);
      property DragCursor;
      property DragKind;
      property DragMode;
      property Enabled;
      property Constraints;
      property ParentShowHint;
      property pen: Tpen read Fpen write Setpen;
      property ShowHint;
    property Direction:qixhdirection read fdirection write setdirection default LeftToRight;
    property Visible;
      property OnContextPopup;
      property OnDragDrop;
      property OnDragOver;
      property OnEndDock;
      property OnEndDrag;
      property OnMouseDown;
      property OnMouseMove;
      property OnMouseUp;
      property OnStartDock;
      property OnStartDrag;

     property x1:integer read Fx1 write setx1;
     property y1:integer read Fy1 write sety1;
     property x2:integer read Fx2 write setx2;
     property y2:integer read Fy2 write sety2;
     property wide:integer read Fwide write setwide;
  end;

procedure Register;

implementation

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

constructor TLine.Create(AOwner: TComponent);
begin
  inherited create(aowner);
  ControlStyle := ControlStyle + [csReplicatable];
  Width := 65;
  Height := 65;
  FPen := TPen.Create;
  FPen.OnChange := StyleChanged;
end;

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

procedure TLine.Paint;
begin
  with Canvas do
  begin
    Pen:=fpen;
       if FDirection=LeftToRight then
       begin
         moveto(0,0);
         lineto(width-1,height-1);
       end;
       if FDirection=RightToLeft then
       begin
         MoveTo(Width-1, 0);
         LineTo(0, Height-1);
       end;
    fX1:=left;
    fy1:=top;
    fX2:=left+width;
    fY2:=top+height;
  end;
end;

procedure TLine.setdirection(value: qixhdirection);
begin
 fdirection:=value;
 invalidate;
end;

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

procedure TLine.setwide(value: integer);
begin
  Fwide:=value;
  invalidate;
end;

procedure TLine.setx1(value: integer);
begin
  Fx1:=value;
  left:=Fx1;
  invalidate;
end;

procedure TLine.setx2(value: integer);
begin
  Fx2:=value;
  width:=abs(Fx2-left);
  invalidate;
end;

procedure TLine.sety1(value: integer);
begin
  Fy1:=value;
  top:=Fy1;
  invalidate;
end;

procedure TLine.sety2(value: integer);
begin
  Fy2:=value;
  height:=abs(Fy2-top);
  invalidate;
end;

procedure TLine.StyleChanged(Sender: TObject);
begin
  invalidate;
end;

end.