frxchart.pas

报表控件。FastReport 是非常强大的报表控件

{******************************************}
{                                          }
{             FastReport v3.0              }
{         TeeChart Add-In Object           }
{                                          }
{         Copyright (c) 1998-2006          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxChart;

interface

{$I frx.inc}
{$I tee.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Menus, Controls,
{$IFDEF FR_COM}
  FastReport_TLB, ComObj,
{$ENDIF}
  frxClass,
  TeeProcs, TeEngine, Chart, Series, TeCanvas
{$IFDEF Delphi6}
, Variants
{$ENDIF};


type
  TfrxChartObject = class(TComponent);  // fake component

  TfrxSeriesDataType = (dtDBData, dtBandData, dtFixedData);
  TfrxSeriesSortOrder = (soNone, soAscending, soDescending);
  TfrxSeriesXType = (xtText, xtNumber, xtDate);
  TSeriesClass = class of TChartSeries;
  TfrxChartSeries = (csLine, csArea, csPoint, csBar, csHorizBar,
    csPie, csGantt, csFastLine, csArrow, csBubble, csChartShape, csHorizArea,
    csHorizLine, csPolar, csRadar, csPolarBar, csGauge, csSmith, csPyramid,
    csDonut, csBezier, csCandle, csVolume, csPointFigure, csHistogram,
    csHorizHistogram, csErrorBar, csError, csHighLow, csFunnel, csBox,
    csHorizBox, csSurface, csContour, csWaterFall, csColorGrid, csVector3D,
    csTower, csTriSurface, csPoint3D, csBubble3D, csMyPoint, csBarJoin, csBar3D);


{$IFDEF FR_COM}
  TfrxSeriesItem = class(TCollectionItem, IfrxSeriesItem, IUnknown )
  private
    FRefCount: Integer;
    FSeries: TChartSeries;
{$ELSE}
  TfrxSeriesItem = class(TCollectionItem)
  private
{$ENDIF}
    FDataBand: TfrxDataBand;
    FDataSet: TfrxDataSet;
    FDataSetName: String;
    FDataType: TfrxSeriesDataType;
    FSortOrder: TfrxSeriesSortOrder;
    FTopN: Integer;
    FTopNCaption: String;
    FSource1: String;
    FSource2: String;
    FSource3: String;
    FSource4: String;
    FSource5: String;
    FSource6: String;
    FXType: TfrxSeriesXType;
    FValues1: String;
    FValues2: String;
    FValues3: String;
    FValues4: String;
    FValues5: String;
    FValues6: String;
    procedure FillSeries(Series: TChartSeries);
    procedure SetDataSet(const Value: TfrxDataSet);
    procedure SetDataSetName(const Value: String);
    function GetDataSetName: String;
{$IFDEF FR_COM}
    { IUnknown }
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    { IfrxSeriesItem }
    function Get_DataBand(out Value: IfrxDataBand): HResult; stdcall;
    function Set_DataBand(const Value: IfrxDataBand): HResult; stdcall;
    function Get_DataSet(out Value: IfrxDataSet): HResult; stdcall;
    function Set_DataSet(const Value: IfrxDataSet): HResult; stdcall;
    function Get_DataSetName(out Value: WideString): HResult; stdcall;
    function Set_DataSetName(const Value: WideString): HResult; stdcall;
    function Get_XSource(out Value: WideString): HResult; stdcall;
    function Set_XSource(const Value: WideString): HResult; stdcall;
    function Get_YSource(out Value: WideString): HResult; stdcall;
    function Set_YSource(const Value: WideString): HResult; stdcall;
    function Get_XValues(out Value: WideString): HResult; stdcall;
    function Set_XValues(const Value: WideString): HResult; stdcall;
    function Get_YValues(out Value: WideString): HResult; stdcall;
    function Set_YValues(const Value: WideString): HResult; stdcall;
    function Get_TopNCaption(out Value: WideString): HResult; stdcall;
    function Set_TopNCaption(const Value: WideString): HResult; stdcall;
    function Get_Title(out Value: WideString): HResult; stdcall;
    function Set_Title(const Value: WideString): HResult; stdcall;
    function Get_ZSource(out Value: WideString): HResult; stdcall;
    function Set_ZSource(const Value: WideString): HResult; stdcall;
    function Get_ZValues(out Value: WideString): HResult; stdcall;
    function Set_ZValues(const Value: WideString): HResult; stdcall;
    function Get_FourthSource(out Value: WideString): HResult; stdcall;
    function Set_FourthSource(const Value: WideString): HResult; stdcall;
    function Get_FourthValues(out Value: WideString): HResult; stdcall;
    function Set_FourthValues(const Value: WideString): HResult; stdcall;
    function Get_FifthSource(out Value: WideString): HResult; stdcall;
    function Set_FifthSource(const Value: WideString): HResult; stdcall;
    function Get_FifthValues(out Value: WideString): HResult; stdcall;
    function Set_FifthValues(const Value: WideString): HResult; stdcall;
    function Get_SixthSource(out Value: WideString): HResult; stdcall;
    function Set_SixthSource(const Value: WideString): HResult; stdcall;
    function Get_SixthValues(out Value: WideString): HResult; stdcall;
    function Set_SixthValues(const Value: WideString): HResult; stdcall;
    function Get_XAxisType(out Value: frxSeriesXType): HResult; stdcall;
    function Set_XAxisType(Value: frxSeriesXType): HResult; stdcall;
{$ENDIF}
  published
    property DataType: TfrxSeriesDataType read FDataType write FDataType;
    property DataBand: TfrxDataBand read FDataBand write FDataBand;
    property DataSet: TfrxDataSet read FDataSet write SetDataSet;
    property DataSetName: String read GetDataSetName write SetDataSetName;
    property SortOrder: TfrxSeriesSortOrder read FSortOrder write FSortOrder;
    property TopN: Integer read FTopN write FTopN;
    property TopNCaption: String read FTopNCaption write FTopNCaption;
    property XType: TfrxSeriesXType read FXType write FXType;

    { source expressions }
    property Source1: String read FSource1 write FSource1;
    property Source2: String read FSource2 write FSource2;
    property Source3: String read FSource3 write FSource3;
    property Source4: String read FSource4 write FSource4;
    property Source5: String read FSource5 write FSource5;
    property Source6: String read FSource6 write FSource6;

    { ready values. For internal use only. }
    property Values1: String read FValues1 write FValues1;
    property Values2: String read FValues2 write FValues2;
    property Values3: String read FValues3 write FValues3;
    property Values4: String read FValues4 write FValues4;
    property Values5: String read FValues5 write FValues5;
    property Values6: String read FValues6 write FValues6;

    { backward compatibility }
    property XSource: String read FSource1 write FSource1;
    property YSource: String read FSource2 write FSource2;
    property XValues: String read FValues1 write FValues1;
    property YValues: String read FValues2 write FValues2;
    {}
{$IFDEF FR_COM}
    property Series: TChartSeries read FSeries write FSeries;
{$ENDIF}
  end;

  TfrxSeriesData = class(TCollection)
  private
    FReport: TfrxReport;
    function GetSeries(Index: Integer): TfrxSeriesItem;
  public
    constructor Create(Report: TfrxReport);
    function Add: TfrxSeriesItem;
    property Items[Index: Integer]: TfrxSeriesItem read GetSeries; default;
  end;

{$IFDEF FR_COM}
  TfrxChartAxis = class(TAutoObject, IfrxChartAxis)
    FAxis:  TChartAxis;
  private
    function Get_Automatic(out Value: WordBool): HResult; stdcall;
    function Set_Automatic(Value: WordBool): HResult; stdcall;
    function Get_Minimum(out Value: Double): HResult; stdcall;
    function Set_Minimum(Value: Double): HResult; stdcall;
    function Get_Maximum(out Value: Double): HResult; stdcall;
    function Set_Maximum(Value: Double): HResult; stdcall;
    function Get_AutomaticMaximum(out Value: WordBool): HResult; stdcall;
    function Set_AutomaticMaximum(Value: WordBool): HResult; stdcall;
    function Get_AutomaticMinimum(out Value: WordBool): HResult; stdcall;
    function Set_AutomaticMinimum(Value: WordBool): HResult; stdcall;
    function Get_AxisValuesFormat(out Value: WideString): HResult; stdcall;
    function Set_AxisValuesFormat(const Value: WideString): HResult; stdcall;
    function Get_EndPosition(out Value: Double): HResult; stdcall;
    function Set_EndPosition(Value: Double): HResult; stdcall;
    function Get_Width(out Value: Integer): HResult; stdcall;
    function Set_Width(Value: Integer): HResult; stdcall;
    function Get_Color(out Value: Integer): HResult; stdcall;
    function Set_Color(Value: Integer): HResult; stdcall;
    function Get_Labels(out Value: WordBool): HResult; stdcall;
    function Set_Labels(Value: WordBool): HResult; stdcall;
    function Get_LabelsExponent(out Value: WordBool): HResult; stdcall;
    function Set_LabelsExponent(Value: WordBool): HResult; stdcall;
    function Get_LabelsSeparation(out Value: Integer): HResult; stdcall;
    function Set_LabelsSeparation(Value: Integer): HResult; stdcall;
    function Get_LabelStyle(out Value: Integer): HResult; stdcall;
    function Set_LabelStyle(Value: Integer): HResult; stdcall;
    function Get_Logarithmic(out Value: WordBool): HResult; stdcall;
    function Set_Logarithmic(Value: WordBool): HResult; stdcall;
  public
    constructor Create(Axis: TChartAxis);
  end;

  TfrxChartView = class(TfrxView, IfrxChartView)
  private
    FLeftAxis:  TfrxChartAxis;
    FBottomAxis:  TfrxChartAxis;
{$ELSE}
  TfrxChartView = class(TfrxView)
  private
{$ENDIF}
    FChart: TChart;
    FSeriesData: TfrxSeriesData;
    procedure CreateChart;
    procedure FillChart;
    procedure ReadData(Stream: TStream);
    procedure ReadData1(Reader: TReader);
    procedure ReadData2(Reader: TReader);
    procedure WriteData(Stream: TStream);
    procedure WriteData1(Writer: TWriter);
    procedure WriteData2(Writer: TWriter);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    {$IFDEF FR_COM}
    function GetSeriesItem(Index: Integer; out Value: IfrxSeriesItem): HResult; stdcall;
    function AddSeriesItem(Type_: frxSeriesType; out NewItem: IfrxSeriesItem): HResult; stdcall;
    function SeriesCount(out Value: Integer): HResult; stdcall;
    function Get_View3D(out Value: WordBool): HResult; stdcall;
    function Set_View3D(Value: WordBool): HResult; stdcall;
    function Get_View3dWalls(out Value: WordBool): HResult; stdcall;
    function Set_View3dWalls(Value: WordBool): HResult; stdcall;
    function Get_LeftAxis(out Value: IfrxChartAxis): HResult; stdcall;
    function Get_BottomAxis(out Value: IfrxChartAxis): HResult; stdcall;
    {$ENDIF}
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    class function GetDescription: String; override;
    procedure Draw(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended); override;
    procedure AfterPrint; override;
    procedure GetData; override;
    procedure BeforeStartReport; override;
    procedure OnNotify(Sender: TObject); override;
    procedure ClearSeries;
    procedure AddSeries(Series: TfrxChartSeries);

    property Chart: TChart read FChart;
    property SeriesData: TfrxSeriesData read FSeriesData;
  published
    property BrushStyle;
    property Color;
    property Cursor;
    property Frame;
    property TagStr;
    property URL;
  end;

implementation

uses
  frxChartHelpers, frxChartRTTI,
{$IFNDEF NO_EDITORS}
  frxChartEditor,
{$ENDIF}
  frxDsgnIntf, frxUtils, frxFormUtils, frxRes;


{ TfrxSeriesItem }

procedure TfrxSeriesItem.SetDataSet(const Value: TfrxDataSet);
begin
  FDataSet := Value;
  if FDataSet = nil then
    FDataSetName := '' else
    FDataSetName := FDataSet.UserName;
end;

procedure TfrxSeriesItem.SetDataSetName(const Value: String);
begin
  FDataSetName := Value;
  FDataSet := frxFindDataSet(FDataSet, FDataSetName,
    TfrxSeriesData(Collection).FReport);
end;

function TfrxSeriesItem.GetDataSetName: String;
begin
  if FDataSet = nil then
    Result := FDataSetName else
    Result := FDataSet.UserName;
end;

procedure TfrxSeriesItem.FillSeries(Series: TChartSeries);
var
  i: Integer;
  sl1, sl2, sl3, sl4, sl5, sl6: TStringList;
  v1, v2, v3, v4, v5, v6: String;
  Helper: TfrxSeriesHelper;

  procedure Sort;
  var
    i: Integer;
    sl: TStringList;
    s: String;
  begin
    if sl1.Count <> sl2.Count then exit;

    sl := TStringList.Create;
    sl.Sorted := True;
    sl.Duplicates := dupAccept;

    for i := 0 to sl2.Count - 1 do
    begin
      s := sl2[i];
      if not frxIsValidFloat(s) then
        s := '0';
      sl.Add(Format('%18.2f', [frxStrToFloat(s)]) + '=' + sl1[i]);
    end;

    sl1.Clear;
    sl2.Clear;
    if FSortOrder = soAscending then
      for i := 0 to sl.Count - 1 do
      begin
        sl1.Add(Trim(Copy(sl[i], Pos('=', sl[i]) + 1, 255)));
        sl2.Add(Trim(Copy(sl[i], 1, Pos('=', sl[i]) - 1)));
      end
    else
      for i := sl.Count - 1 downto 0 do
      begin
        sl1.Add(Trim(Copy(sl[i], Pos('=', sl[i]) + 1, 255)));
        sl2.Add(Trim(Copy(sl[i], 1, Pos('=', sl[i]) - 1)));
      end;

    sl.Free;
  end;

  procedure MakeTopN;
  var
    i: Integer;
    d: Double;
    sl: TStringList;
    s: String;
  begin
    if sl1.Count <> sl2.Count then exit;

    sl := TStringList.Create;
    sl.Sorted := True;
    sl.Duplicates := dupAccept;

    for i := 0 to sl2.Count - 1 do
    begin
      s := sl2[i];
      if not frxIsValidFloat(s) then
        s := '0';
      sl.Add(Format('%18.2f', [frxStrToFloat(s)]) + '=' + sl1[i]);
    end;

    sl1.Clear;
    sl2.Clear;
    for i := sl.Count - 1 downto sl.Count - FTopN do
    begin
      sl1.Add(Trim(Copy(sl[i], Pos('=', sl[i]) + 1, 255)));
      sl2.Add(Trim(Copy(sl[i], 1, Pos('=', sl[i]) - 1)));
    end;

    d := 0;
    for i := sl.Count - FTopN - 1 downto 0 do
      d := d + frxStrToFloat(Trim(Copy(sl[i], 1, Pos('=', sl[i]) - 1)));

    sl1.Add(FTopNCaption);
    sl2.Add(FloatToStr(d));

    sl.Free;
  end;

begin
  sl1 := TStringList.Create;
  sl2 := TStringList.Create;
  sl3 := TStringList.Create;
  sl4 := TStringList.Create;
  sl5 := TStringList.Create;
  sl6 := TStringList.Create;
  Series.Clear;

  v1 := FValues1;
  if (v1 <> '') and (v1[1] = ';') then
    Delete(v1, 1, 1);
  v2 := FValues2;
  if (v2 <> '') and (v2[1] = ';') then
    Delete(v2, 1, 1);
  v3 := FValues3;
  if (v3 <> '') and (v3[1] = ';') then
    Delete(v3, 1, 1);
  v4 := FValues4;
  if (v4 <> '') and (v4[1] = ';') then
    Delete(v4, 1, 1);
  v5 := FValues5;
  if (v5 <> '') and (v5[1] = ';') then
    Delete(v5, 1, 1);
  v6 := FValues6;
  if (v6 <> '') and (v6[1] = ';') then
    Delete(v6, 1, 1);

  frxSetCommaText(v1, sl1);
  frxSetCommaText(v2, sl2);
  frxSetCommaText(v3, sl3);
  frxSetCommaText(v4, sl4);
  frxSetCommaText(v5, sl5);
  frxSetCommaText(v6, sl6);