drawingobjchart2.pas

一个经典的读写Excel的控件

     function  GetAxisLabels: boolean;
     function  GetShadow: boolean;
     procedure SetAxisLabels(const Value: boolean);
     procedure SetShadow(const Value: boolean);
protected
     procedure Assign(Rec: TChartRecord); override;
public
     constructor Create;
     destructor Destroy; override;
published
     property AxisLabels: boolean read GetAxisLabels write SetAxisLabels;
     property Shadow: boolean read GetShadow write SetShadow;
     end;

type TChartStyleRadarArea = class(TChartStyle)
private
     function  GetAxisLabels: boolean;
     function  GetShadow: boolean;
     procedure SetAxisLabels(const Value: boolean);
     procedure SetShadow(const Value: boolean);
protected
     procedure Assign(Rec: TChartRecord); override;
public
     constructor Create;
     destructor Destroy; override;
published
     property AxisLabels: boolean read GetAxisLabels write SetAxisLabels;
     property Shadow: boolean read GetShadow write SetShadow;
     end;

type TChartPlotArea = class(TRecordObject)
private
     FCategoryAxis: TCategoryAxis;
     FSerieAxis: TSerieAxis;
     FValueAxis: TValueAxis;
     FChartStyle: TChartStyle;
     FFrame: TPaintFrame;

     function  GetChartType: TXLSChartType;
     procedure SetChartType(const Value: TXLSChartType);
     function  GetIs3D: boolean;
     procedure SetIs3D(const Value: boolean);
     function  GetHasLegend: boolean;
     procedure SetHasLegend(const Value: boolean);
protected
     procedure Assign(Rec: TChartRecord); override;
public
     constructor Create;
     destructor Destroy; override;
published
     property ChartType: TXLSChartType read GetChartType write SetChartType;
     property ChartStyle: TChartStyle read FChartStyle write FChartStyle;
     property Frame: TPaintFrame read FFrame write FFrame;
     property Is3D: boolean read GetIs3D write SetIs3D;
     property HasLegend: boolean read GetHasLegend write SetHasLegend;
     property CategoryAxis: TCategoryAxis read FCategoryAxis write FCategoryAxis;
     property SerieAxis: TSerieAxis read FSerieAxis write FSerieAxis;
     property ValueAxis: TValueAxis read FValueAxis write FValueAxis;
     end;

type TDrwChart = class(TDrwAnchor)
private
     FRecord: TChartRecord;
     FRecCHART: TChartRecord;
     FRecSHTPROPS: TChartRecord;
     FDefaultTextA: TChartText;
     FDefaultTextB: TChartText;
     FLabels: TChartLabels;
     FSeries: TChartSeries;
     FPlotArea: TChartPlotArea;
     FFrame: TPaintFrame;

     function  GetEmptyCells: TChartEmptyCells;
     function  GetSheetOptions: TChartSheetOptions;
     procedure SetEmptyCells(const Value: TChartEmptyCells);
     procedure SetSheetOptions(const Value: TChartSheetOptions);
     function  GetPlotVisibleCellsOnly: boolean;
     procedure SetPlotVisibleCellsOnly(const Value: boolean);
protected
     FFormulaHandler: TFormulaHandler;

     procedure AssignRecords(Records: TChartRecord);
public
     constructor Create(Collection: TCollection); override;
     destructor Destroy; override;

     property EmptyCells: TChartEmptyCells read GetEmptyCells write SetEmptyCells;
     property PlotVisibleCellsOnly: boolean read GetPlotVisibleCellsOnly write SetPlotVisibleCellsOnly;
published
     property DefaultTextA: TChartText read FDefaultTextA write FDefaultTextA;
     property DefaultTextB: TChartText read FDefaultTextB write FDefaultTextB;
     property Series: TChartSeries read FSeries write FSeries;
     property PlotArea: TChartPlotArea read FPlotArea write FPlotArea;
     property Labels: TChartLabels read FLabels write FLabels;
     property SheetOptions: TChartSheetOptions read GetSheetOptions write SetSheetOptions;
     end;

type TDrwCharts = class(TCollection)
private
     function  GetDrwChart(Index: integer): TDrwChart;
protected
     FOwner: TPersistent;
     FDrawing: TEscherDrawing;
     FFileAdd: boolean;
     FFormulaHandler: TFormulaHandler;
     FFonts: TXFonts;

     function  GetOwner: TPersistent; override;
public
     constructor Create(AOwner: TPersistent; Drawing: TEscherDrawing; FormulaHandler: TFormulaHandler; Fonts: TXFonts);
     function  Add(SheetIndex: integer): TDrwChart;
     procedure AddFromFile(Shape: TShapeClientAnchor);
     procedure Clear;

     property Items[Index: integer]: TDrwChart read GetDrwChart; default;
     end;

type TSheetChart = class(TDrwChart)
private
     FSheetIndex: integer;
     FName: WideString;
published
     constructor Create(Collection: TCollection); override;
     property SheetIndex: integer read FSheetIndex write FSheetIndex;
     property Name: WideString read FName write FName;
     end;

type TSheetCharts = class(TCollection)
private
     FOwner: TPersistent;

     function GetSheetChart(Index: integer): TSheetChart;
protected
     function  GetOwner: TPersistent; override;
     function  Add: TSheetChart;
public
     constructor Create(AOwner: TPersistent);
     procedure LoadFromStream(Stream: TXLSStream; Name: WideString; PBuf: PByteArray; Fonts: TXFonts; SheetIndex: integer);
     procedure SaveToStream(Index: integer; Stream: TXLSStream);
     property Items[Index: integer]: TSheetChart read GetSheetChart; default;
     end;

implementation

procedure CheckRec(Rec: TChartRecord);
begin
  if Rec = Nil then
    raise Exception.Create('Property has no data');
end;

{ TDrwCharts }

function TDrwCharts.Add(SheetIndex: integer): TDrwChart;
begin
  Result := TDrwChart(inherited Add);
  FFormulaHandler.ExternalNames.AddSelf(SheetIndex,1);
  Result.FRecord := TShapeOutsideMsoChart(Result.FShape.ExShape).Records;
  Result.FFormulaHandler := FFormulaHandler;
  Result.FRecord.ReadDefaultRecords(drdAll);
  Result.AssignRecords(Result.FRecord);
end;

procedure TDrwCharts.AddFromFile(Shape: TShapeClientAnchor);
var
  Chart: TDrwChart;
begin
  FFileAdd := True;
  try
    Chart := TDrwChart(inherited Add);
    Chart.FRecord := TShapeOutsideMsoChart(Shape.ExShape).Records;
    Chart.FFormulaHandler := FFormulaHandler;
    Chart.FShape := Shape;
    Chart.AssignRecords(Chart.FRecord);
  finally
    FFileAdd := False;
  end;
end;

procedure TDrwCharts.Clear;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    FDrawing.DeleteShape(Items[i].FShape.SpId);
  inherited Clear;
end;

constructor TDrwCharts.Create(AOwner: TPersistent; Drawing: TEscherDrawing; FormulaHandler: TFormulaHandler; Fonts: TXFonts);
begin
  inherited Create(TDrwChart);
  FOwner := AOwner;
  FDrawing := Drawing;
  FFormulaHandler := FormulaHandler;
  FFonts := Fonts;
end;

function TDrwCharts.GetDrwChart(Index: integer): TDrwChart;
begin
  Result := TDrwChart(inherited Items[Index]);
end;

function TDrwCharts.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

{ TDrwChart }

procedure TDrwChart.AssignRecords(Records: TChartRecord);
var
  i: integer;
begin
  i := 0;
  if (Records.Count > 0) and (Records[i].RecId = BIFFRECID_BOF8) then begin
    while i < Records.Count do begin
      if Records[i].RecId = CHARTRECID_CHART then begin
        FRecCHART := Records[i];
        Records := Records[i];
        Break;
      end;
      Inc(i);
    end;
  end;
  if Records = Nil then
    raise Exception.Create('Can not find CHART record.');
  i := 0;
  while i < Records.Count do begin
    case Records[i].RecId of
      CHARTRECID_DEFAULTTEXT: begin
        Inc(i);
        if (i >= Records.Count) or (Records[i].RecId <> CHARTRECID_TEXT) then
          raise Exception.Create('Excpected Chart record missing: TEXT');
        case PCRecDEFAULTTEXT(Records[i - 1].Data).Id of
          2: FDefaultTextA.Assign(Records[i]);
          3: FDefaultTextB.Assign(Records[i]);
        end;
      end;
      CHARTRECID_FRAME:
        FFrame.Assign(Records[i]);
      CHARTRECID_SERIES:
        FSeries.AddFromFile.AssignRecords(Records[i]);
      CHARTRECID_TEXT:
        FLabels.AddFromFile.AssignRecords(Records[i]);
      CHARTRECID_SHTPROPS:
        FRecSHTPROPS := Records[i];
      CHARTRECID_AXISPARENT:
        FPlotArea.Assign(Records[i]);
      CHARTRECID_FONTX:
        Inc(i);
    end;
    Inc(i);
  end;
end;

constructor TDrwChart.Create(Collection: TCollection);
begin
  FDefaultTextA := TChartText.Create;
  FDefaultTextB := TChartText.Create;
  FLabels := TChartLabels.Create(Self);
  FSeries := TChartSeries.Create(Self,TDrwCharts(Collection).FFormulaHandler);
  FPlotArea := TChartPlotArea.Create;
  FFrame := TPaintFrame.Create;

  if not TDrwCharts(Collection).FFileAdd then
    FShape := TDrwCharts(Collection).FDrawing.AddChart;
  inherited Create(Collection);
  FName := 'Chart ' + IntToStr(ID);
end;

destructor TDrwChart.Destroy;
begin
  FLabels.Free;
  FSeries.Free;
  FDefaultTextA.Free;
  FDefaultTextB.Free;
  FPlotArea.Free;
  FFrame.Free;
  inherited;
end;

function TDrwChart.GetEmptyCells: TChartEmptyCells;
begin
  CheckRec(FRecSHTPROPS);
  Result := TChartEmptyCells(PCRecSHTPROPS(FRecSHTPROPS.Data).BlanksAs);
end;

function TDrwChart.GetPlotVisibleCellsOnly: boolean;
begin
  CheckRec(FRecSHTPROPS);
  Result := (PCRecSHTPROPS(FRecSHTPROPS.Data).Flags and $0002) = $0002;
end;

function TDrwChart.GetSheetOptions: TChartSheetOptions;
begin
  CheckRec(FRecSHTPROPS);
  Result := [];
  if (PCRecSHTPROPS(FRecSHTPROPS.Data).Flags and $0002) = $0002 then
    Result := Result + [csoOnlyVisibleCells];
  if (PCRecSHTPROPS(FRecSHTPROPS.Data).Flags and $0004) = $0004 then
    Result := Result + [csoDoNotSize];
end;

procedure TDrwChart.SetEmptyCells(const Value: TChartEmptyCells);
begin
  CheckRec(FRecSHTPROPS);
  PCRecSHTPROPS(FRecSHTPROPS.Data).BlanksAs := Integer(Value);
end;

procedure TDrwChart.SetPlotVisibleCellsOnly(const Value: boolean);
begin
  CheckRec(FRecSHTPROPS);
  if Value then
    PCRecSHTPROPS(FRecSHTPROPS.Data).Flags := PCRecSHTPROPS(FRecSHTPROPS.Data).Flags or $0002
  else
    PCRecSHTPROPS(FRecSHTPROPS.Data).Flags := PCRecSHTPROPS(FRecSHTPROPS.Data).Flags and not $0002;
end;

procedure TDrwChart.SetSheetOptions(const Value: TChartSheetOptions);
begin
  CheckRec(FRecSHTPROPS);
  PCRecSHTPROPS(FRecSHTPROPS.Data).Flags := PCRecSHTPROPS(FRecSHTPROPS.Data).Flags and not ($0002 + $0004);
  if csoOnlyVisibleCells in Value then
    PCRecSHTPROPS(FRecSHTPROPS.Data).Flags := PCRecSHTPROPS(FRecSHTPROPS.Data).Flags or $0002;
  if csoDoNotSize in Value then
    PCRecSHTPROPS(FRecSHTPROPS.Data).Flags := PCRecSHTPROPS(FRecSHTPROPS.Data).Flags or $0004;
end;

{ TChartText }

procedure TChartText.Assign(Rec: TChartRecord);
var
  i: integer;
begin
  inherited;
  FFont := Nil;
  for i := 0 to Rec.Count - 1 do begin
    if Rec[i].RecId = CHARTRECID_FONTX then begin
      FFont := TXFont(Rec[i].Data);
    end;
  end;
end;

function TChartText.GetColor: TExcelColor;
begin
  Check;
  if PCRecTEXT(FRecord.Data).ColorIndex > Integer(High(TExcelColor)) then
    Result := xcAutomatic
  else
    Result := TExcelColor(PCRecTEXT(FRecord.Data).ColorIndex);
end;

procedure TChartText.SetColor(const Value: TExcelColor);
begin
  Check;
  PCRecTEXT(FRecord.Data).ColorIndex := Word(Value);
  PCRecTEXT(FRecord.Data).Options1 := PCRecTEXT(FRecord.Data).Options1 and (not $0001);
  PCRecTEXT(FRecord.Data).Options1 := PCRecTEXT(FRecord.Data).Options1 and (not $0020);
end;

{ TChartSeries }

function TChartSeries.Add: TChartSerie;
const
  D: array[0..11] of byte = ($01,$00,$01,$00,$0A,$00,$0A,$00,$01,$00,$00,$00);
var
  i,Index: integer;
  Rec,Par: TChartRecord;
begin
  Index := -1;
  Par := Items[Count - 1].FRecord.Parent;
  for i := 0 to Par.Count - 1 do begin
    if Par[i].RecId = CHARTRECID_SERIES then
      Index := i;
  end;
  if Index < 0 then
    raise Exception.Create('Can not find insertion point for serie');
  Rec := Par.InsertRecord(Index,CHARTRECID_SERIES,SizeOf(TCRecSERIES));
  Move(D,Rec.Data^,SizeOf(TCRecSERIES));
  Rec.ReadDefaultRecords(drdSerie);

  Result := TChartSerie.Create(Self);
  Result.FFormulaHandler := FFormulaHandler;
  Result.AssignRecords(Rec);
end;

function TChartSeries.AddFromFile: TChartSerie;
begin
  Result := TChartSerie.Create(Self);