rm_chart.pas

中小企业管理系统------ ERP系统原代码

{*****************************************}
{                                         }
{         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_Class, RM_DsgCtrls,
  TeeProcs, TeEngine, Chart, Series
{$IFDEF TeeChartPro}
  , EditChar
{$ENDIF}
{$IFDEF Delphi6}
  , Variants
{$ENDIF};

const
  rmptMetafile = 0;
  rmptBitmap = 1;

  flChartUseChartSetting = $2;

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

  TRMChartOptions = packed record
    ChartType: Byte;
    ShowMarks, Colored: Boolean;
    MarksStyle: Byte;
    Top10Num: Integer;
    Reserved: array[0..35] of Byte;
  end;

  TRMChartSeries = class
  private
    FLegendObj, FValueObj, FLabelObj, FTop10Label: string;
    FTitle: string;
    FColor: TColor;
  protected
  public
    ChartOptions: TRMChartOptions;
    constructor Create;
    property LegendObj: string read FLegendObj write FLegendObj;
    property ValueObj: string read FValueObj write FValueObj;
    property LabelObj: string read FLabelObj write FLabelObj;
    property Top10Label: string read FTop10Label write FTop10Label;
    property Title: string read FTitle write FTitle;
    property Color: TColor read FColor write FColor;
  end;

  {TRMChartView}
  TRMChartView = class(TRMView)
  private
    FPrintType: Byte;
    FChart: TChart;
    FPicture: TMetafile;
    FList: TList;

    function GetUseChartSetting: Boolean;
    procedure SetUseChartSetting(Value: Boolean);
    function ShowChart: Boolean;
    procedure ChartEditor(Sender: TObject);
    procedure LegendFontEditor(Sender: TObject);
    function GetSeries(Index: Integer): TRMChartSeries;
  protected
    function GetViewCommon: string; override;
    procedure SetPropValue(Index: string; Value: Variant); override;
    function GetPropValue(Index: string): Variant; override;
    procedure Init; override;
  public
    ChartDim3D, ChartShowLegend, ChartShowAxis: Boolean;
    constructor Create; override;
    destructor Destroy; override;
    procedure Clear;
    function SeriesCount: Integer;
    function AddSeries: TRMChartSeries;
    procedure DeleteSeries(Index: Integer);

    procedure Draw(aCanvas: TCanvas); override;
    procedure StreamOut(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefinePopupMenu(Popup: TPopupMenu); override;
    procedure DefineProperties; override;
    procedure OnHook(View: TRmView); override;
    procedure ShowEditor; override;
    procedure AssignChart(AChart: TCustomChart);
    property Chart: TChart read FChart;
    property Series[Index: Integer]: TRMChartSeries read GetSeries;
    property PrintType: Byte read FPrintType write FPrintType;
    property PUseChartSetting: Boolean read GetUseChartSetting write SetUseChartSetting;
  end;

  { TRMChartForm }
  TRMChartForm = class(TForm)
    Page1: TPageControl;
    Tab1: TTabSheet;
    GroupBox1: TGroupBox;
    Tab2: TTabSheet;
    btnOk: TButton;
    btnCancel: TButton;
    GroupBox3: TGroupBox;
    chkSeriesMultiColor: TCheckBox;
    chkSeriesShowMarks: TCheckBox;
    Tab3: TTabSheet;
    GroupBox4: TGroupBox;
    RB1: TRadioButton;
    RB2: TRadioButton;
    RB3: TRadioButton;
    RB4: TRadioButton;
    RB5: TRadioButton;
    SB1: TSpeedButton;
    SB4: TSpeedButton;
    SB2: TSpeedButton;
    SB6: TSpeedButton;
    SB5: TSpeedButton;
    SB3: TSpeedButton;
    TabSheet1: TTabSheet;
    ListBox1: TListBox;
    GroupBox6: TGroupBox;
    chkChartShowLegend: TCheckBox;
    chkChartShowAxis: TCheckBox;
    PopupMenu1: TPopupMenu;
    Add1: TMenuItem;
    Delete1: TMenuItem;
    chkChartDim3D: TCheckBox;
    EditTitle1: TMenuItem;
    N1: TMenuItem;
    MoveUp1: TMenuItem;
    MoveDown1: TMenuItem;
    SB7: TSpeedButton;
    SB8: TSpeedButton;
    SB9: TSpeedButton;
    SB11: TSpeedButton;
    SB10: TSpeedButton;
    GroupBox5: TGroupBox;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    editTop10Num: TEdit;
    edtTop10Label: TEdit;
    GroupBox2: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    edtLegendObj: TEdit;
    edtValueObj: TEdit;
    Button1: TButton;
    Label6: TLabel;
    edtLabelObj: TEdit;
    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);
  private
    { Private declarations }
    FChartView: TRMChartView;
    FSeries: TRMChartSeries;
    FBtnColor: TRMColorPickerButton;

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

implementation

{$IFDEF TeeChart}
uses Math, RM_Intrp, RM_Utils, RM_Const, RM_Const1, RM_CmpReg, TeeShape, ArrowCha,
  GanttCh, BubbleCh;

{$R *.DFM}

type
  THackView = class(TRMView)
  end;

  TSeriesClass = class of TChartSeries;

const
  ChartTypes: array[0..10] of TSeriesClass =
  (TLineSeries, TAreaSeries, TPointSeries, TBarSeries, THorizBarSeries, TPieSeries,
    TChartShape, TFastLineSeries, TArrowSeries, TGanttSeries, TBubbleSeries);

function RMExtractFieldName(const Fields: string; var Pos: Integer): string;
var
  i: Integer;
begin
  i := Pos;
  while (i <= Length(Fields)) and (Fields[i] <> ';') do Inc(i);
  Result := Copy(Fields, Pos, i - Pos);
  if (i <= Length(Fields)) and (Fields[i] = ';') then Inc(i);
  Pos := i;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}

constructor TRMChartSeries.Create;
begin
  inherited Create;
  with ChartOptions do
  begin
    Colored := True;
  end;
  FValueObj := '';
  FLegendObj := '';
  FTop10Label := '';
  FTitle := '';
  FColor := clTeeColor;
end;

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

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

  ChartDim3D := True;
  ChartShowLegend := True;
  FPrintType := 0;

  FPicture := TMetafile.Create;
  BaseName := 'Chart';
  Flags := Flags or flWantHook;
  PUseChartSetting := False;

  FList := TList.Create;

  RMConsts['laBottom'] := laBottom;
  RMConsts['laTop'] := laTop;
  RMConsts['laLeft'] := laLeft;
  RMConsts['laRight'] := laRight;
end;

destructor TRMChartView.Destroy;
begin
  if RMDialogForm <> nil then
    FChart.Free;
  FPicture.Free;
  Clear;
  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
  liSeries: TRMChartSeries;

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

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

procedure TRMChartView.DeleteSeries(Index: Integer);
begin
  if 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 < FList.Count then
    Result := TRMChartSeries(FList[Index]);
end;

procedure TRMChartView.DefineProperties;
begin
  inherited DefineProperties;
  AddProperty('Chart', [RMdtHasEditor, RMdtOneObject], ChartEditor);
  AddEnumProperty('PrintType', 'ptMetafile;ptBitmap', [0, 1], nil);
  AddProperty('LeftAxisFormat', [rmdtString], nil);
  AddProperty('LeftAxisIncrement', [rmdtFloat], nil);
  AddProperty('LeftAxisMax', [rmdtFloat], nil);
  AddProperty('LeftAxisMin', [rmdtFloat], nil);
  AddProperty('LeftAxisAuto', [rmdtBoolean], nil);
  AddProperty('LeftAxisAutoMax', [rmdtBoolean], nil);
  AddProperty('LeftAxisAutoMin', [rmdtBoolean], nil);

  AddProperty('BottomAxisFormat', [rmdtString], nil);
  AddProperty('BottomAxisIncrement', [rmdtFloat], nil);
  AddProperty('BottomAxisMax', [rmdtFloat], nil);
  AddProperty('BottomAxisMin', [rmdtFloat], nil);
  AddProperty('BottomAxisAuto', [rmdtBoolean], nil);
  AddProperty('BottomAxisAutoMax', [rmdtBoolean], nil);
  AddProperty('BottomAxisAutoMin', [rmdtBoolean], nil);

  AddProperty('LegendVisible', [rmdtBoolean], nil);
  AddProperty('LegendFont', [rmdtHasEditor], LegendFontEditor);
  AddEnumProperty('LegendPosition', 'laBottom; laLeft; laRight; laTop',
    [laBottom, laLeft, laRight, laTop], nil);

  AddProperty('UseChartSetting', [rmdtBoolean], nil);

  AddProperty('OnBeforePrint', [RMdtHasEditor, RMdtOneObject], RMScript_BeforePrintEditor);
  AddProperty('OnAfterPrint', [RMdtHasEditor, RMdtOneObject], RMScript_AfterPrintEditor);
end;

procedure TRMChartView.SetPropValue(Index: string; Value: Variant);
begin
  inherited SetPropValue(Index, Value);
  Index := AnsiUpperCase(Index);
  if Index = 'PRINTTYPE' then
    FPrintType := Value
  else if Index = 'LEFTAXISFORMAT' then
    FChart.LeftAxis.AxisValuesFormat := Value
  else if Index = 'LEFTAXISINCREMENT' then
    FChart.LeftAxis.Increment := Value
  else if Index = 'LEFTAXISMAX' then
    FChart.LeftAxis.Maximum := Max(Value, FChart.LeftAxis.Minimum)
  else if Index = 'LEFTAXISMIN' then
    FChart.LeftAxis.Minimum := Min(Value, FChart.LeftAxis.Maximum)
  else if Index = 'LEFTAXISAUTO' then
    FChart.LeftAxis.Automatic := Value
  else if Index = 'LEFTAXISAUTOMAX' then
    FChart.LeftAxis.AutomaticMaximum := Value
  else if Index = 'LEFTAXISAUTOMIN' then
    FChart.LeftAxis.AutomaticMinimum := Value
  else if Index = 'BOTTOMAXISFORMAT' then
    FChart.BottomAxis.AxisValuesFormat := Value
  else if Index = 'BOTTOMAXISINCREMENT' then
    FChart.BottomAxis.Increment := Value
  else if Index = 'BOTTOMAXISMAX' then
    FChart.BottomAxis.Maximum := Max(Value, FChart.BottomAxis.Minimum)
  else if Index = 'BOTTOMAXISMIN' then
    FChart.BottomAxis.Minimum := Min(Value, FChart.BottomAxis.Maximum)
  else if Index = 'BOTTOMAXISAUTO' then
    FChart.BottomAxis.Automatic := Value
  else if Index = 'BOTTOMAXISAUTOMAX' then
    FChart.BottomAxis.AutomaticMaximum := Value
  else if Index = 'BOTTOMAXISAUTOMIN' then
    FChart.BottomAxis.AutomaticMinimum := Value
  else if Index = 'LEGENDPOSITION' then
    FChart.Legend.Alignment := Value
  else if Index = 'LEGENDVISIBLE' then
    ChartShowLegend := Value
  else if Index = 'USECHARTSETTING' then
    PUseChartSetting := Value
end;

function TRMChartView.GetPropValue(Index: string): Variant;
begin
  Index := AnsiUpperCase(Index);
  Result := inherited GetPropValue(Index);
  if Result <> Null then Exit;
  if Index = 'PRINTTYPE' then
    Result := FPrintType
  else if Index = 'LEFTAXISFORMAT' then
    Result := FChart.LeftAxis.AxisValuesFormat
  else if Index = 'LEFTAXISINCREMENT' then
    Result := FChart.LeftAxis.Increment
  else if Index = 'LEFTAXISMAX' then
    Result := FChart.LeftAxis.Maximum
  else if Index = 'LEFTAXISMIN' then
    Result := FChart.LeftAxis.Minimum
  else if Index = 'LEFTAXISAUTO' then
    Result := FChart.LeftAxis.Automatic
  else if Index = 'LEFTAXISAUTOMAX' then
    Result := FChart.LeftAxis.AutomaticMaximum
  else if Index = 'LEFTAXISAUTOMIN' then
    Result := FChart.LeftAxis.AutomaticMinimum
  else if Index = 'BOTTOMAXISFORMAT' then
    Result := FChart.BottomAxis.AxisValuesFormat
  else if Index = 'BOTTOMAXISINCREMENT' then
    Result := FChart.BottomAxis.Increment
  else if Index = 'BOTTOMAXISMAX' then
    Result := FChart.BottomAxis.Maximum
  else if Index = 'BOTTOMAXISMIN' then
    Result := FChart.BottomAxis.Minimum
  else if Index = 'BOTTOMAXISAUTO' then
    Result := FChart.BottomAxis.Automatic
  else if Index = 'BOTTOMAXISAUTOMAX' then
    Result := FChart.BottomAxis.AutomaticMaximum
  else if Index = 'BOTTOMAXISAUTOMIN' then
    Result := FChart.BottomAxis.AutomaticMinimum
  else if Index = 'LEGENDPOSITION' then
    Result := FChart.Legend.Alignment
  else if Index = 'LEGENDVISIBLE' then
    Result := ChartShowLegend
  else if Index = 'USECHARTSETTING' then
    Result := PUseChartSetting
end;

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

function TRMChartView.ShowChart: Boolean;
var