sst2.pas

一个经典的读写Excel的控件

unit SST2;

{
********************************************************************************
******* XLSReadWriteII V2.00                                             *******
*******                                                                  *******
******* Copyright(C) 1999,2004 Lars Arvidsson, Axolot Data               *******
*******                                                                  *******
******* email: [e-mail]                                     *******
******* URL:   http://www.axolot.com                                     *******
********************************************************************************
** 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, Windows, BIFFRecsII2, XLSStream2, XLSUtils2, XLSFonts2,
     XLSRWIIResourceStrings2;

type PXLSString = ^TXLSString;
     TXLSString = record
     Index: integer;
     Hash: longword;
     RefCount: integer;
     Len: word;
     Options: byte;
     Data: record end;
     end;

type PExtSSTRec = ^TExtSSTRec;
     TExtSSTRec = record
     StreamPos: longword;
     RecPos: word;
     end;

type TExtSST = class(TList)
private
     FBucketSize: integer;

     procedure SetStringCount(const Value: integer);
public
     procedure Clear; override;
     procedure Add(StreamPos: longword; RecPos: word);
     procedure Write(Stream: TXLSStream);

     property BucketSize: integer read FBucketSize;
     property StringCount: integer write SetStringCount;
     end;

type TSST2 = class(TObject)
private
     FSST: TList;
     FExtSST: TExtSST;
     FTotalCount: integer;
     FMaxBufSize: integer;
     FFonts: TXFonts;
     FIsUpdating: boolean;

     function  GetItemByIndex(Index: integer): WideString;
     function  GetItem(Value: PXLSString): WideString;
     function  HashFind(Hash: longword; S: Pointer; Len: integer; var Index: integer): boolean;
     function  GetIsFormatted(Value: PXLSString): boolean;
     function  GetFormatCount(Value: PXLSString): integer;
     function  GetDataPointer(Value: PXLSString): PByteArray;
     function  AddCompressedString(S: string; FontRunCount: integer = 0): PXLSString;
     function  AddUnicodeString(S: WideString; FontRunCount: integer = 0): PXLSString;
     function  IsUnicode(S: WideString): boolean;
     function  StreamReadString(Stream: TXLSStream; var RecSize: word): PByteArray;
     function  ReadCONTINUE(Stream: TXLSStream): word;
     function  GetSST(Index: integer): PXLSString;
     procedure Sort;
     function  GetFont(Value: PXLSString; FormatIndex: integer): PFontRun;
public
     constructor Create(Fonts: TXFonts);
     destructor Destroy; override;
     procedure Clear;
     function  AddString(S: WideString): PXLSString;
     function  AddRichString(S: WideString; FontRunCount: integer): PXLSString;
     function  Delete(Value: PXLSString): boolean;
     procedure Write(Stream: TXLSStream);
     procedure Read(Stream: TXLSStream; RecSize: word);
     function  StrSeek(Stream: TXLSStream; ExtSSTPos,Index: integer): WideString;
     function  Check: boolean;
     procedure BeginUpdate;
     procedure EndUpdate;

     property ItemsByIndex[Index: integer]: WideString read GetItemByIndex;
     property Items[Value: PXLSString]: WideString read GetItem; default;
     property MaxBufSize: integer read FMaxBufSize write FMaxBufSize;
     property IsFormatted[Value: PXLSString]: boolean read GetIsFormatted;
     property FormatCount[Value: PXLSString]: integer read GetFormatCount;
     property Font[Value: PXLSString; FormatIndex: integer]: PFontRun read GetFont;
     property SST[Index: integer]: PXLSString read GetSST;
     end;

implementation

const STRID_COMPRESSED      = $00;
const STRID_UNICODE         = $01;
const STRID_RICH            = $08;
const STRID_RICH_UNICODE    = STRID_RICH + STRID_UNICODE;
const STRID_FAREAST         = $04;
const STRID_FAREAST_RICH    = STRID_FAREAST + STRID_RICH;
const STRID_FAREAST_UC      = STRID_FAREAST + STRID_UNICODE;
const STRID_FAREAST_RICH_UC = STRID_FAREAST + STRID_UNICODE + STRID_RICH;

// Compressed
// Declared public above

// Unicode
type PXLSStringUC = ^TXLSStringUC;
     TXLSStringUC = record
     Index: integer;
     Hash: longword;
     RefCount: integer;
     Len: word;
     Options: byte;
     Data: record end;
     end;

// Compressed with formatting
type PXLSStringRich = ^TXLSStringRich;
     TXLSStringRich = record
     Index: integer;
     Hash: longword;
     RefCount: integer;
     Len: word;
     Options: byte;
     FormatCount: word;
     Data: record end;
     end;

// Unicode with formatting
type PXLSStringRichUC = ^TXLSStringRichUC;
     TXLSStringRichUC = record
     Index: integer;
     Hash: longword;
     RefCount: integer;
     Len: word;
     Options: byte;
     FormatCount: word;
     Data: record end;
     end;

// Compressed with Far East data
type PXLSStringFarEast = ^TXLSStringFarEast;
     TXLSStringFarEast = record
     Index: integer;
     Hash: longword;
     RefCount: integer;
     Len: word;
     Options: byte;
     FarEastDataSize: longword;
     Data: record end;
     end;

// Unicode with Far East data
type PXLSStringFarEastUC = ^TXLSStringFarEastUC;
     TXLSStringFarEastUC = record
     Index: integer;
     Hash: longword;
     RefCount: integer;
     Len: word;
     Options: byte;
     FarEastDataSize: longword;
     Data: record end;
     end;

// Compressed with Far East data and formatting
type PXLSStringFarEastRich = ^TXLSStringFarEastRich;
     TXLSStringFarEastRich = record
     Index: integer;
     Hash: longword;
     RefCount: integer;
     Len: word;
     Options: byte;
     FormatCount: word;
     FarEastDataSize: longword;
     Data: record end;
     end;

// Unicode with Far East data and formatting
type PXLSStringFarEastRichUC = ^TXLSStringFarEastRichUC;
     TXLSStringFarEastRichUC = record
     Index: integer;
     Hash: longword;
     RefCount: integer;
     Len: word;
     Options: byte;
     FormatCount: word;
     FarEastDataSize: longword;
     Data: record end;
     end;

type TRecREFormat = packed record
     CharIndex: word;
     case word of
       0: (FontIndex: word);
       1: (FormatCount: word);
     end;

type TRecREFormatArray = array[0..32767] of TRecREFormat;
     PRecREFormatArray = ^TRecREFormatArray;

type PRecUnicodeStr = ^TRecUnicodeStr;
     TRecUnicodeStr = packed record
     CharCount: word;
     Options: byte;
     case integer of
       0: (Data: array[0..MAXINT div 2] of byte);
       1: (FormattingRuns: word);
     end;

function StrHashCode(const Buffer; Count: Integer): longword;
var
  i: Integer;
  x: longword;
begin
  Result := 0;
  for i := 0 to Count - 1 do begin
    Result := (Result shl 4) + PByteArray(@Buffer)[i];
    x := Result and $F0000000;
    if (x <> 0) then
      Result := Result xor (x shr 24);
    Result := Result and (not x);
  end;
end;



{ TSST2 }

function TSST2.AddCompressedString(S: string; FontRunCount: integer = 0): PXLSString;
var
  i,Index: integer;
  Hash: longword;
  P: PXLSString;
begin
  Index := -1;
  Inc(FTotalCount);
  Hash := StrHashCode(Pointer(S)^,Length(S));
  if FIsUpdating or not HashFind(Hash,Pointer(S),Length(S),Index) then begin
    if FontRunCount > 0 then begin
      GetMem(P,SizeOf(TXLSStringRich) + Length(S) + FontRunCount * SizeOf(TFontRun));
      P.Options := STRID_COMPRESSED + STRID_RICH;
      PXLSStringRich(P).FormatCount := FontRunCount;
    end
    else begin
      GetMem(P,SizeOf(TXLSString) + Length(S));
      P.Options := STRID_COMPRESSED;
    end;
    P.Hash := Hash;
    P.Index := Index;
    P.RefCount := 1;
    P.Len := Length(S);
    Move(Pointer(S)^,GetDataPointer(P)^,Length(S));
    if Index >= 0 then begin
      FSST.Insert(Index,P);
      Result := FSST[Index];
      for i := Index + 1 to FSST.Count - 1 do
        PXLSString(FSST[i]).Index := PXLSString(FSST[i]).Index + 1;
    end
    else begin
      FSST.Add(P);
      P.Index := FSST.Count - 1;
      Result := FSST[P.Index];
    end
  end
  else begin
    Inc(PXLSString(FSST[Index]).RefCount);
    Result := PXLSString(FSST[Index]);
  end;
end;

function TSST2.AddUnicodeString(S: WideString; FontRunCount: integer = 0): PXLSString;
var
  i,Index: integer;
  Hash: longword;
  P: PXLSString;
begin
  Index := -1;
  Inc(FTotalCount);
  Hash := StrHashCode(Pointer(S)^,Length(S) * 2);
  if FIsUpdating or not HashFind(Hash,Pointer(S),Length(S),Index) then begin
    if FontRunCount > 0 then begin
      GetMem(P,SizeOf(TXLSStringRichUC) + (Length(S) * 2) + FontRunCount * SizeOf(TFontRun));
      P.Options := STRID_UNICODE + STRID_RICH;
      PXLSStringRichUC(P).FormatCount := FontRunCount;
    end
    else begin
      GetMem(P,SizeOf(TXLSStringUC) + Length(S) * 2);
      P.Options := STRID_UNICODE;
    end;
    P.Hash := Hash;
    P.Index := Index;
    P.RefCount := 1;
    P.Len := Length(S);
    Move(Pointer(S)^,GetDataPointer(P)^,Length(S) * 2);
    if Index >= 0 then begin
      FSST.Insert(Index,P);
      for i := Index + 1 to FSST.Count - 1 do
        PXLSString(FSST[i]).Index := PXLSString(FSST[i]).Index + 1;
      Result := FSST[Index];
    end
    else begin
      FSST.Add(P);
      P.Index := FSST.Count - 1;
      Result := FSST[P.Index];
    end;
  end
  else begin
    Inc(PXLSString(FSST[Index]).RefCount);
    Result := PXLSString(FSST[Index]);
  end;
end;

function TSST2.IsUnicode(S: WideString): boolean;
var
  i: integer;
  W: word;
begin
  for i := 1 to Length(S) do begin
    W := Word(S[i]);
    if (W and $FF00) <> 0 then begin
      Result := True;
      Exit;
    end;
  end;
  Result := False;
end;

function TSST2.AddString(S: WideString): PXLSString;
begin
  if IsUnicode(S) then
    Result := AddUnicodeString(S)
  else
    Result := AddCompressedString(S);
end;

function TSST2.AddRichString(S: WideString; FontRunCount: integer): PXLSString;
begin
  if IsUnicode(S) then
    Result := AddUnicodeString(S,FontRunCount)
  else
    Result := AddCompressedString(S,FontRunCount);
end;

procedure TSST2.Clear;
var
  i: integer;
begin
  FTotalCount := 0;
  for i := 0 to FSST.Count - 1 do
    FreeMem(FSST[i]);
  FSST.Clear;
  FExtSST.Clear;
  FIsUpdating := False;
end;

constructor TSST2.Create(Fonts: TXFonts);
begin
  FFonts := Fonts;
  FIsUpdating := False;
  FSST := TList.Create;
  FExtSST := TExtSST.Create;
end;

destructor TSST2.Destroy;
begin
  Clear;
  FSST.Free;
  FExtSST.Free;
  inherited;
end;