精华区 [关闭][返回]

当前位置:网易精华区>>讨论区精华>>编程开发>>● Delphi>>控件开发和使用>>创建一个线形控件

主题:创建一个线形控件
发信人: lihai155(天琴)
整理人: kingron(2000-12-27 18:20:13), 站内信件
unit Line;

interface

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

type
  TLine = class(TPanel)
  private
    FEndY: Integer;
    FStartY: Integer;
    FEndX: Integer;
    FStartX: Integer;
    HdlRgn:THandle;
    FLineWidth: Integer;
    procedure SetEndX(const Value: Integer);
    procedure SetEndY(const Value: Integer);
    procedure SetStartX(const Value: Integer);
    procedure SetStartY(const Value: Integer);
    procedure DrawLine;
    procedure SetLineWidth(const Value: Integer);
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
    Constructor Create(AOwner:TComponent);override;
    Destructor Destroy;override;
  published
    { Published declarations }
    property StartX:Integer Read FStartX write SetStartX;
    property StartY:Integer Read FStartY write SetStartY;
    property EndX:Integer Read FEndX write SetEndX;
    property EndY:Integer Read FEndY write SetEndY;
    property LineWidth:Integer Read FLineWidth write SetLineWidth;
  end;

procedure Register;

implementation

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

{ TLine }

constructor TLine.Create(AOwner: TComponent);
begin
  inherited;
  Self.Caption:='';
  Color:=clRed;
  if Parent=nil then
    Parent:=TWinControl(AOwner);
  Left:=0;  Top:=0;  
  FStartX:=0;  FStartY:=0;
  FEndX:=100;   FEndY:=100;
  FLineWidth:=3;
  DrawLine;
end;

destructor TLine.Destroy;
begin
  inherited;
  DeleteObject(HdlRgn);
end;

procedure TLine.DrawLine;
Var
  Pnts:Array[1..4]of TPoint;
begin
  if Parent=nil then exit;
  Pnts[1].x:=FStartX;  Pnts[1].y:=FStartY;
  Pnts[2].x:=FEndX;  Pnts[2].y:=FEndY;
  Pnts[3].x:=FEndX+FLineWidth;  Pnts[3].y:=FEndY - FLineWidth;
  Pnts[4].x:=FStartX+FLineWidth;  Pnts[4].y:=FStartY - FLineWidth;
  if HdlRgn>0 then
    DeleteObject(HdlRgn);
  HdlRgn:=CreatePolyGonRgn(Pnts,4,Winding);
  SetWindowRgn(Handle,HdlRgn,True);
  DeleteObject(Handle);
end;

procedure TLine.SetEndX(const Value: Integer);
begin
  FEndX := Value;
  DrawLine;
end;

procedure TLine.SetEndY(const Value: Integer);
begin
  FEndY := Value;
  DrawLine;
end;

procedure TLine.SetLineWidth(const Value: Integer);
begin
  FLineWidth := Value;
  DrawLine;
end;

procedure TLine.SetStartX(const Value: Integer);
begin
  FStartX := Value;
  DrawLine;
end;

procedure TLine.SetStartY(const Value: Integer);
begin
  FStartY := Value;
  DrawLine;
end;

end.

//这个控件在编辑环境下有一个虚框,在运行时就是一个线形了。
//有什么改进意见欢迎回复,谢谢。


----
头上起包包,鲜血直见飚。
脚杆不松活,据说要开刀。
还考啥子初中,差点儿进高烟囱。

[关闭][返回]