rm_chart.pas

这是一个功能强大

  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;
  FSeriesList := TList.Create;
end;

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

  FPicture.Free;
  FSeriesList.Free;
  inherited Destroy;
end;

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

function TRMChartView.SeriesCount: Integer;
begin
  Result := FSeriesList.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 FSeriesList.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;
  FSeriesList.Add(lSeries);
  Result := lSeries;
end;

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

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

procedure TRMChartView.AssignChart(AChart: TCustomChart);
var
  lSeries: TChartSeries;
  lSeriesClass: TChartSeriesClass;
  i: Integer;
begin
  Clear;
  FChart.RemoveAllSeries;
  FChart.Assign(AChart);
  for i := 0 to AChart.SeriesCount - 1 do
  begin
    if not aChart.SeriesList[i].Active then Continue;

    lSeriesClass := TChartSeriesClass(AChart.Series[i].ClassType);
    lSeries := lSeriesClass.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
  lChartSeries: TRMChartSeries;
  lXValues, lYValues: TStringList;

  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 COMPILER4_UP}
      FChart.BackWall.Brush.Style := bsClear;
      FChart.View3DOptions.Elevation := 315;
      FChart.View3DOptions.Rotation := 360;
{$ENDIF}
    end;
  end;

  procedure _PaintChart;
  var
    lSaveDx, lSaveDy: Integer;
    lMetafile: TMetafile;
    lBitmap: TBitmap;
  begin
    if FillColor = clNone then
      Chart.Color := clWhite
    else
      Chart.Color := FillColor;

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

  procedure _AddSeries(aIndex: Integer; aHaveLabel: Boolean);
  var
    i, lCount: Integer;
    lSeries: TChartSeries;

    procedure _SetSeriesType;
    begin
      if UseChartSetting or (aIndex < Chart.SeriesCount) then
        lSeries := Chart.SeriesList[aIndex]
      else
      begin
        lSeries := ChartTypes[lChartSeries.ChartType].Create(Chart);
        Chart.AddSeries(lSeries);

        lSeries.Title := lChartSeries.Title;
        lSeries.ColorEachPoint := lChartSeries.Colored;
        lSeries.Marks.Visible := lChartSeries.ShowMarks;
        lSeries.Marks.Style := TSeriesMarksStyle(lChartSeries.MarksStyle);
      end;

      lSeries.Clear;
      Chart.View3DWalls := lChartSeries.ChartType <> 5;
      lSeries.Marks.Font.Charset := rmCharset;
  {$IFDEF COMPILER4_UP}
      Chart.View3DOptions.Orthogonal := lChartSeries.ChartType <> 5;
  {$ENDIF}
    end;

  begin
    _SetSeriesType;
    lCount := Min(lXValues.Count, lYValues.Count);
    for i := 0 to lCount - 1 do
    begin
      if aHaveLabel then
      begin
        if lSeries.ColorEachPoint then
          lSeries.AddXY(StrToFloat(lXValues[i]), StrToFloat(lYValues[i]), '', clTeeColor)
        else
          lSeries.AddXY(RMStrToFloat(lXValues[i]), StrToFloat(lYValues[i]), '', lChartSeries.Color);
      end
      else
      begin
        if lSeries.ColorEachPoint then
          lSeries.Add(StrToFloat(lYValues[i]), lXValues[i], clTeeColor)
        else
          lSeries.Add(StrToFloat(lYValues[i]), lXValues[i], lChartSeries.Color);
      end;
    end;
  end;

  procedure _BuildSeries;
  var
    i, lPos: Integer;
    lXStr, lYStr: string;
    lFlag_NumberString: Boolean;
    lStr: string;
  begin
    if Memo.Count < FSeriesList.Count * 2 then Exit;

    for i := 0 to FSeriesList.Count - 1 do
    begin
      lXStr := Memo[i * 2];
      lYStr := Memo[i * 2 + 1];

      if (lXStr <> '') and (lXStr[Length(lXStr)] <> ';') then
        lXStr := lXStr + ';';
      if (lYStr <> '') and (lYStr[Length(lYStr)] <> ';') then
        lYStr := lYStr + ';';

      lXValues.Clear; lYValues.Clear;
      lFlag_NumberString := True;
      for lPos := 1 to Length(lXStr) do
      begin
        if not (lXStr[lPos] in ['-', ' ', ';', '.', '0'..'9']) then
        begin
          lFlag_NumberString := False;
          Break;
        end;
      end;

      lPos := 1;
      while lPos <= Length(lXStr) do
        lXValues.Add(_ExtractStr(lXStr, lPos));

      lPos := 1;
      while lPos <= Length(lYStr) do
      begin
        lStr := _ExtractStr(lYStr, lPos);
        if RMisNumeric(lStr) then
          lYValues.Add(SysUtils.Format('%12.3f', [RMStrToFloat(lStr)]))
        else
          lYValues.Add('0');
      end;

      lChartSeries := Series[i];
      _AddSeries(i, lFlag_NumberString);
    end;
  end;

begin
  if (FSeriesList.Count < 1) and (Memo.Count = 0) then
  begin
    if FPicture.Width = 0 then
      _PaintChart
    else
      Canvas.StretchDraw(RealRect, FPicture);

    Exit;
  end;

  lXValues := TStringList.Create;
  lYValues := TStringList.Create;
  try
    _SetChartProp;
    _BuildSeries;
    _PaintChart;
  finally
    lXValues.Free;
    lYValues.Free;
  end;
end;

procedure TRMChartView.Draw(aCanvas: TCanvas);
begin
  BeginDraw(aCanvas);
  Memo1.Assign(Memo);
  CalcGaps;
  ShowBackground;
  ShowChart;
  ShowFrame;
  RestoreCoord;
end;

procedure TRMChartView.PlaceOnEndPage(aStream: TStream);
var
  i: Integer;
begin
  inherited PlaceOnEndPage(aStream);
  Memo.Text := '';
  for i := 0 to FSeriesList.Count - 1 do
  begin
    Series[i].Init;
  end;
end;

procedure TRMChartView.GetEndPageData(aStream: TStream);
var
  i, j: Integer;
  lStr: string;
  lSeries: TRMChartSeries;
begin
  if UseDoublePass and (ParentReport.MasterReport.DoublePass and ParentReport.MasterReport.FinalPass) then
  begin
    Memo1.Text := FSaveMemo;
  end
  else
  begin
    for i := 0 to FSeriesList.Count - 1 do
    begin
      lSeries := Series[i];
      lSeries.GetData(ParentReport);
      lStr := '';
      for j := 0 to High(lSeries.FXValues) do
      begin
        if j > 0 then
          lStr := lStr + ';';

        lStr := lStr + string(lSeries.FXValues[j]);
      end;
      Memo1.Add(lStr);

      lStr := '';
      for j := 0 to High(lSeries.FYValues) do
      begin
        if j > 0 then
          lStr := lStr + ';';

        lStr := lStr + string(lSeries.FYValues[j]);
      end;
      Memo1.Add(lStr);
    end;
  end;
end;

procedure TRMChartView.LoadFromStream(aStream: TStream);
var
  lVersion: Integer;
  lType: Byte;
  lStream: TMemoryStream;
  i, lCount: Integer;
  lSeries: TRMChartSeries;
begin
  inherited LoadFromStream(aStream);
  lVersion := RMReadWord(aStream);

  Clear;
  FPicture.Clear;
  ChartDim3D := RMReadBoolean(aStream);
  ChartShowLegend := RMReadBoolean(aStream);
  ChartShowAxis := RMReadBoolean(aStream);
  FPrintType := TRMPrintMethodType(RMReadByte(aStream));
  lCount := RMReadWord(aStream);
  for i := 1 to lCount do
  begin
    lSeries := AddSeries;
    lSeries.XObject := RMReadString(aStream);
    lSeries.YObject := RMReadString(aStream);
    if lVersion < 2 then
      RMReadString(aStream);
    lSeries.Top10Label := RMReadString(aStream);
    lSeries.Title := RMReadString(aStream);
    lSeries.Color := RMReadInt32(aStream);
    lSeries.ChartType := RMReadByte(aStream);
    lSeries.ShowMarks := RMReadBoolean(aStream);
    lSeries.Colored := RMReadBoolean(aStream);
    lSeries.MarksStyle := RMReadByte(aStream);
    lSeries.Top10Num := RMReadInt32(aStream);
    if lVersion >= 1 then
    begin
      lSeries.DataType := TRMChartSeriesDataType(RMReadByte(aStream));
      lSeries.SortOrder := TRMChartSeriesSortOrder(RMReadByte(aStream));
      lSeries.DataSet := RMReadString(aStream);
    end;
  end;

  lType := RMReadByte(aStream);
  if lType = 1 then
  begin
    lStream := TMemoryStream.Create;
    try
      lStream.CopyFrom(aStream, RMReadInt32(aStream));
      lStream.Position := 0;
      FPicture.LoadFromStream(lStream);
    finally
      lStream.Free;
    end;
  end;

  lType := RMReadByte(aStream);
  if lType = 1 then
  begin
    FreeAndNil(FChart);
    FChart := TChart.Create(RMDialogForm);
    with FChart do
    begin
      Parent := RMDialogForm;
      Visible := False;
      BevelInner := bvNone;
      BevelOuter := bvNone;
    end;

    lStream := TMemoryStream.Create;
    try
      lStream.CopyFrom(aStream, RMReadInt32(aStream));
      lStream.Position := 0;
      lStream.ReadComponent(FChart);
      FChart.Name := '';
      for i := 0 to FChart.SeriesList.Count - 1 do
        FChart.SeriesList[i].Name := '';
    finally
      lStream.Free;
    end;
  end;
end;

procedure TRMChartView.SaveToStream(aStream: TStream);
var
  lStream: TMemoryStream;
  lEMF: TMetafile;
  i: Integer;
  lSavePos, lSavePos1, lPos: Integer;
begin
  inherited SaveToStream(aStream);
  RMWriteWord(aStream, 2);

  RMWriteBoolean(aStream, ChartDim3D);
  RMWriteBoolean(aStream, ChartShowLegend);
  RMWriteBoolean(aStream, ChartShowAxis);
  RMWriteByte(aStream, Byte(FPrintType));
  RMWriteWord(aStream, FSeriesList.Count);
  for i := 0 to FSeriesList.Count - 1 do
  begin
    RMWriteString(aStream, Series[i].XObject);
    RMWriteString(aStream, Series[i].YObject);
    RMWriteString(aStream, Series[i].Top10Label);
    RMWriteString(aStream, Series[i].Title);
    RMWriteInt32(aStream, Series[i].Color);
    RMWriteByte(aStream, Series[i].ChartType);
    RMWriteBoolean(aStream, Series[i].ShowMarks);
    RMWriteBoolean(aStream, Series[i].Colored);
    RMWriteByte(aStream, Series[i].MarksStyle);
    RMWriteInt32(aStream, Series[i].Top10Num);
    RMWriteByte(aStream, Byte(Series[i].DataType));
    RMWriteByte(aStream, Byte(Series[i].SortOrder));
    RMWriteString(aStream, Series[i].DataSet);
  end;