xlswriteii2.pas

一个经典的读写Excel的控件

unit XLSWriteII2;

{
********************************************************************************
******* XLSReadWriteII V2.00                                             *******
*******                                                                  *******
******* Copyright(C) 1999,2004 Lars Arvidsson, Axolot Data               *******
*******                                                                  *******
******* email: [e-mail]                                     *******
******* URL:   http://www.axolot.com                                     *******
*******************************************************f*************************
** Users of the XLSReadWriteII component must accept the following            **
** disclaimer of warranty:                                                    **
**                                                                            **
** XLSReadWriteII is supplied as is. The author disclaims all warranties,     **
** expressedor implied, including, without limitation, the warranties of      **
** merchantability and of fitness for any purpose. The author assumes no      **
** liability for damages, direct or consequential, which may result from the  **
** use of XLSReadWriteII.                                                     **
********************************************************************************
}

{$B-}

interface

uses Classes, SysUtils, Dialogs, BIFFRecsII2, CellFormats2, SheetData2, Windows,
     XLSUtils2, XLSStream2, XLSFonts2, ExcelMaskII2, EncodeFormulaII2,
     XLSReadWriteII2, Cell2, Graphics, Contnrs, RecordStorage2;

type TBoundsheetType = (btSheet,btChart);

type TBoundsheetData = class(TObject)
private
     FBoundsheetType: TBoundsheetType;
     FIndex: integer;
     FFilePos: integer;
     FName: WideString;
public
     procedure WritePos(Stream: TXLSStream);
     property BoundsheetType: TBoundsheetType read FBoundsheetType write FBoundsheetType;
     property Index: integer read FIndex write FIndex;
     property FilePos: integer read FFilePos write FFilePos;
     property Name: WideString read FName write FName;
     end;

type TBoundsheetList = class(TObjectList)
private
     function GetCharts(Index: integer): TBoundsheetData;
     function GetItems(Index: integer): TBoundsheetData;
     function GetSheets(Index: integer): TBoundsheetData;
public
     procedure AddSheet(Index: integer; Name: WideString);
     procedure AddChart(Index: integer; Name: WideString);

     property Items[Index: integer]: TBoundsheetData read GetItems; default;
     property Sheets[Index: integer]: TBoundsheetData read GetSheets;
     property Charts[Index: integer]: TBoundsheetData read GetCharts;
     end;

type TXLSWriteII = class(TObject)
protected
     FXLS: TXLSReadWriteII2;
     PBuf: PByteArray;
     FCurrSheet: integer;
     FXLSStream: TXLSStream;
     FBoundsheetList: TBoundsheetList;

     procedure WriteRecId(RecId: word);
     procedure WriteWord(RecId,Value: word);
     procedure WriteBoolean(RecId: word; Value: boolean);
     procedure WriteBuf(RecId,Size: word);
     procedure WritePointer(RecId: word; P: Pointer; Size: word);

     // File prefix
     procedure WREC_BOF(SubStreamType: TSubStreamType);
     procedure WREC_INTERFACEHDR;
     procedure WREC_ADDMENU;
     procedure WREC_DELMENU;
     procedure WREC_INTERFACEEND;
     procedure WREC_WRITEACCESS;
     procedure WREC_CODEPAGE;
     procedure WREC_DSF;
     procedure WREC_EXCEL9FILE;
//     procedure WREC_TABID;
     procedure WREC_OBPROJ;
     procedure WREC_FNGROUPCOUNT;
     procedure WREC_WINDOWPROTECT;
     procedure WREC_PROTECT;
     procedure WREC_PROTECT_Sheet(Value: boolean);
     procedure WREC_PASSWORD;
     procedure WREC_PROT4REV;
     procedure WREC_PROT4REVPASS;
     procedure WREC_WINDOW1;
     procedure WREC_BACKUP;
     procedure WREC_HIDEOBJ;
     procedure WREC_1904;
     procedure WREC_PRECISION;
     procedure WREC_REFRESHALL;
     procedure WREC_BOOKBOOL;
     procedure WREC_FONT;
     procedure WREC_FORMAT;
     procedure WREC_XF;
     procedure WREC_STYLE;
     procedure WREC_PALETTE;
//     procedure WREC_EXTERNNAME;
     procedure WREC_USESELFS;
     procedure WREC_BOUNDSHEET(Index: integer);
     procedure WREC_COUNTRY;
     procedure WREC_MSODRAWINGGROUP;
     procedure WREC_SST;
     procedure WREC_EOF;

     // Sheet prefix
     procedure WREC_CALCMODE;
     procedure WREC_CALCCOUNT;
     procedure WREC_REFMODE;
     procedure WREC_ITERATION;
     procedure WREC_DELTA;
     procedure WREC_SAVERECALC;
     procedure WREC_PRINTHEADERS;
     procedure WREC_PRINTGRIDLINES;
     procedure WREC_GRIDSET;
     procedure WREC_GUTS;
     procedure WREC_DEFAULTROWHEIGHT;
     procedure WREC_WSBOOL;
     procedure WREC_HORIZONTALPAGEBREAKS;
     procedure WREC_VERTICALPAGEBREAKS;
     procedure WREC_HEADER;
     procedure WREC_FOOTER;
     procedure WREC_HCENTER;
     procedure WREC_VCENTER;
     procedure WREC_PLS;
     procedure WREC_MARGINS;
     procedure WREC_SETUP;
     procedure WREC_DEFCOLWIDTH;
     procedure WREC_COLINFO;
     procedure WREC_DIMENSIONS;
     procedure WREC_ROW;

     // Sheet suffix
     procedure WREC_MSODRAWING;
     procedure WREC_MSODRAWINGSELECTION;
     procedure WREC_NOTE;
     procedure WREC_WINDOW2;
     procedure WREC_SCL;
     procedure WREC_PANE;
     procedure WREC_SELECTION;

     procedure WREC_MERGECELLS;
     procedure WREC_CONDFMT;
     procedure WREC_HLINK;
     procedure WREC_DVAL;
public
     constructor Create(XLS: TXLSReadWriteII2);
     destructor Destroy; override;
     procedure WriteToStream(Stream: TStream);
     procedure WriteToStream40(Stream: TStream);
     end;

implementation

type TWordArray = array[0..65535] of word;
     PWordArray = ^TWordArray;

// If the number of default formats are changed, DEFAULT_FORMATS_COUNT_97 in BIFFRecsII must be changed.
{ TXLSWriteII }

constructor TXLSWriteII.Create(XLS: TXLSReadWriteII2);
begin
  FXLS := XLS;
  GetMem(PBuf,FXLS.MaxBuffsize);
  FXLSStream := TXLSStream.Create;
  FBoundsheetList := TBoundsheetList.Create;
end;

destructor TXLSWriteII.Destroy;
begin
  FreeMem(PBuf);
  FXLSStream.Free;
  FBoundsheetList.Free;
end;

procedure TXLSWriteII.WriteRecId(RecId: word);
var
  Header: TBIFFHeader;
begin
  Header.RecId := RecID;
  Header.Length := 0;
  FXLSStream.Write(Header,SizeOf(TBIFFHeader));
end;

procedure TXLSWriteII.WriteWord(RecId,Value: word);
var
  Header: TBIFFHeader;
begin
  Header.RecId := RecID;
  Header.Length := SizeOf(word);
  FXLSStream.Write(Header,SizeOf(TBIFFHeader));
  FXLSStream.Write(Value,SizeOf(word));
end;

procedure TXLSWriteII.WriteBoolean(RecId: word; Value: boolean);
begin
  if Value then
    WriteWord(RecId,1)
  else
    WriteWord(RecId,0);
end;

procedure TXLSWriteII.WriteBuf(RecId,Size: word);
begin
  FXLSStream.WriteHeader(RecId,Size);
  if Size > 0 then
    FXLSStream.Write(PBuf^,Size);
end;

procedure TXLSWriteII.WritePointer(RecId: word; P: Pointer; Size: word);
var
  Header: TBIFFHeader;
begin
  Header.RecId := RecID;
  Header.Length := Size;
  FXLSStream.Write(Header,SizeOf(TBIFFHeader));
  if Size > 0 then
    FXLSStream.Write(P^,Header.Length);
end;

procedure TXLSWriteII.WriteToStream(Stream: TStream);
var
  i,j,k: integer;
  HasRecordData: boolean;
begin
  FBoundsheetList.Clear;
  try
    k := 0;
    for i := 0 to FXLS.Sheets.Count - 1 do begin
      while (k < FXLS.SheetCharts.Count) and (FXLS.SheetCharts[k].SheetIndex <= i) do begin
        FBoundsheetList.AddChart(k,FXLS.SheetCharts[k].Name);
        Inc(k);
      end;
      if i = 0 then
        // Selected tab.
        FXLS.Sheets[0].Records.WINDOW2.Options := FXLS.Sheets[0].Records.WINDOW2.Options or $0200;
      FBoundsheetList.AddSheet(i,FXLS.Sheets[i].Name);
    end;
    // Charts after the last sheet.
    while k < FXLS.SheetCharts.Count do begin
      FBoundsheetList.AddChart(k,FXLS.SheetCharts[k].Name);
      Inc(k);
    end;

    HasRecordData := FXLS.Records.Count > 0;

    if FXLS.ExtraObjects.Count > 0 then
      FXLSStream.ExtraObjects := FXLS.ExtraObjects;
    FXLSStream.TargetStream := Stream;
    FXLSStream.OpenWrite(FXLS.Filename,FXLS.Version);

    if not HasRecordData then
      FXLS.Records.MoveAllDefault;
    for i := 0 to FXLS.Records.Count - 1 do begin
      try
        case FXLS.Records[i].RecId of
          $0809: begin
            FXLS.Records.WriteRec(i,FXLSStream);
            if (PRecBOF8(@FXLS.Records[i].Data).SubstreamType = $0005) and (FXLS.WritePassword <> '') then begin
              FXLSStream.WriteHeader(BIFFRECID_FILEPASS,SizeOf(TRecFILEPASS));
              FXLSStream.Write(PBuf,SizeOf(TRecFILEPASS));
            end;
          end;
          BIFFRECID_OBPROJ:
            WREC_OBPROJ;
          BIFFRECID_PASSWORD:
            WREC_PASSWORD;
          INTERNAL_FORMATS: begin
            WREC_FONT;
            WREC_FORMAT;
            WREC_XF;
            WREC_STYLE;
          end;
          INTERNAL_BOUNDSHEETS: begin
            for j := 0 to FBoundsheetList.Count - 1 do
              WREC_BOUNDSHEET(j);
          end;
          INTERNAL_NAMES: begin
            FXLS.FormulaHandler.ExternalNames.WriteRecords(FXLSStream);
            FXLS.FormulaHandler.InternalNames.WriteRecords(FXLSStream);
          end;
          INTERNAL_MSODRWGRP: begin
            if FXLS.MSOPictures.HasData then begin
              FXLSStream.BeginCONTINUEWrite(MAXRECSZ_97);
              FXLS.MSOPictures.WriteToStream(FXLSStream,PBuf);
              FXLSStream.EndCONTINUEWrite;
            end;
          end;
          INTERNAL_SST:
            FXLS.Sheets.WriteSST(FXLSStream);
          BIFFRECID_TABID: begin
            if FXLS.Records[i].Length = 0 then begin
              FXLSStream.WriteHeader(BIFFRECID_TABID,FXLS.Sheets.Count * 2);
              for j := 1 to FXLS.Sheets.Count do
                FXLSStream.WWord(j);
            end;
          end;
          else
            FXLS.Records.WriteRec(i,FXLSStream);
        end;
      except
        on E: Exception do
          raise Exception.CreateFmt('Error on writing record # %d' + #13 + E.Message,[i]);
      end;
    end;
    k := 0;
    for i := 0 to FXLS.Sheets.Count - 1 do begin
      if not FXLS.Sheets[i].HasDefaultRecords then begin
        FXLS.Sheets[i].Records.MoveAllDefault;
        FXLS.Sheets[i].HasDefaultRecords := True;
      end;
      FCurrSheet := i;

      while (k < FXLS.SheetCharts.Count) and (FXLS.SheetCharts[k].SheetIndex <= i) do begin
        FBoundsheetList.Charts[k].WritePos(FXLSStream);
        FXLS.SheetCharts.SaveToStream(k,FXLSStream);
        Inc(k);
      end;
      FBoundsheetList.Sheets[i].WritePos(FXLSStream);

      FXLS.Sheets[i].CalcDimensions;
      for j := 0 to FXLS.Sheets[i].Records.Count - 1 do begin
        case FXLS.Sheets[i].Records[j].RecId of
          INTERNAL_PAGEBREAKES: begin
            WREC_HORIZONTALPAGEBREAKS;
            WREC_VERTICALPAGEBREAKS;
          end;
          INTERNAL_HEADER: begin
            WREC_HEADER;
            WREC_FOOTER;
          end;
          INTERNAL_MARGINS: begin
            WREC_MARGINS;
          end;
          INTERNAL_COLINFO: begin
            WREC_COLINFO;
          end;
          INTERNAL_CELLDATA: begin
            WREC_ROW;
            FXLS.Sheets[i].StreamWriteCells(FXLS.Version,FXLSStream);
          end;
          INTERNAL_SUFFIXDATA : begin
            WREC_MSODRAWING;
            WREC_PANE;
            WREC_MERGECELLS;
            WREC_CONDFMT;
            WREC_HLINK;
            WREC_DVAL;
          end;
          else
            FXLS.Sheets[i].Records.WriteRec(j,FXLSStream);
        end;
      end;
//      FXLSStream.WriteHeader(BIFFRECID_EOF,0);
    end;
    // Charts after the last sheet.
    while k < FXLS.SheetCharts.Count do begin
      FBoundsheetList.Charts[k].WritePos(FXLSStream);