uxlsbaserecords.pas

来自「DELPHI界面增强控件,非常好,里面有显示GIF的图片控件,更美观的下拉框控件」· PAS 代码 · 共 1,072 行 · 第 1/3 页

unit UXlsBaseRecords;

interface
uses Sysutils, Contnrs, Classes,
    {$IFDEF ConditionalExpressions}{$if CompilerVersion >= 14} variants,{$IFEND}{$ENDIF} //Delphi 6 or above
     XlsMessages;

type
  TContinueRecord=class;

  TBaseRecord = class (TObject)
  public
    Id: word;
    Data: PArrayOfByte;
    DataSize: word;

    Continue: TContinueRecord;

    procedure SaveDataToStream(const Workbook: TStream; const aData: PArrayOfByte);
  protected
    function DoCopyTo: TBaseRecord; virtual;
  public
    constructor Create(const aId: word; const aData: PArrayOfByte; const aDataSize: integer);virtual;
    destructor Destroy; override;
    procedure AddContinue(const aContinue: TContinueRecord);

    procedure SaveToStream(const Workbook: TStream); virtual;
    function CopyTo: TBaseRecord;  //this should be non-virtual
    function TotalSize: integer;virtual;
    function TotalSizeNoHeaders: integer;virtual;
  end;

  ClassOfTBaseRecord= Class of TBaseRecord;

  TContinueRecord=class(TBaseRecord)
  end;

  TIgnoreRecord = class (TBaseRecord)
    function TotalSize: integer; override;
    procedure SaveToStream(const Workbook: TStream); override;
  end;

  TSubListRecord = class (TBaseRecord)  //This is a "virtual" record used to save sublists to stream
  private
    FSubList: TObjectList;
  protected
    function DoCopyTo: TBaseRecord; override;

  public
    constructor  CreateAndAssign(const aSubList: TObjectList);
    function TotalSize: integer; override;
    procedure SaveToStream(const Workbook: TStream); override;
  end;

  TBaseRowColRecord = class(TBaseRecord)
  private
    function GetColumn: word;
    function GetRow: word;
    procedure SetColumn( Value: word );
    procedure SetRow( Value: word );
  public
    property Row: word read GetRow write SetRow;
    property Column: word read GetColumn write SetColumn;

    procedure ArrangeInsert(const aPos, aCount:integer; const SheetInfo: TSheetInfo);virtual;
    procedure ArrangeCopy(const NewRow: Word);virtual;
  public
    constructor Create(const aId: word; const aData: PArrayOfByte; const aDataSize: integer);override;
  end;

  TCellRecord=class(TBaseRowColRecord)
  private
    function GetXF: word;
    procedure SetXF(const Value: word);
  protected
    function GetValue: Variant; virtual;
    procedure SetValue(const Value: Variant); virtual;
  public
    property XF: word read GetXF write SetXF;
    property Value:Variant read GetValue write SetValue;
    constructor CreateFromData(const aId, aDataSize, aRow, aCol, aXF: word);
  end;

  TRowRecord=class(TBaseRowColRecord)
  private
    function GetHeight: word;
    function GetMaxCol: word;
    function GetMinCol: word;
    function GetXF: word;
    procedure SetHeight(const Value: word);
    procedure SetMaxCol(const Value: word);
    procedure SetMinCol(const Value: word);
    procedure SetXF(const Value: word);
  public
    constructor Create(const aId: word; const aData: PArrayOfByte; const aDataSize: integer);override;
    constructor CreateStandard(const Row: word);
    function GetRow: Word;

    property MaxCol: word read GetMaxCol write SetMaxCol;
    property MinCol: word read GetMinCol write SetMinCol;
    property Height: word read GetHeight write SetHeight;
    property XF: word read GetXF write SetXF;
    function IsFormatted: boolean;
    function IsModified: boolean;

    procedure ManualHeight;
    procedure AutoHeight;
    function IsAutoHeight: boolean;
    procedure SaveRangeToStream(const DataStream: TStream; const aMinCol, aMaxCol: integer);
  end;

  TDimensionsRec=packed record
    FirstRow, LastRow: LongWord;
    FirstCol, LastCol: Word;
    Extra: word;
  end;
  PDimensionsRec=^TDimensionsRec;
  
  TDimensionsRecord=class(TBaseRecord)
    function Dim: PDimensionsRec;
  end;

  TStringRecord=class(TBaseRecord)
  public
    procedure SaveToStream(const Workbook: TStream); override;
    function TotalSize: integer; override;
    function Value: widestring;
  end;

  TWindow1Record=class(TBaseRecord)
  private
    function GetActiveSheet: integer;
    procedure SetActiveSheet(const Value: integer);
  public
    property ActiveSheet: integer read GetActiveSheet write SetActiveSheet;
  end;

  TWindow2Record=class(TBaseRecord)
  private
    function GetSelected: boolean;
    procedure SetSelected(const Value: boolean);
    function GetShowGridLines: boolean;
    procedure SetShowGridLines(const Value: boolean);
    procedure SetSheetZoom(const Value: integer);
    function GetSheetZoom: integer;
  protected
    function DoCopyTo: TBaseRecord; override;
  public
    property Selected: boolean read GetSelected write SetSelected;
    property ShowGridLines: boolean read GetShowGridLines write SetShowGridLines;
    property SheetZoom: integer read GetSheetZoom write SetSheetZoom;
  end;

  TSCLRecord=class(TBaseRecord)
  private
    function GetZoom: integer;
    procedure SetZoom(const Value: integer);
  public
    constructor CreateFromData(const aZoom: integer);
    property Zoom: integer read GetZoom write SetZoom;
  end;

  TDefColWidthRecord = class(TBaseRecord)
  public
    function Width: Word;
  end;

  TDefRowHeightRecord = class(TBaseRecord)
  public
    function Height: Word;
  end;

  TPageHeaderFooterRecord = class(TBaseRecord)
  private
    function GetText: WideString;
    procedure SetText(const Value: WideString);
  public
    property Text: WideString read GetText write SetText;
  end;

  TPageHeaderRecord = class(TPageHeaderFooterRecord)
  end;

  TPageFooterRecord = class(TPageHeaderFooterRecord)
  end;

  TPrintGridLinesRecord = class(TPageHeaderFooterRecord)
  private
    function GetValue: boolean;
    procedure SetValue(const Value: boolean);
  public
    property Value: boolean read GetValue write SetValue;
  end;


  TMarginRecord=class(TBaseRecord)
  private
    function GetValue: double;
    procedure SetValue(const Value: double);
  public
    property Value: double read GetValue write SetValue;
  end;

  TSetupRec=packed record
    PaperSize: word;
    Scale: word;
    PageStart: word;
    FitWidth: word;
    FitHeight: word;
    GrBit: word;
    Resolution: word;
    VResolution: word;
    HeaderMargin: double;
    FooterMargin: double;
    Copies: word;
  end;
  PSetupRec=^TSetupRec;

  TSetupRecord=class(TBaseRecord)
  private
    function GetValue: TSetupRec;
    procedure SetValue(const Value: TSetupRec);
    function GetScale: word;
    procedure SetScale(const Value: word);
    function GetFitHeight: word;
    function GetFitWidth: word;
    procedure SetFitHeight(const Value: word);
    procedure SetFitWidth(const Value: word);
    function GetFooterMargin: extended;
    function GetHeaderMargin: extended;
    procedure SetFooterMargin(const Value: extended);
    procedure SetHeaderMargin(const Value: extended);
  public
    property Value: TSetupRec read GetValue write SetValue;
    property Scale: word read GetScale write SetScale;
    property FitWidth: word read GetFitWidth write SetFitWidth;
    property FitHeight: word read GetFitHeight write SetFitHeight;

    property HeaderMargin: extended read GetHeaderMargin write SetHeaderMargin;
    property FooterMargin: extended read GetFooterMargin write SetFooterMargin;
  end;

  TWsBoolRecord=class(TBaseRecord)
  private
    function GetValue: word;
    procedure SetValue(const Value: word);
    function GetFitToPage: boolean;
    procedure SetFitToPage(const Value: boolean);
  public
    property Value: word read GetValue write SetValue;
    property FitToPage: boolean read GetFitToPage write SetFitToPage;
  end;


////////////////////////////// Utility functions
  function LoadRecord(const DataStream: TStream; const RecordHeader: TRecordHeader): TBaseRecord;
  procedure ReadMem(var aRecord: TBaseRecord; var aPos: integer; const aSize: integer; const pResult: pointer);
  procedure ReadStr(var aRecord: TBaseRecord; var aPos: integer; var ShortData: string; var WideData: WideString; var OptionFlags, ActualOptionFlags: byte; var DestPos: integer; const StrLen: integer );

implementation
uses UXlsFormula, UXlsOtherRecords, UXlsSST, UXlsReferences, UXlsCondFmt, UXlsChart, UXlsEscher,
     UXlsNotes, UXlsCellRecords, UXlsPageBreaks, UXlsStrings, UXlsColInfo, UXlsXF,
     UXlsBaseRecordLists, UXlsPalette;

////////////////////////////// Utility functions

procedure ReadMem(var aRecord: TBaseRecord; var aPos: integer; const aSize: integer; const pResult: pointer);
//Read memory taking in count "Continue" Records
var
  l: integer;
begin
  l:= aRecord.DataSize-aPos;

  if l<0 then raise Exception.Create(ErrReadingRecord);
  if (l=0) and (aSize>0) then
  begin
    aPos:=0;
    aRecord:=aRecord.Continue;
    if aRecord=nil then raise Exception.Create(ErrReadingRecord);
  end;

  l:= aRecord.DataSize-aPos;

  if aSize<=l then
  begin
    if pResult<>nil then Move(aRecord.Data^[aPos], pResult^, aSize);
    inc(aPos, aSize);
  end else
  begin
    ReadMem(aRecord, aPos, l, pResult);
    if pResult<>nil then ReadMem(aRecord, aPos, aSize-l, PCHAR(pResult)+ l)
    else ReadMem(aRecord, aPos, aSize-l, nil);
  end
end;

procedure ReadStr(var aRecord: TBaseRecord; var aPos: integer; var ShortData: string; var WideData: WideString; var OptionFlags, ActualOptionFlags: byte; var DestPos: integer; const StrLen: integer );
//Read a string taking in count "Continue" Records
var
  l,i: integer;
  pResult: pointer;
  aSize, CharSize: integer;
begin
  l:= aRecord.DataSize-aPos;

  if l<0 then raise Exception.Create(ErrReadingRecord);
  if (l=0) and (StrLen>0) then
    if DestPos=0 then  //we are beginning the record
    begin
      aPos:=0;
      if aRecord.Continue=nil then raise Exception.Create(ErrReadingRecord);
      aRecord:=aRecord.Continue;
    end else
    begin       //We are in the middle of a string
      aPos:=1;
      if aRecord.Continue=nil then raise Exception.Create(ErrReadingRecord);
      aRecord:=aRecord.Continue;
      ActualOptionFlags:=aRecord.Data[0];
      if (ActualOptionFlags=1) and ((OptionFlags and 1)=0 ) then
      begin
        WideData:=StringToWideStringNoCodePage(ShortData);
        OptionFlags:= OptionFlags or 1;
      end;
    end;

  l:= aRecord.DataSize-aPos;

  if (ActualOptionFlags and 1)=0 then
  begin
    aSize:= StrLen-DestPos;
    pResult:= @ShortData[DestPos+1];
    CharSize:=1;
  end else
  begin
    aSize:= (StrLen-DestPos)*2;
    pResult:= @WideData[DestPos+1];
    CharSize:=2;
  end;

  if aSize<=l then
  begin
    if (ActualOptionFlags and 1=0) and (OptionFlags and 1=1) then
      //We have to move result to widedata
      for i:=0 to aSize div CharSize -1 do WideData[DestPos+1+i]:=WideChar(aRecord.Data^[aPos+i])
      //We are either reading widedata or shortdata
      else Move(aRecord.Data^[aPos], pResult^, aSize);

    inc(aPos, aSize);
    inc(DestPos, aSize div CharSize);
  end else
  begin
    if (ActualOptionFlags and 1=0) and (OptionFlags and 1=1) then
      //We have to move result to widedata
      for i:=0 to l div CharSize -1 do WideData[DestPos+1+i]:=WideChar(aRecord.Data^[aPos+i])
      //We are either reading widedata or shortdata
      else  Move(aRecord.Data^[aPos], pResult^, l);
    inc(aPos, l);
    inc(DestPos, l div CharSize);
    ReadStr(aRecord, aPos, ShortData, WideData, OptionFlags, ActualOptionFlags, DestPos ,StrLen);