mychart.pas

水晶 ? ?报表 ? ? ? ?源码

(*
    迷你曲线图表类（2005-3-9）
*)
unit MyChart;

interface

uses
  Windows,SysUtils, Classes, Controls,Graphics,ExtCtrls,Math;

type
  TLabelType=(ltNumber,ltTime);//坐标类型
  TMyChart = class(TGraphicControl)
  private
    { Private declarations }
    SelectPoints:Array[0..4] of TPoint;//选择区域
    FLineColor:TColor;//表线颜色
    FCoordColor:TColor;//坐标轴颜色
    FGridColor:TColor;//网格颜色
    FBackColor:TColor;//背景颜色
    FSelLineColor:TColor;//选择线颜色
    MDown:Boolean;//鼠标选中
    SelectStart:Boolean;//鼠标选中开始
    FLeftPixs:Integer;//左边距
    FTopPixs:Integer;//上边距
    FBottomPixs:Integer;//下边距
    FRightPixs:Integer;//右边距
    FCellWidth:Integer;//单元格宽度
    FCellHeight:Integer;//单元格高度
    BaseX:Double;//X方向位移
    BaseY:Double;//Y方向位移
    OffsetX1:Integer;//绘图区域开始-X
    OffsetX2:Integer;//绘图区域结束-X
    OffsetY1:Integer;//绘图区域开始-Y
    OffsetY2:Integer;//绘图区域结束-Y
    ScaleX:Double;//X-放大系数
    ScaleY:Double;//Y-放大系数
    internalCanvas:TCanvas;//内部画布
    internalBitmap:TBitmap;
    internalWidth:Integer;//绘图区域宽度
    internalHeight:Integer;//绘图区域高度
    FLabelType: TLabelType;//坐标类型
    internalRgn:HRGN;
    FCoordFontColor: TColor;//坐标刻度颜色

    procedure SetLineColor(const Value: TColor);
    procedure SetCoordColor(const Value: TColor);
    procedure SetGridColor(const Value: TColor);
    procedure SetBackColor(const Value: TColor);
    procedure SetSelLineColor(const Value: TColor);
    procedure SetBottomPixs(const Value: Integer);
    procedure SetCellHeight(const Value: Integer);
    procedure SetCellWidth(const Value: Integer);
    procedure SetLeftPixs(const Value: Integer);
    procedure SetRightPixs(const Value: Integer);
    procedure SetTopPixs(const Value: Integer);
    procedure FMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
    procedure FMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
    procedure FMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
    procedure ZoomRect;
    procedure DrawGrid;
    procedure DrawCoord;
    procedure DoResize(Sender: TObject);
    procedure Clear;
    procedure DrawLine;

    property Canvas;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    procedure SetLabelType(const Value: TLabelType);
    procedure SetCoordFontColor(const Value: TColor);
  protected
    { Protected declarations }
    procedure Paint;override;
  public
    { Public declarations }
    Points:Array[0..12,0..2047] of TPoint;
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;
    procedure ReDraw;
  published
    { Published declarations }
    property Align;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property LabelType:TLabelType read FLabelType write SetLabelType;
    property LineColor:TColor read FLineColor write SetLineColor default clYellow;
    property CoordColor:TColor read FCoordColor write SetCoordColor default clWhite;
    property GridColor:TColor read FGridColor write SetGridColor default clSilver;
    property BackColor:TColor read FBackColor write SetBackColor default clBlack;
    property SelLineColor:TColor read FSelLineColor write SetSelLineColor default clWhite;
    property CoordFontColor:TColor read FCoordFontColor write SetCoordFontColor default clWhite;
    property TopPixs:Integer read FTopPixs write SetTopPixs default 10;
    property LeftPixs:Integer read FLeftPixs write SetLeftPixs default 10;
    property BottomPixs:Integer read FBottomPixs write SetBottomPixs default 30;
    property RightPixs:Integer read FRightPixs write SetRightPixs default 10;
    property CellWidth:Integer read FCellWidth write SetCellWidth default 40;
    property CellHeight:Integer read FCellHeight write SetCellHeight default 30;
  end;
implementation

{ TMyChart }

procedure TMyChart.Clear;//清除背景
begin
  with internalCanvas do
  begin
    Brush.Color:=FBackColor;
    FillRect(ClientRect);
  end;
  DrawCoord;//绘制坐标系
end;

constructor TMyChart.Create(AOwner: TComponent);
var
  i:Integer;
begin
  inherited Create(AOwner);
  internalBitmap:=TBitmap.Create;
  internalCanvas:=internalBitmap.Canvas;
  ControlStyle := ControlStyle + [csReplicatable];
  FLineColor:=clYellow;
  FGridColor:=clSilver;
  FCoordColor:=clWhite;
  FCoordFontColor:=clWhite;  
  FBackColor:=clBlack;
  FSelLineColor:=clWhite;
  MDown:=False;
  Height:=100;
  Width:=100;
  FTopPixs:=10;
  FLeftPixs:=10;
  FBottomPixs:=30;
  FRightPixs:=10;
  FCellWidth:=40;
  FCellHeight:=30;
  ScaleX:=1;
  ScaleY:=1;
  BaseX:=0;
  BaseY:=0;
  internalWidth:=Width-FLeftPixs-FRightPixs;
  internalHeight:=Height-FTopPixs-FBottomPixs;
  OffsetX2:=internalWidth;
  OffsetX1:=0;
  OffsetY2:=internalHeight;
  OffsetY1:=0;
  
  OnMouseDown:=FMouseDown;
  OnMouseMove:=FMouseMove;
  OnMouseUp:=FMouseUp;
  OnResize:=DoResize;
  for i:=0 to 2047 do
  begin
    Points[0,i].X:=i+FLeftPixs;
    Points[0,i].Y:=i Mod 100;
  end;
end;

destructor TMyChart.Destroy;
begin
  inherited;
  DeleteObject(internalRgn);  
  internalBitmap.Free;
end;

procedure TMyChart.DrawCoord;
begin
  with internalCanvas do
  begin
    Pen.Color:=FCoordColor;
    Pen.Style:=psSolid;
    MoveTo(FLeftPixs,FTopPixs);
    LineTo(FLeftPixs,Height-FBottomPixs);
    LineTo(Width-FRightPixs,Height-FBottomPixs);
  end;
  DrawGrid;
end;

procedure TMyChart.DrawGrid;
const
  YLabelFormatStr='%d';
  XLabelFormatStr='%d';
var
  tx,ty:Integer;
  sx,sy,CoordX,CoordY:Double;
  CoordXLabel,CoordYLabel:String;
begin
  with internalCanvas do
  begin
    Pen.Style:=psDot;
    Pen.Color:=FGridColor;
    sy:=(OffsetY2-OffsetY1)/(internalHeight/FCellHeight);
    CoordY:=OffsetY1;
    CoordYLabel:=Format(YLabelFormatStr,[Round(CoordY)]);
    TextOut(FLeftPixs-TextWidth(CoordYLabel),Height-FBottomPixs-13,CoordYLabel);
    ty:=Height-FBottomPixs-FCellHeight;
    while ty>=FTopPixs do
    begin
      MoveTo(FLeftPixs,ty);
      LineTo(Width-FRightPixs,ty);
      CoordY:=CoordY+sy;
      CoordYLabel:=Format(YLabelFormatStr,[Round(CoordY)]);
      TextOut(FLeftPixs-TextWidth(CoordYLabel),ty-13,CoordYLabel);
      Dec(ty,FCellHeight);
    end;
    sx:=(OffsetX2-OffsetX1)*FCellWidth/internalWidth;
    CoordX:=OffsetX1;
    CoordXLabel:=Format(XLabelFormatStr,[Round(CoordX)]);
    TextOut(FLeftPixs-TextWidth(CoordXLabel) shr 1,Height-FBottomPixs+1,CoordXLabel);
    tx:=FLeftPixs+FCellWidth;
    while tx<=InternalWidth+FLeftPixs do
    begin
      MoveTo(tx,FTopPixs);
      LineTo(tx,Height-FBottomPixs);
      CoordX:=CoordX+sx;
      CoordXLabel:=Format(XLabelFormatStr,[Round(CoordX)]);
      TextOut(tx-TextWidth(CoordXLabel) shr 1,Height-FBottomPixs+1,CoordXLabel);
      Inc(tx,FCellWidth);
    end;
  end;
end;

procedure TMyChart.DrawLine;
var
  tx:Integer;
begin
  with internalCanvas do
  begin
    SelectClipRgn(Handle,internalRgn);
    Pen.Style:=psSolid;
    Pen.Color:=FLineColor;
    if (ScaleX<>1) or (ScaleY<>1) then
    begin
      MoveTo(Round((Points[0,OffsetX1].X-FLeftPixs)*ScaleX-BaseX+FLeftPixs),Round((internalHeight-Points[0,OffsetX1].Y)*ScaleY-BaseY)+FTopPixs);
      for tx:=OffsetX1+1 to OffsetX2 do
      begin
        LineTo(Round((Points[0,tx].X-FLeftPixs)*ScaleX-BaseX+FLeftPixs),Round((internalHeight-Points[0,tx].Y)*ScaleY-BaseY)+FTopPixs);
      end;
    end
    else
    begin
      MoveTo(Points[0,OffsetX1].X,internalHeight-Points[0,OffsetX1].Y+FTopPixs);
      for tx:=OffsetX1+1 to OffsetX2 do
      begin
        LineTo(Points[0,tx].X,internalHeight-Points[0,tx].Y+FTopPixs);
      end;
    end;
  end;
  with Canvas do
  begin
    CopyRect(ClientRect,internalCanvas,ClientRect);
    if MDown and (not SelectStart)then
    begin
      Pen.Color:=FSelLineColor;
      Pen.Mode:=pmXOR;
      PolyLine(SelectPoints);
      Pen.Mode:=pmCopy;
    end;
  end;
end;



procedure TMyChart.FMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if mbLeft in [Button] then
  begin
    SelectPoints[0].X:=X;
    SelectPoints[0].Y:=Y;
    SelectPoints[1].Y:=Y;
    SelectPoints[3].X:=X;
    SelectPoints[4].X:=X;
    SelectPoints[4].Y:=Y;
    SelectStart:=True;
    MDown:=True;
  end;
end;
procedure TMyChart.FMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if MDown then
  begin
    with Canvas do
    begin
      Pen.Mode:=pmXOR;
      Pen.Style:=psSolid;
      Pen.Color:=FSelLineColor;
      if not SelectStart then
      begin
        PolyLine(SelectPoints);
      end;
      SelectPoints[1].X:=X;
      SelectPoints[2].X:=X;
      SelectPoints[2].Y:=Y;
      SelectPoints[3].Y:=Y;
      PolyLine(SelectPoints);
      Pen.Mode:=pmCopy;
      SelectStart:=False;
    end;
  end;
end;

procedure TMyChart.FMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  MDown:=False;
  if not SelectStart then
  begin
    with Canvas do
    begin
      Pen.Color:=FSelLineColor;
      Pen.Style:=psSolid;
      Pen.Mode:=pmXOR;
      PolyLine(SelectPoints);
      Pen.Mode:=pmCopy;
    end;
    ZoomRect;
  end;
end;


procedure TMyChart.Paint;
begin
  if (internalBitmap.Width<>Width) or (internalBitmap.Height<>Height) then
  begin
    internalBitmap.Width:=Width;
    internalBitmap.Height:=Height;
    DeleteObject(internalRgn);
    internalRgn:=CreateRectRgn(FLeftPixs,FTopPixs,Width-FRightPixs+1,Height-FBottomPixs+1);
    internalBitmap.Canvas.Font.Height:=-13;
    internalBitmap.Canvas.Font.Color:=FCoordFontColor;
  end;
  internalWidth:=Width-FLeftPixs-FRightPixs;
  internalHeight:=Height-FTopPixs-FBottomPixs;
  if ScaleX=1 then
  begin
    OffsetX2:=internalWidth;
  end;
  if ScaleY=1 then
  begin
    OffsetY2:=internalHeight;
  end;
  ReDraw;
  if csDesigning in ComponentState then
  begin
  	with Canvas do
	  begin
	    Pen.Style := psDash;
  	  Brush.Style := bsClear;
	    Rectangle(0, 0, Width, Height);
  	end;
  end;
end;

procedure TMyChart.SetBackColor(const Value: TColor);
begin
  if  FBackColor <> Value then
  begin
    FBackColor := Value;
    ReDraw;
  end;
end;

procedure TMyChart.SetBottomPixs(const Value: Integer);
begin
  if  FBottomPixs <> Value then
  begin
    FBottomPixs := Value;
    internalHeight:=Height-FTopPixs-FBottomPixs;
    ReDraw;
  end;
end;

procedure TMyChart.SetCellHeight(const Value: Integer);
begin
  if FCellHeight<>Value then
  begin
    if Value<9 then
      FCellHeight :=9
    else
      FCellHeight := Value;
    ReDraw;
  end;
end;

procedure TMyChart.SetCellWidth(const Value: Integer);
begin
  if FCellWidth<>Value then
  begin
    if Value<12 then
      FCellWidth :=12
    else
      FCellWidth := Value;
    ReDraw;
  end;
end;

procedure TMyChart.SetCoordColor(const Value: TColor);
begin
  if FCoordColor <> Value then
  begin
    FCoordColor := Value;
    ReDraw;
  end;
end;


procedure TMyChart.SetGridColor(const Value: TColor);
begin
  if FGridColor <> Value then
  begin
    FGridColor := Value;
    ReDraw;
  end;
end;

procedure TMyChart.SetLeftPixs(const Value: Integer);
var
  i:Integer;
begin
  if  FLeftPixs <> Value then
  begin
    FLeftPixs := Value;
    internalWidth:=Width-FLeftPixs-FRightPixs;
    for i:=0 to 2047 do
    begin
      Points[0,i].X:=i+FLeftPixs;
    end;
    ReDraw;
  end;
end;

procedure TMyChart.SetLineColor(const Value: TColor);
begin
  if  FLineColor <> Value then
  begin
    FLineColor := Value;
    ReDraw;
  end;
end;


procedure TMyChart.SetRightPixs(const Value: Integer);
var
  i:Integer;
begin
  if  FRightPixs <> Value then
  begin
    FRightPixs := Value;
    internalWidth:=Width-FLeftPixs-FRightPixs;
    for i:=0 to 2047 do
    begin
      Points[0,i].X:=i+FLeftPixs;
    end;
    ReDraw;
  end;
end;

procedure TMyChart.SetSelLineColor(const Value: TColor);
begin
  if FSelLineColor <> Value then
  begin
    FSelLineColor := Value;
    ReDraw;
  end;
end;

procedure TMyChart.SetTopPixs(const Value: Integer);
begin
  if FTopPixs <> Value then
  begin
    FTopPixs := Value;
    internalHeight:=Height-FTopPixs-FBottomPixs;
    ReDraw;
  end;
end;

procedure TMyChart.ZoomRect;
var
  wx,wy:Integer;
  sy,sx:Double;
begin
    wx:=(SelectPoints[2].X-SelectPoints[0].X);
    wy:=(SelectPoints[2].Y-SelectPoints[0].Y);
    if (wx<>0) and (wy<>0) then
    begin
      if (wx<0) or (wy<0) then
      begin
        ScaleX:=1;
        ScaleY:=1;
        BaseX:=0;
        BaseY:=0;
        OffsetX2:=internalWidth;
        OffsetX1:=0;
        OffsetY2:=internalHeight;
        OffsetY1:=0;
      end
      else
      begin
        OffsetX1:=Floor((SelectPoints[0].X-FLeftPixs+BaseX)/ScaleX);
        OffsetX2:=Round((SelectPoints[2].X-FLeftPixs+BaseX)/ScaleX);
        OffsetY2:=internalHeight-Floor((SelectPoints[0].Y-FTopPixs+BaseY)/ScaleY);
        OffsetY1:=internalHeight-Round((SelectPoints[2].Y-FTopPixs+BaseY)/ScaleY);
        sx:=internalWidth/wx;
        sy:=internalHeight/wy;
        ScaleX:=ScaleX*sx;
        ScaleY:=ScaleY*sy;
        BaseX:=(SelectPoints[0].X-FLeftPixs+BaseX)*sx;
        BaseY:=(SelectPoints[0].Y-FTopPixs+BaseY)*sy;
      end;
      ReDraw;
    end;
end;

procedure TMyChart.DoResize(Sender: TObject);
begin
end;

procedure TMyChart.SetLabelType(const Value: TLabelType);
begin
  FLabelType := Value;
end;

{ TLabelTypeProperty }


procedure TMyChart.ReDraw;
begin
  Clear;
  DrawLine;
end;

procedure TMyChart.SetCoordFontColor(const Value: TColor);
begin
  if FCoordFontColor <> Value then
  begin
    FCoordFontColor := Value;
    internalCanvas.Font.Color:=FCoordFontColor;
    ReDraw;
  end;
end;

end.