dbchart.pas

来自「Delphi TeeChartPro.6.01的源代码」· PAS 代码 · 共 1,041 行 · 第 1/2 页

{******************************************}
{ TDBChart Component                       }
{ Copyright (c) 1995-2003 by David Berneda }
{ All rights Reserved                      }
{******************************************}
unit DBChart;
{$I TeeDefs.inc}

interface

uses
  {$IFNDEF LINUX}
  Windows, Messages,
  {$ENDIF}
  SysUtils, Classes,
  {$IFDEF CLX}
  QGraphics, QControls, QMenus, QForms, QDialogs, QExtCtrls, QStdCtrls,
  {$ELSE}
  Graphics, Controls, Menus, Forms, Dialogs, ExtCtrls, StdCtrls,
  {$ENDIF}
  Chart, DB, TeeProcs, TeCanvas, TeEngine;

type
  DBChartException=class(Exception);

  TTeeDBGroup=(dgHour,dgDay,dgWeek,dgWeekDay,dgMonth,dgQuarter,dgYear,dgNone);

  TListOfDataSources=class(TList)
  private
    procedure Put(Index:Integer; Value:TDataSource);
    function Get(Index:Integer):TDataSource;
  public
    Procedure Clear; override;
    property DataSource[Index:Integer]:TDataSource read Get write Put; default;
  end;

  TCustomDBChart=class;

  TProcessRecordEvent=Procedure(Sender:TCustomDBChart; DataSet:TDataSet) of object;

  TCustomDBChart = class(TCustomChart)
  private
    FAutoRefresh     : Boolean;
    FRefreshInterval : Integer;
    FShowGlassCursor : Boolean;
    FOnProcessRecord : TProcessRecordEvent;
    { internal }
    IUpdating        : Boolean;
    ITimer           : TTimer;
    IDataSources     : TListOfDataSources;
    Procedure DataSourceCheckDataSet(ADataSet:TDataSet);
    Procedure DataSourceCloseDataSet(ADataSet:TDataSet);
    Procedure CheckDataSet(ADataSet:TDataSet; ASeries:TChartSeries=nil);
    Procedure CheckNewDataSource(ADataSet:TDataSet; SingleRow:Boolean);
    Procedure SetRefreshInterval(Value:Integer);
    Procedure CheckTimer;
    Procedure OnRefreshTimer(Sender:TObject);
  protected
    procedure RemovedDataSource( ASeries: TChartSeries;
                                 AComponent: TComponent ); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    Procedure Assign(Source:TPersistent); override;
    Procedure CheckDatasource(ASeries:TChartSeries); override;
    Function IsValidDataSource(ASeries:TChartSeries; AComponent:TComponent):Boolean; override;

    Procedure FillValueSourceItems( AValueList:TChartValueList; Proc:TGetStrProc); override;
    Procedure FillSeriesSourceItems( ASeries:TChartSeries; Proc:TGetStrProc); override;

    Procedure RefreshDataSet(ADataSet:TDataSet; ASeries:TChartSeries);
    Procedure RefreshData;
    { properties }
    property AutoRefresh:Boolean read FAutoRefresh write FAutoRefresh default True;
    property RefreshInterval:Integer read FRefreshInterval write SetRefreshInterval default 0;
    property ShowGlassCursor:Boolean read FShowGlassCursor write FShowGlassCursor default True;
    { events }
    property OnProcessRecord:TProcessRecordEvent read FOnProcessRecord
                                                 write FOnProcessRecord;
  published
  end;

  TDBChart=class(TCustomDBChart)
  published
    { TCustomDBChart properties }
    property AutoRefresh;
    property RefreshInterval;
    property ShowGlassCursor;
    { TCustomDBChart events }
    property OnProcessRecord;

    { TCustomChart Properties }
    property AllowPanning;
    property BackImage;
    property BackImageInside;
    property BackImageMode;
    property BackImageTransp;
    property BackWall;
    property Border;
    property BorderRound;
    property BottomWall;
    property Foot;
    property Gradient;
    property LeftWall;
    property MarginBottom;
    property MarginLeft;
    property MarginRight;
    property MarginTop;
    property MarginUnits;
    property PrintProportional;
    property RightWall;
    property SubFoot;
    property SubTitle;
    property Title;

    { TCustomChart Events }
    property OnAllowScroll;
    property OnClickAxis;
    property OnClickBackground;
    property OnClickLegend;
    property OnClickSeries;
    property OnClickTitle;
    property OnGetLegendPos;
    property OnGetLegendRect;
    property OnScroll;
    property OnUndoZoom;
    property OnZoom;

    { TCustomAxisPanel properties }
    property AxisBehind;
    property AxisVisible;
    property BottomAxis;
    property Chart3DPercent;
    property ClipPoints;
    property CustomAxes;
    property DepthAxis;
    property Frame;
    property LeftAxis;
    property Legend;
    property MaxPointsPerPage;
    property Monochrome;
    property Page;
    property RightAxis;
    property ScaleLastPage;
    property SeriesList;
    property Shadow;
    property TopAxis;
    property View3D;
    property View3DOptions;
    property View3DWalls;
    property Zoom;

    { TCustomAxisPanel events }
    property OnAfterDraw;
    property OnBeforeDrawAxes;
    property OnBeforeDrawChart;
    property OnBeforeDrawSeries;
    property OnGetAxisLabel;
    property OnGetLegendText;
    property OnGetNextAxisLabel;
    property OnPageChange;

    { TPanel properties }
    property Align;
    property BevelInner;
    property BevelOuter;
    property BevelWidth;

    {$IFDEF CLX}
    property Bitmap;
    {$ENDIF}

    property BorderWidth;
    property Color;
    {$IFNDEF CLX}
    property DragCursor;
    {$ENDIF}
    property DragMode;
    property Enabled;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property Anchors;
    {$IFNDEF CLX}
    property AutoSize;
    {$ENDIF}
    property Constraints;
    {$IFNDEF CLX}
    property DragKind;
    property Locked;
    {$ENDIF}

    { TPanel events }
    property OnClick;
    {$IFDEF D5}
    property OnContextPopup;
    {$ENDIF}
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnStartDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnResize;
    {$IFNDEF CLX}
    property OnCanResize;
    {$ENDIF}
    property OnConstrainedResize;
    {$IFNDEF CLX}
    property OnDockDrop;
    property OnDockOver;
    property OnEndDock;
    property OnGetSiteInfo;
    property OnStartDock;
    property OnUnDock;
    {$ENDIF}

    {$IFDEF K3}
    property OnMouseEnter;
    property OnMouseLeave;
    {$ENDIF}
  end;

  TTeeFieldType=(tftNumber,tftDateTime,tftText,tftNone);

{ given a VCL "database field type", this function returns
  a more simplified "type": (number, date, text) }
Function TeeFieldType(AType:TFieldType):TTeeFieldType;

{ Returns the ISO- Week number (from 1 to 52) of a given "ADate" parameter,
  and decrements "Year" if it's the first week of the year. }
Function DateToWeek(ADate:TDateTime; Var Year:Word):Integer;

{ same as DateToWeek, using a different algorithm
  (compatible with TeeChart version 4 }
Function DateToWeekOld(Const ADate:TDateTime; Var Year:Word):Integer;

{ internal, used by DBChart Summary feature }
Function TeeGetDBPart(Num:Integer; St:String):String;
Function StrToDBGroup(St:String):TTeeDBGroup;
Function StrToDBOrder(St:String):TChartListOrder;

type
  TCheckDataSetEvent=procedure(DataSet:TDataSet) of object;

  TDBChartDataSource=class(TDataSource)
  private
    FDBChart   : TCustomDBChart;
    FWasActive : Boolean;
    Procedure DataSourceRowChange(Sender:TObject; Field:TField);
    Procedure DataSourceStateChange(Sender:TObject);
    Procedure DataSourceUpdateData(Sender:TObject);
  protected
    OnCheckDataSet : TCheckDataSetEvent;
    OnCloseDataSet : TCheckDataSetEvent;
    Procedure SetDataSet(Value:TDataSet; SingleRow:Boolean=False);
  end;

Procedure FillDataSetFields(DataSet:TDataSet; Proc:TGetStrProc);

implementation

Uses TeeConst, TypInfo;


{ TDBChartDataSource }
Procedure TDBChartDataSource.SetDataSet(Value:TDataSet; SingleRow:Boolean=False);
Begin
  DataSet:=Value;
  FWasActive:=DataSet.Active;

  OnStateChange:=DataSourceStateChange;
  OnUpdateData:=DataSourceUpdateData;
  if SingleRow then OnDataChange:=DataSourceRowChange;
end;

Procedure TDBChartDataSource.DataSourceRowChange(Sender:TObject; Field:TField);
begin
  if Assigned(FDBChart) then
     if not FDBChart.IUpdating then
        With TDBChartDataSource(Sender) do OnCheckDataSet(DataSet);
end;

Procedure TDBChartDataSource.DataSourceUpdateData(Sender:TObject);
Begin
  With TDBChartDataSource(Sender) do
  if State=dsBrowse then OnCheckDataSet(DataSet)
                    else FWasActive:=False;
End;

Procedure TDBChartDataSource.DataSourceStateChange(Sender:TObject);
Begin
  With TDBChartDataSource(Sender) do
  if State=dsInactive then
  Begin
    FWasActive:=False;
    if Assigned(OnCloseDataSet) then OnCloseDataSet(DataSet);
  end
  else
  if (State=dsBrowse) and (not FWasActive) then
  Begin
    OnCheckDataSet(DataSet);
    FWasActive:=True;
  end;
end;

{ TListOfDataSources }
Procedure TListOfDataSources.Clear;
var t : Integer;
begin
  for t:=0 to Count-1 do DataSource[t].Free;
  inherited;
end;

procedure TListOfDataSources.Put(Index:Integer; Value:TDataSource);
begin
  inherited Items[Index]:=Value;
end;

function TListOfDataSources.Get(Index:Integer):TDataSource;
begin
  result:=TDataSource(inherited Items[Index]);
end;

{ TDBChart }
Constructor TCustomDBChart.Create(AOwner: TComponent);
begin
  inherited;
  IDataSources:=TListOfDataSources.Create;
  FAutoRefresh:=True;
  FShowGlassCursor:=True;
  ITimer:=nil;
  IUpdating:=False;
end;

Destructor TCustomDBChart.Destroy;
begin
  ITimer.Free;
  IDataSources.Free;
  inherited;
end;

procedure TCustomDBChart.RemovedDataSource( ASeries: TChartSeries;
                                            AComponent: TComponent );
var t   : Integer;
    tmp : TDataSet;
begin
  inherited;
  if AComponent is TDataSet then
  for t:=0 to IDataSources.Count-1 do
  begin
    tmp:=IDataSources[t].DataSet;
    if (not Assigned(tmp)) or (tmp=AComponent) then
    begin
      IDataSources[t].Free;
      IDataSources.Delete(t);
      break;
    end;
  end;
end;

Procedure TCustomDBChart.CheckTimer;
Begin
  if Assigned(ITimer) then ITimer.Enabled:=False;
  if (FRefreshInterval>0) and (not (csDesigning in ComponentState) ) then
  Begin
    if not Assigned(ITimer) then
    Begin
      ITimer:=TTimer.Create(Self);
      ITimer.Enabled:=False;
      ITimer.OnTimer:=OnRefreshTimer;
    end;
    ITimer.Interval:=FRefreshInterval*1000;
    ITimer.Enabled:=True;
  end;
End;

Procedure TCustomDBChart.OnRefreshTimer(Sender:TObject);
var t : Integer;
Begin
  ITimer.Enabled:=False;  { no try..finally here ! }
  for t:=0 to IDataSources.Count-1 do
  With IDataSources[t] do
  if DataSet.Active then
  Begin
    DataSet.Refresh;
    CheckDataSet(DataSet);
  end;
  ITimer.Enabled:=True;
end;

Procedure TCustomDBChart.SetRefreshInterval(Value:Integer);
Begin
  if (Value<0) or (Value>60) then
     Raise DBChartException.Create(TeeMsg_RefreshInterval);
  FRefreshInterval:=Value;
  CheckTimer;
End;

Function TCustomDBChart.IsValidDataSource(ASeries:TChartSeries; AComponent:TComponent):Boolean;
Begin
  result:=inherited IsValidDataSource(ASeries,AComponent);
  if not Result then result:=(AComponent is TDataSet) or (AComponent is TDataSource);
end;

Procedure TCustomDBChart.CheckNewDataSource(ADataSet:TDataSet; SingleRow:Boolean);
Var tmpDataSource : TDBChartDataSource;
Begin
  if IDataSources.IndexOf(ADataSet)=-1 then
  begin
    tmpDataSource:=TDBChartDataSource.Create(nil); { 5.02 }
    With tmpDataSource do
    begin
      SetDataSet(ADataSet,SingleRow);
      OnCheckDataSet:=DataSourceCheckDataSet;
      OnCloseDataSet:=DataSourceCloseDataSet;
    end;
    IDataSources.Add(tmpDataSource);
  end;
end;

Procedure TCustomDBChart.CheckDatasource(ASeries:TChartSeries);
Begin
  if Assigned(ASeries) then
  With ASeries do
    if ParentChart=Self then
    Begin
      if Assigned(DataSource) then
      Begin
        ASeries.Clear;
        if DataSource is TDataSet then
        Begin
          CheckNewDataSource(TDataSet(DataSource),False);
          CheckDataSet(TDataSet(DataSource),ASeries);
        end
        else
        if (DataSource is TDataSource) and Assigned(TDataSource(DataSource).DataSet) then
        begin
          CheckNewDataSource(TDataSource(DataSource).DataSet,True);
          CheckDataSet(TDataSource(DataSource).DataSet,ASeries);
        end
        else inherited;
      end
      else inherited;
    end
    else Raise ChartException.Create(TeeMsg_SeriesParentNoSelf);
end;

Procedure TCustomDBChart.CheckDataSet(ADataSet:TDataSet; ASeries:TChartSeries=nil);
Begin
  if FAutoRefresh then RefreshDataSet(ADataSet,ASeries);
end;

Procedure TCustomDBChart.DataSourceCheckDataSet(ADataSet:TDataSet);
begin
  CheckDataSet(ADataSet);
end;

Procedure TCustomDBChart.DataSourceCloseDataSet(ADataSet:TDataSet);
var t : Integer;
begin
  if FAutoRefresh then
     for t:=0 to SeriesCount-1 do
         if Series[t].DataSource=ADataSet then Series[t].Clear;
end;

type TValueListAccess=class(TChartValueList);

     TDBChartAgg=(dcaNone, dcaSum, dcaCount, dcaHigh, dcaLow, dcaAverage);
     TDBChartSeries=packed record
        ASeries     : TChartSeries;
        YManda      : Boolean;
        MandaList   : TChartValueList;
        LabelSort   : TChartListOrder;
        LabelField  : TField;
        ColorField  : TField;
        MandaField  : TField;
        NumFields   : Integer;
        GroupPrefix : TTeeDBGroup;
        AggPrefix   : TDBChartAgg;
     end;

     TDBChartSeriesList=Array of TDBChartSeries;

Procedure TCustomDBChart.RefreshDataSet(ADataSet:TDataSet; ASeries:TChartSeries);
Var HasAnyDataSet : Boolean;

  Procedure ProcessRecord(const tmpSeries:TDBChartSeries);
  var tmpxLabel : String;
      tmpColor  : TColor;
      tmpNotMand: Double;
      tmpMand   : Double;

    Procedure AddToSeries(const DestSeries:TDBChartSeries);
    Var t        : Integer;
        tmpIndex : Integer;
    begin
      With DestSeries do
      if AggPrefix<>dcaNone then
      begin
        tmpIndex:=ASeries.Labels.IndexOfLabel(tmpXLabel);

        if tmpIndex=-1 then { new point }
        begin
          if AggPrefix=dcaCount then tmpMand:=1
          else
          if AggPrefix=dcaAverage then tmpColor:=1;