dcurve.~pas

很好地delphi书籍源码

unit DCurve;

interface

uses
  SysUtils, Classes, Controls,Graphics;

const  MAXY=500;
type
  TPlace=(aTop,aMid,aBottom);	//X坐标轴位置,上、中和下
  TCurveNumber=(One,Two,Three);//一个坐标中同时显示的曲线数量


  TDCurve = class(TGraphicControl)
  private
    FAxis:TPlace ;					//X坐标位置
    FCurveNumber:TCurveNumber ;
    FLineColor1:TColor ;			//第1条曲线线条颜色
    FLineColor2:TColor ;			//第2条曲线线条颜色
    FLineColor3:TColor ;			//第3条曲线线条颜色
    FLineWidth1:integer ;			//第1条曲线线条宽度
    FLineWidth2:integer ;			//第2条曲线线条宽度
    FLineWidth3:integer ;			//第3条曲线线条宽度
    FRangeMaxT, FRangeMinT :integer ;//曲线自变量的最大值最小值
    FRangeMaxX:integer;			//横轴最大值
    FRangeMinX:integer;			//横轴最小值
    FRangeMaxY1:integer;			//第1条曲线最大值
    FRangeMinY1:integer;			//第1条曲线最小值
    FRangeMaxY2:integer;			//第2条曲线最大值
    FRangeMinY2:integer;			//第2条曲线最小值
    FRangeMaxY3:integer;			//第3条曲线最大值
    FRangeMinY3:integer;			//第3条曲线最小值
    FLineStyle1:TPenStyle ;		//第1条曲线曲线风格
    FLineStyle2:TPenStyle ;		//第2条曲线曲线风格
    FLineStyle3:TPenStyle ;		//第3条曲线曲线风格
    FWidthNumber:integer;			//宽度方向等分数量　
    FHeightNumber:integer;			//高度方向等分数量
    FGrid:boolean ;				//是否显示风格
    Cir:word;						//记录显示的周期数
    FTitleX,FTitleY:shortstring  ;//横向和纵向标题
    Scale_x,Scale_y:array[1..40] of shortstring ;//显示比例
    procedure ConfigPen(C:TColor;S:TPenStyle;W:integer);//曲线的显示方式
    procedure ReDrawLine1();//重绘第1条曲线
    procedure ReDrawLine2();//重绘第2条曲线
    procedure ReDrawLine3();//重绘第3条曲线
  protected
    procedure SetWidthNumber(AWidthNumber:integer);	//设置X轴分段
    procedure SetHeightNumber(AHeightNumber:integer);	//设置Y轴分段
    procedure SetAxis(AAxis:TPlace);					//设置x轴位置
    procedure SetGrid(AGrid:boolean);					//设置网格的显示
    procedure Paint(); override;						//重载Paint过
  public
   Y1,Y2,Y3:array[0..MAXY] of word;	//记录曲线的因变量值勤,即y值
   X0,Y0:word;						//记录原点位置的因变量值
   Count:integer;						//计算已标绘的点数
   procedure PSetRangeY(MaxY1,MaxY2,MaxY3,MinY1,MinY2,MinY3:integer); //设置因变量范围
   procedure PSetCurveNum(Num:TCurveNumber);			//设置曲线数量
   procedure PSetAxis(AAxis:TPlace );					//设置
   procedure PSetGrid(AGrid:boolean );
   procedure DrawLine1(t:integer;yy:double);		//绘制一条曲线
   procedure DrawLine2(t:integer;yy1,yy2:double);	//绘制二条曲线
   procedure DrawLine3(t:integer;yy1,yy2,yy3:double);//绘制三条曲线
   procedure WriteTitle(XT,YT: string);				//写标题
   constructor Create (AOnwer:TComponent);override;	//重载构造函数
  published
   property CurveNumber:TCurveNumber read FCurveNumber write
   FCurveNumber default Three;
   property Axis:TPlace read FAxis write SetAxis default aMid;
   property LineColor1:TColor  read FLineColor1 write FLineColor1
      default clRed;
   property LineWidth1:integer read FLineWidth1 write FLineWidth1
     default 1;
   property LineColor2:TColor  read FLineColor2 write FLineColor2
      default clBlue;
   property LineWidth2:integer read FLineWidth2 write FLineWidth2
      default 1;
   property LineColor3:TColor  read FLineColor3 write FLineColor3
      default clTeal;
   property LineWidth3:integer read FLineWidth3 write FLineWidth3
      default 1;
   property LineStyle1:TPenStyle read FLineStyle1  write FLineStyle1
      default psSolid;
   property LineStyle2:TPenStyle read FLineStyle2  write FLineStyle2
     default psSolid;
   property LineStyle3:TPenStyle read FLineStyle3  write FLineStyle3
      default psSolid;
   property RangeMaxY1:integer read FRangeMaxY1 write FRangeMaxY1 ;
   property RangeMinY1:integer read FRangeMinY1 write FRangeMinY1 ;
   property RangeMaxY2:integer read FRangeMaxY2 write FRangeMaxY2 ;
   property RangeMinY2:integer read FRangeMinY2 write FRangeMinY2 ;
   property RangeMaxY3:integer read FRangeMaxY3 write FRangeMaxY3 ;
   property RangeMinY3:integer read FRangeMinY3 write FRangeMinY3 ;
   property WidthNumber:integer read FWidthNumber write FwidthNumber
     default 8;
   property HeightNumber:integer read FHeightNumber write
   FHeightNumber default 6;
   property Grid:boolean read FGrid write SetGrid default true;
   property TitleX:shortString read FTitleX  write FTitleX;
   property TitleY:shortString read FTitleY  write FTitleY;
   property RangeMaxT:integer read  FRangeMaxT write FrangeMaxT
     default  10  ;
   property RangeMinT:integer read  FRangeMinT write FrangeMinT
     default  1  ;
   property Width default 200;	//来自基类的属性
   property Height default 150;	//来自基类的属性
   property Align default alNone;//来自基类的属性
   property Visible default true;//来自基类的属性
   property OnClick;				//来自基类的属性
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('MyComponent', [TDCurve]);
end;

procedure TDCurve.ConfigPen(C: TColor; S: TPenStyle; W: integer);
begin
  Canvas.Pen.Color:=C;
  Canvas.Pen.Style:=S;
  Canvas.Pen.Width:=W;
end;

constructor TDCurve.Create(AOnwer: TComponent);
begin
  inherited create(AOnwer);//执行父辈组件的构造函数,完成父辈组件初始化工作
  FLineColor1:=clRed;
  FLineColor2:=clBlue;
  FLineColor3:=clTeal;
  FLineWidth1:=1;
  FLineWidth2:=1;
  FLineWidth3:=1;
  FLineStyle1:=psSolid;//实线
  FLineStyle2:=psSolid;
  FLineStyle3:=psSolid;
  Width:=200;
  Height:=150;
  FWidthNumber:=8;
  FHeightNumber:=6;
  Cir:=1;
  FAxis:=aMid;
  FGrid:=true;
  FCurveNumber:=Three;
  X0:=1;
  Y0:=Round(0.5*Height);
  FRangeMaxY1:=Y0;
  FRangeMaxY2:=Y0;
  FRangeMaxY3:=Y0;
  FRangeMinY1:=-Y0;
  FRangeMinY2:=-Y0;
  FRangeMinY3:=-Y0;
  Y1[0]:=1;
  Y2[0]:=1;
  Y3[0]:=1;
  FRangeMaxT:=Width;
  FRangeMinT:=1;
  FTitleX:='';
  FTitleY:='';
end;


procedure TDCurve.DrawLine1(t: integer; yy: double);
var
  j:word;
begin
  j:=0;
  case (FAxis) of
   aTop:
     j:=Round(yy*Height/(FRangeMaxY1-FRangeMinY1));
   aMid: begin
     Y0:=Round(0.5*Height);
     j:=Y0-Round(yy*Height/(FRangeMaxY1-FRangeMinY1));
         end;
   aBottom :
     j:=Height-Round(yy*Height/(FRangeMaxY1-FRangeMinY1));
  end;
  if t=Cir*Width then		//如果成立则说明曲线已显示到最左边
  begin
    Count:=0;			//为重画曲线计数用
    Cir:=Cir+1;		//计数器加1
    Y1[t mod  Width]:=j;
    Invalidate();		//重画窗口
  end else
  begin
    Inc(Count);
    t:=t-(Cir-1)*Width;
    Y1[t mod  Width]:=j;
    ConfigPen(FLineColor1,FLineStyle1,FLineWidth1);
    if (t=1) then exit;
    Canvas.MoveTo(t-1,Y1[t-1]);
    Canvas.LineTo(t,Y1[t]);
  end;
end;

procedure TDCurve.DrawLine2(t: integer; yy1, yy2: double);
var
  i,j1,j2:word;
begin
  case (FAxis) of
   aTop:begin
     j1:=Round(yy1*Height/(FRangeMaxY1-FRangeMinY1));
     j2:=Round(yy2*Height/(FRangeMaxY2-FRangeMinY2));
       end;
   aMid:begin
     Y0:=Round(0.5*Height);
     j1:=Y0-Round(yy1*Height/(FRangeMaxY1-FRangeMinY1));
     j2:=Y0-Round(yy2*Height/(FRangeMaxY2-FRangeMinY2));
      end;
   aBottom :begin
    j1:=Height-Round(yy1*Height/(FRangeMaxY1-FRangeMinY1));
    j2:=Height-Round(yy2*Height/(FRangeMaxY2-FRangeMinY2));
      end;
  end;
  if (t=Cir*Width) then		//如果成立则说明曲线已显示到最左边
  begin
    Count:=0;				//为重画曲线计数用
    Cir:=Cir+1;			//计数器加1
    Y1[t mod  Width]:=j1;
    Y2[t mod  Width]:=j2;
    Invalidate;				//重画窗口
  end else
  begin
    Inc(Count);
    t:=t-(Cir-1)*Width;
    Y1[t mod Width]:=j1;
    Y2[t mod  Width]:=j2;
    if (t=1) then exit;
    ConfigPen(FLineColor1,FLineStyle1,FLineWidth1);
    Canvas.MoveTo(t-1,Y1[t-1]);
    Canvas.LineTo(t,Y1[t]);
    ConfigPen(FLineColor2,FLineStyle2,FLineWidth2);
    Canvas.MoveTo(t-1,Y2[t-1]);
    Canvas.LineTo(t,Y2[t]);
  end;
end;

procedure TDCurve.DrawLine3(t: integer; yy1, yy2, yy3: double);
var
  j1,j2,j3:integer;
begin
  case (FAxis) of
   aTop:begin
    j1:=Round(yy1*Height/(FRangeMaxY1-FRangeMinY1));
    j2:=Round(yy2*Height/(FRangeMaxY2-FRangeMinY2));
    j3:=Round(yy3*Height/(FRangeMaxY3-FRangeMinY3));
   end;
   aMid:begin
    Y0:=Round(0.5*Height);
    j1:=Y0-Round(yy1*Height/(FRangeMaxY1-FRangeMinY1));
    j2:=Y0-Round(yy2*Height/(FRangeMaxY2-FRangeMinY2));
    j3:=Y0-Round(yy3*Height/(FRangeMaxY3-FRangeMinY3));
   end;
   aBottom:begin
    j1:=Height-Round(yy1*Height/(FRangeMaxY1-FRangeMinY1));
    j2:=Height-Round(yy2*Height/(FRangeMaxY2-FRangeMinY2));
    j3:=Height-Round(yy3*Height/(FRangeMaxY3-FRangeMinY3));
   end;
  end;
  if t=Cir*Width then			//如果成立则说明曲线已显示到最左边
  begin
    Count:=0;				//为重画曲线计数用
    Cir:=Cir+1;			//计数器加1
    Y1[t mod Width]:=j1;
    Y2[t mod Width]:=j2;
    Y3[t mod Width]:=j3;
    Invalidate();			//重画窗口
    end else
    begin
    inc(Count);
    t:=t-(Cir-1)*Width;
    Y1[t mod Width]:=j1;
    Y2[t mod Width]:=j2;
    Y3[t mod Width]:=j3;
    if (t=1) then exit;
    ConfigPen(FLineColor1,FLineStyle1,FLineWidth1);
    Canvas.MoveTo(t-1,Y1[t-1]);
    Canvas.LineTo(t,Y1[t]);
    ConfigPen(FLineColor2,FLineStyle2,FLineWidth2);
    Canvas.MoveTo(t-1,Y2[t-1]);
    Canvas.LineTo(t,Y2[t]);
    ConfigPen(FLineColor3,FLineStyle3,FLineWidth3);
    Canvas.MoveTo(t-1,Y3[t-1]);
    Canvas.LineTo(t,Y3[t]);
  end;
end;

procedure TDCurve.Paint;
var
  i:word;
  Temp:double;
begin
  inherited Paint();						//绘矩形的画笔配置
  ConfigPen(clBlack, psSolid,1);
  Canvas.Rectangle(0,0,Width,Height);	//配置刻度
  for i:=1 to FWidthNumber-1 do
  begin
    temp:=i*(FRangeMaxT-FRangeMinT)/FWidthNumber+FRangeMinT;
    Scale_x[i]:=Format('%5.0f', [temp]);
  end;
  for i:=1 to FHeightNumber-1 do
  begin
    temp:=FRangeMinY1+i*(FRangeMaxY1-FRangeMinY1)/FHeightNumber;
    Scale_y[i]:=Format('%5.0f', [temp]);
  end;
  if (FGrid=true) then					//绘网格线画笔配置
  begin
    Canvas.Pen.Color:=clGray;
    Canvas.Pen.Width:=0;
    Canvas.Pen.Style:=psDot;
   //划竖线
    for i:=1 to FWidthNumber-1 do
    begin
      Canvas.TextOut(X0+Round(i*Width/FWidthNumber),Height-15,Scale_x[i]);
      Canvas.MoveTo(X0+Round(i*Width/FWidthNumber),0);
      Canvas.LineTo(X0+Round(i*Width/FWidthNumber),Height);
    end;
  //划横线
    for i:=1 to FHeightNumber-1 do
    begin
      Canvas.TextOut(X0,Round(i*Height/FHeightNumber),
      Scale_y[FheightNumber-i]);
      Canvas.MoveTo(X0,Round(i*Height/FHeightNumber));
      Canvas.LineTo(X0+Width,Round(i*Height/FHeightNumber));
    end;
  end;
  Canvas.TextOut(5,2,FTitleY);
  Canvas.TextOut(Width-7*Length(FTitleX)-5,Height-30,FTitleX);
  case FCurveNumber of
  One:  ReDrawLine1;
  Two:  ReDrawLine2;
  Three: ReDrawLine3;
  end;
end;


procedure TDCurve.PSetAxis(AAxis: TPlace);
begin
  FAxis:=AAxis;
  case (FAxis) of
   aTop: Y0:=0;
   aMid: Y0:=Round(0.5*Height);
   aBottom: Y0:=Height;
  end;
end;

procedure TDCurve.PSetCurveNum(Num: TCurveNumber);
begin
  FCurveNumber:=Num;
end;

procedure TDCurve.PSetGrid(AGrid: boolean);
begin
  FGrid:=AGrid;
  Paint();
end;

procedure TDCurve.PSetRangeY(MaxY1, MaxY2, MaxY3, MinY1, MinY2,MinY3: integer);
begin
  FRangeMaxY1:=MaxY1;
  FRangeMaxY2:=MaxY2;
  FRangeMaxY3:=MaxY3;
  FRangeMinY1:=MinY1;
  FRangeMinY2:=MinY2;
  FRangeMinY3:=MinY3;
end;

procedure TDCurve.ReDrawLine1;
var
  i:integer;
begin
  Canvas.Pen.Width:=FLineWidth1;
  Canvas.Pen.Color:=FLineColor1;
  for i:=2 to Count do
  begin
    Canvas.MoveTo(i-1,Y1[i-1]);
    Canvas.LineTo(i,Y1[i]);
  end;
end;

procedure TDCurve.ReDrawLine2;
var
  i:word;
begin
  for i:=2  to Count do
  begin
    Canvas.Pen.Width:=FLineWidth1;
    Canvas.Pen.Color:=FLineColor1;
    Canvas.MoveTo(i-1,Y1[i-1]);
    Canvas.LineTo(i,Y1[i]);
    Canvas.Pen.Width:=FLineWidth2;
    Canvas.Pen.Color:=FLineColor2;
    Canvas.MoveTo(i-1,Y2[i-1]);
    Canvas.LineTo(i,Y2[i]);
  end;
end;

procedure TDCurve.ReDrawLine3;
var
  i:word;
begin
  for i:=2  to Count do
  begin
    Canvas.Pen.Width:=FLineWidth1;
    Canvas.Pen.Color:=FLineColor1;
    Canvas.MoveTo(i-1,Y1[i-1]);
    Canvas.LineTo(i,Y1[i]);
    Canvas.Pen.Width:=FLineWidth2;
    Canvas.Pen.Color:=FLineColor2;
    Canvas.MoveTo(i-1,Y2[i-1]);
    Canvas.LineTo(i,Y2[i]);
    Canvas.Pen.Width:=FLineWidth3;
    Canvas.Pen.Color:=FLineColor3;
    Canvas.MoveTo(i-1,Y3[i-1]);
    Canvas.LineTo(i,Y3[i]);
  end;
end;

procedure TDCurve.SetAxis(AAxis: TPlace);
begin
  FAxis:=AAxis;
  case (FAxis) of
   aTop: Y0:=0;
   aMid:Y0:=Round(0.5*Height);
   aBottom :Y0:=Height;
  end;
end;

procedure TDCurve.SetGrid(AGrid: boolean);
begin
  FGrid:=AGrid;
end;

procedure TDCurve.SetHeightNumber(AHeightNumber: integer);
begin
  FHeightNumber:= AHeightNumber;
end;

procedure TDCurve.SetWidthNumber(AWidthNumber: integer);
begin
  FWidthNumber:= AWidthNumber;
end;

procedure TDCurve.WriteTitle(XT, YT: string);
begin
  TitleX:=XT;
  TitleY:=YT;
  Canvas.TextOut(5,2,FTitleY);
  Canvas.TextOut(Width- 7*Length(FTitleX)-5 ,Height-30,FTitleX);
end;

end.