rm_chart.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,438 行 · 第 1/3 页

{*****************************************}
{                                         }
{         Report Machine v2.0             }
{           Chart Add-In Object           }
{                                         }
{*****************************************}

unit RM_Chart;

interface

{$I RM.inc}

{$IFDEF TeeChart}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, ComCtrls, Menus, Buttons, RM_Common, RM_Class, RM_Ctrls,
  TeeProcs, TeEngine, Chart, Series
{$IFDEF USE_INTERNAL_JVCL}, rm_JvInterpreter{$ELSE}, JvInterpreter{$ENDIF}
{$IFDEF Delphi6}
  , Variants, ImgList
{$ENDIF};

type

  TRMChartObject = class(TComponent) // fake component
  end;

  TRMChartSeries = class
  private
    FLegendView, FValueView, FLabelView, FTop10Label: string;
    FTitle: string;
    FColor: TColor;
    FChartType: Byte;
    FShowMarks, FColored: Boolean;
    FMarksStyle: Byte;
    FTop10Num: Integer;
  protected
  public
    constructor Create;
  published
    property LegendView: string read FLegendView write FLegendView;
    property ValueView: string read FValueView write FValueView;
    property LabelView: string read FLabelView write FLabelView;
    property Top10Label: string read FTop10Label write FTop10Label;
    property Title: string read FTitle write FTitle;
    property Color: TColor read FColor write FColor;
    property ChartType: Byte read FChartType write FChartType;
    property ShowMarks: Boolean read FShowMarks write FShowMarks;
    property Colored: Boolean read FColored write FColored;
    property MarksStyle: Byte read FMarksStyle write FMarksStyle;
    property Top10Num: Integer read FTop10Num write FTop10Num;
  end;

  {TRMChartView}
  TRMChartView = class(TRMReportView)
  private
    FPrintType: TRMPrintMethodType;
    FChart: TChart;
    FPicture: TMetafile;
    FList: TList;
    FChartDim3D, FChartShowLegend, FChartShowAxis: Boolean;
    FSaveMemo: string;

    function GetUseChartSetting: Boolean;
    procedure SetUseChartSetting(Value: Boolean);
    procedure ShowChart;
    function GetSeries(Index: Integer): TRMChartSeries;
    function GetDirectDraw: Boolean;
    procedure SetDirectDraw(Value: Boolean);
  protected
    procedure Prepare; override;
    procedure PlaceOnEndPage(aStream: TStream); override;
    function GetViewCommon: string; override;
    procedure ClearContents; override;
    function GetPropValue(aObject: TObject; aPropName: string; var aValue: Variant;
      Args: array of Variant): Boolean; override;
    procedure OnHook(aView: TRmView); override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Clear;
    function SeriesCount: Integer;
    function AddSeries: TRMChartSeries;
    procedure DeleteSeries(Index: Integer);

    procedure Draw(aCanvas: TCanvas); override;
    procedure LoadFromStream(aStream: TStream); override;
    procedure SaveToStream(aStream: TStream); override;
    procedure DefinePopupMenu(Popup: TRMCustomMenuItem); override;
    procedure ShowEditor; override;
    procedure AssignChart(AChart: TCustomChart);
    property Series[Index: Integer]: TRMChartSeries read GetSeries;
    property Chart: TChart read FChart;
  published
    property PrintType: TRMPrintMethodType read FPrintType write FPrintType;
    property UseChartSetting: Boolean read GetUseChartSetting write SetUseChartSetting;
    property UseDoublePass;
    property Memo;
    property ChartDim3D: Boolean read FChartDim3D write FChartDim3D;
    property ChartShowLegend: Boolean read FChartShowLegend write FChartShowLegend;
    property ChartShowAxis: Boolean read FChartShowAxis write FChartShowAxis;
    property ReprintOnOverFlow;
    property ShiftWith;
    property BandAlign;
    property LeftFrame;
    property RightFrame;
    property TopFrame;
    property BottomFrame;
    property FillColor;
    property DirectDraw: Boolean read GetDirectDraw write SetDirectDraw;
    property PrintFrame;
    property Printable;
  end;

  { TRMChartForm }
  TRMChartForm = class(TForm)
    Page1: TPageControl;
    Tab1: TTabSheet;
    gpbSeriesType: TGroupBox;
    Tab2: TTabSheet;
    btnOk: TButton;
    btnCancel: TButton;
    gpbSeriesOptions: TGroupBox;
    chkSeriesMultiColor: TCheckBox;
    chkSeriesShowMarks: TCheckBox;
    Tab3: TTabSheet;
    gpbMarks: TGroupBox;
    rdbStyle1: TRadioButton;
    rdbStyle2: TRadioButton;
    rdbStyle3: TRadioButton;
    rdbStyle4: TRadioButton;
    rdbStyle5: TRadioButton;
    TabSheet1: TTabSheet;
    ListBox1: TListBox;
    gpbChartOptions: TGroupBox;
    chkChartShowLegend: TCheckBox;
    chkChartShowAxis: TCheckBox;
    PopupMenu1: TPopupMenu;
    Add1: TMenuItem;
    Delete1: TMenuItem;
    chkChartDim3D: TCheckBox;
    EditTitle1: TMenuItem;
    N1: TMenuItem;
    MoveUp1: TMenuItem;
    MoveDown1: TMenuItem;
    gpbTopGroup: TGroupBox;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    editTop10Num: TEdit;
    edtTop10Label: TEdit;
    gpbObjects: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    Button1: TButton;
    Label6: TLabel;
    ImageList1: TImageList;
    cmbSeriesType: TComboBox;
    cmbLegend: TComboBox;
    cmbValue: TComboBox;
    cmbLabel: TComboBox;
    procedure FormCreate(Sender: TObject);
    procedure Add1Click(Sender: TObject);
    procedure Delete1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure PopupMenu1Popup(Sender: TObject);
    procedure MoveUp1Click(Sender: TObject);
    procedure MoveDown1Click(Sender: TObject);
    procedure btnOkClick(Sender: TObject);
    procedure EditTitle1Click(Sender: TObject);
    procedure chkSeriesMultiColorClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure cmbSeriesTypeDrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
  private
    { Private declarations }
    FChartView: TRMChartView;
    FSeries: TRMChartSeries;
    FBtnColor: TRMColorPickerButton;

    procedure Localize;
    procedure LoadSeriesOptions;
    procedure SaveSeriesOptions;
  public
    { Public declarations }
  end;

  TRMCustomTeeChartUIClass = class of TRMCustomTeeChartUI;

  TRMCustomTeeChartUI = class
  public
    class procedure Edit(aTeeChart: TCustomChart); virtual;
  end;

  {TRMTeeChartUIPlugIn }
  TRMTeeChartUIPlugIn = class
  private
    class function GetChartUIClass(aTeeChart: TCustomChart): TRMCustomTeeChartUIClass;
  public
    class procedure Register(aChartUIClass: TRMCustomTeeChartUIClass);
    class procedure UnRegister(aChartUIClass: TRMCustomTeeChartUIClass);
    class procedure Edit(aTeeChart: TCustomChart);
  end; {class, TRMTeeChartUIPlugIn}
{$ENDIF}

implementation

{$IFDEF TeeChart}
uses Math, RM_Utils, RM_Const, RM_Const1, RMInterpreter_Chart;

{$R *.DFM}

const
  flChartUseChartSetting = $2;
  flChartDirectDraw = $4;

type
  THackPage = class(TRMCustomPage)
  end;

  THackView = class(TRMView)
  end;

  TSeriesClass = class of TChartSeries;

const
  ChartTypes: array[0..5] of TSeriesClass =
  (TLineSeries, TAreaSeries, TPointSeries, TBarSeries, THorizBarSeries, TPieSeries);

var
  uChartUIClassList: TList;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMChartSeries }

constructor TRMChartSeries.Create;
begin
  inherited Create;

  FColored := True;
  FValueView := '';
  FLegendView := '';
  FTop10Label := '';
  FTop10Num := 0;
  FTitle := '';
  FColor := clTeeColor;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMChartView }

constructor TRMChartView.Create;
begin
  inherited Create;
  BaseName := 'Chart';
  WantHook := True;
  UseChartSetting := False;

  FChart := TChart.Create(RMDialogForm);
  with FChart do
  begin
    Parent := RMDialogForm;
    Visible := False;
    BevelInner := bvNone;
    BevelOuter := bvNone;
  end;

  FChartDim3D := True;
  FChartShowLegend := True;
  FPrintType := rmptMetafile;

  FPicture := TMetafile.Create;
  FList := TList.Create;
end;

destructor TRMChartView.Destroy;
begin
  Clear;
  if RMDialogForm <> nil then
  begin
    FreeAndNil(FChart);
  end;
  FPicture.Free;
  FList.Free;
  inherited Destroy;
end;

procedure TRMChartView.Clear;
begin
  while FList.Count > 0 do
  begin
    TRMChartSeries(FList[0]).Free;
    FList.Delete(0);
  end;
end;

function TRMChartView.SeriesCount: Integer;
begin
  Result := FList.Count;
end;

function TRMChartView.AddSeries: TRMChartSeries;
var
  lSeries: TRMChartSeries;

  procedure _SetSeriesTitle;
  var
    i, j: Integer;
    listr: string;
    liFlag: Boolean;
  begin
    for i := 1 to 9999 do
    begin
      listr := 'Series' + IntToStr(i);
      liFlag := True;
      for j := 0 to FList.Count - 1 do
      begin
        if AnsiCompareText(Series[j].Title, listr) = 0 then
        begin
          liFlag := False;
          Break;
        end;
      end;

      if liFlag then
      begin
        lSeries.Title := listr;
        Break;
      end;
    end;
  end;

begin
  lSeries := TRMChartSeries.Create;
  _SetSeriesTitle;
  FList.Add(lSeries);
  Result := lSeries;
end;

procedure TRMChartView.DeleteSeries(Index: Integer);
begin
  if (Index >= 0) and (Index < FList.Count) then
  begin
    TRMChartSeries(FList[Index]).Free;
    FList.Delete(Index);
  end;
end;

function TRMChartView.GetSeries(Index: Integer): TRMChartSeries;
begin
  Result := nil;
  if (Index >= 0) and (Index < FList.Count) then
    Result := TRMChartSeries(FList[Index]);
end;

procedure TRMChartView.AssignChart(AChart: TCustomChart);
var
  lSeries: TChartSeries;
  liSeriesClass: TChartSeriesClass;
  i: Integer;
begin
  Clear;
  FChart.RemoveAllSeries;
  FChart.Assign(AChart);
  for i := 0 to AChart.SeriesCount - 1 do
  begin
    liSeriesClass := TChartSeriesClass(AChart.Series[i].ClassType);
    lSeries := liSeriesClass.Create(FChart);
    lSeries.Assign(aChart.Series[i]);
    FChart.AddSeries(lSeries);
  end;

  FChart.Name := '';
  for i := 0 to FChart.SeriesList.Count - 1 do
    FChart.SeriesList[i].Name := '';
  Memo.Clear;
  FPicture.Clear;
end;

procedure TRMChartView.ShowChart;
var
  i: Integer;
  lMetafile: TMetafile;
  lBitmap: TBitmap;
  liChartSeries: TRMChartSeries;
  liFlag: Boolean;
  liLegends, liValues, liLabels: TStringList;

  function _ExtractStr(const aStr: string; var aPos: Integer): string;
  var
    i: Integer;
  begin
    i := aPos;
    while (i <= Length(aStr)) and (aStr[i] <> ';') do
      Inc(i);

    Result := Copy(aStr, aPos, i - aPos);
    if (i <= Length(aStr)) and (aStr[i] = ';') then
      Inc(i);

    aPos := i;
  end;

  procedure _SetChartProp;
  begin
    FChart.View3D := ChartDim3D;
    FChart.Legend.Visible := ChartShowLegend;
    FChart.AxisVisible := ChartShowAxis;
    if not UseChartSetting then
    begin
      FChart.RemoveAllSeries;
      FChart.Frame.Visible := False;
      FChart.LeftWall.Brush.Style := bsClear;
      FChart.BottomWall.Brush.Style := bsClear;

      FChart.Legend.Font.Charset := rmCharset;
      FChart.BottomAxis.LabelsFont.Charset := rmCharset;
      FChart.LeftAxis.LabelsFont.Charset := rmCharset;
      FChart.TopAxis.LabelsFont.Charset := rmCharset;
      FChart.BottomAxis.LabelsFont.Charset := rmCharset;
{$IFDEF Delphi4}
      FChart.BackWall.Brush.Style := bsClear;
      FChart.View3DOptions.Elevation := 315;
      FChart.View3DOptions.Rotation := 360;
{$ENDIF}
    end;
  end;

  procedure _PaintChart;
  var
    SaveDx, SaveDy: Integer;
  begin
    if FillColor = clNone then
      Chart.Color := clWhite
    else
      Chart.Color := FillColor;

    SaveDX := RMToScreenPixels(mmSaveWidth, rmutMMThousandths);
    SaveDY := RMToScreenPixels(mmSaveHeight, rmutMMThousandths);
    case FPrintType of
      rmptMetafile:
        begin
          lMetafile := Chart.TeeCreateMetafile(True {False}, Rect(0, 0, SaveDX, SaveDY));
          try
            RMPrintGraphic(Canvas, RealRect, lMetafile, IsPrinting, DirectDraw, False);
          finally
            lMetafile.Free;
          end;
        end;
      rmptBitmap:
        begin
          lBitmap := TBitmap.Create;
          try
            lBitmap.Width := SaveDX;
            lBitmap.Height := SaveDY;
            Chart.Draw(lBitmap.Canvas, Rect(0, 0, SaveDX, SaveDY));
            RMPrintGraphic(Canvas, RealRect, lBitmap, IsPrinting, DirectDraw, False);
          finally
            lBitmap.Free;
          end;
        end;
    end;
  end;

  function _StrToFloat(s: string): Double;
  begin
    s := RMDeleteNoNumberChar(s);
    Result := 0;
    try
      Result := StrToFloat(s);
    except
    end;
  end;