sst2.pas

一个经典的读写Excel的控件

      GetMem(Result,SizeOf(TXLSStringFarEastRichUC) + MemLen + FmtCount * SizeOf(TFontRun) + FarEastDataSize);
      ReadString(@PXLSStringFarEastRichUC(Result).Data,Len,True);
      ReadData(Pointer(Integer(@PXLSStringFarEastRichUC(Result).Data) + StrMemLen),FmtCount * SizeOf(TFormatRun));
      ConvertFormatRunsToFonts(Pointer(Integer(@PXLSStringFarEastRichUC(Result).Data) + StrMemLen),FmtCount);
      ReadData(Pointer(Integer(@PXLSStringFarEastRichUC(Result).Data) + StrMemLen + FmtCount * SizeOf(TFontRun)),FarEastDataSize);
      PXLSStringFarEastRichUC(Result).FormatCount := FmtCount;
      PXLSStringFarEastRichUC(Result).FarEastDataSize := FarEastDataSize;
      PXLSStringFarEastRichUC(Result).Hash := GetHashCode(PXLSStringFarEastRichUC(Result).Data,StrMemLen);
    end;
    else
      raise Exception.CreateFmt('STT: Unhandled string type in Read (%.2X)',[Options]);
  end;
  PXLSString(Result).Index := FSST.Count;
  PXLSString(Result).Len := Len;
  // RefCount is increased when the cell is read.
  PXLSString(Result).RefCount := 0;
  PXLSString(Result).Options := Options;
end;

procedure TSST2.Write(Stream: TXLSStream);
var
  i,RecPos: integer;
  RecSize: integer;
  W: word;

procedure WriteCONTINUE;
begin
  Stream.Seek(RecPos,soFromBeginning);
  W := FMaxBufSize - RecSize;
  Stream.Write(W,2);
  Stream.Seek(0,soFromEnd);
  Stream.WriteHeader(BIFFRECID_CONTINUE,0);
  RecPos := Stream.Pos - 2;
  RecSize := FMaxBufSize;
end;

procedure WriteString(P: PByteArray; Len: word; IsUnicode: boolean);
var
  Options: byte;
  IsSplittedChar: boolean;
begin
  if Len > RecSize then begin
    // Do not split unicode characters
    IsSplittedChar := IsUnicode and Odd(Len - RecSize);
    if IsSplittedChar then
      Dec(RecSize);
    Stream.Write(P^,RecSize);
    Dec(Len,RecSize);
    P := PByteArray(Integer(P) + RecSize);
    if IsSplittedChar then
      RecSize := 1
    else
      RecSize := 0;
    WriteCONTINUE;
    if IsUnicode then
      Options := $01
    else
      Options := $00;
    Dec(RecSize,Stream.Write(Options,1));
    WriteString(P,Len,IsUnicode);
  end
  else
    Dec(RecSize,Stream.Write(P^,Len));
end;

procedure WriteData(P: PByteArray; Len: word);
begin
  if Len > RecSize then begin
    Stream.Write(P^,RecSize);
    Dec(Len,RecSize);
    P := PByteArray(Integer(P) + RecSize);
    RecSize := 0;
    WriteCONTINUE;
    WriteData(P,Len);
  end
  else
    Dec(RecSize,Stream.Write(P^,Len));
end;

procedure WriteRichData(P: PByteArray; Count: integer);
var
  i: integer;
  pFnt: PFontRun;
begin
  for i := 0 to Count - 1 do begin
    if RecSize < SizeOf(TFormatRun) then begin
      RecSize := 0;
      WriteCONTINUE;
    end;
    pFnt := PFontRun(Integer(P) + (i * SizeOf(TFontRun)));
    Dec(RecSize,Stream.Write(pFnt.Index,2));
    Dec(RecSize,Stream.Write(pFnt.Font.Index,2));
  end;
end;

begin
  // FFonts can be Nil if SST only is used by external seek, and only string
  // values are read (and is used).
  if FFonts = Nil then
    raise Exception.Create('Can not write SST when FFonts = Nil');
  FExtSST.StringCount := FSST.Count;
  RecSize := FMaxBufSize;
  Stream.WriteHeader(BIFFRECID_SST,0);
  RecPos := Stream.Pos - 2;
  Dec(RecSize,Stream.Write(FTotalCount,4));
  Dec(RecSize,Stream.Write(FSST.Count,4));
  for i := 0 to FSST.Count - 1 do begin
    if (i mod FExtSST.BucketSize) = 0 then
      FExtSST.Add(Stream.Pos,Stream.Pos - RecPos + SizeOf(TBIFFHeader) - 2);

    // Don't split string headers over CONTINUE records
    if RecSize <= 15 then
      WriteCONTINUE;
    Dec(RecSize,Stream.Write(PXLSString(FSST[i]).Len,2));
    Dec(RecSize,Stream.Write(PXLSString(FSST[i]).Options,1));
    case PXLSString(FSST[i]).Options of
      STRID_COMPRESSED: begin
        with PXLSString(FSST[i])^ do
          WriteString(PByteArray(@Data),Len,False);
      end;
      STRID_UNICODE: begin
        with PXLSStringUC(FSST[i])^ do
          WriteString(PByteArray(@Data),Len * 2,True);
      end;
      STRID_RICH: begin
        with PXLSStringRich(FSST[i])^ do begin
          Dec(RecSize,Stream.Write(FormatCount,2));
          WriteString(PByteArray(@Data),Len,False);
          WriteRichData(Pointer(Integer(@Data) + Len),FormatCount);
        end;
      end;
      STRID_RICH_UNICODE: begin
        with PXLSStringRichUC(FSST[i])^ do begin
          Dec(RecSize,Stream.Write(FormatCount,2));
          WriteString(PByteArray(@Data),Len * 2,False);
          WriteRichData(Pointer(Integer(@Data) + Len * 2),FormatCount);
        end;
      end;
      STRID_FAREAST: begin
        with PXLSStringFarEast(FSST[i])^ do begin
          Dec(RecSize,Stream.Write(FarEastDataSize,4));
          WriteString(PByteArray(@Data),Len,False);
          WriteData(Pointer(Integer(@Data) + Len),FarEastDataSize);
        end;
      end;
      STRID_FAREAST_RICH: begin
        with PXLSStringFarEastRich(FSST[i])^ do begin
          Dec(RecSize,Stream.Write(FormatCount,2));
          Dec(RecSize,Stream.Write(FarEastDataSize,4));
          WriteString(PByteArray(@Data),Len,False);
          WriteRichData(Pointer(Integer(@Data) + Len),FormatCount);
          WriteData(Pointer(Integer(@Data) + Len + FormatCount * SizeOf(TFormatRun)),FarEastDataSize);
        end;
      end;
      STRID_FAREAST_UC: begin
        with PXLSStringFarEastUC(FSST[i])^ do begin
          Dec(RecSize,Stream.Write(FarEastDataSize,4));
          WriteString(PByteArray(@Data),Len * 2,False);
          WriteData(Pointer(Integer(@Data) + Len * 2),FarEastDataSize);
        end;
      end;
      STRID_FAREAST_RICH_UC: begin
        with PXLSStringFarEastRichUC(FSST[i])^ do begin
          Dec(RecSize,Stream.Write(FormatCount,2));
          Dec(RecSize,Stream.Write(FarEastDataSize,4));
          WriteString(PByteArray(@Data),Len * 2,False);
          WriteRichData(Pointer(Integer(@Data) + Len * 2),FormatCount);
          WriteData(Pointer(Integer(@Data) + Len * 2 + FormatCount * SizeOf(TFormatRun)),FarEastDataSize);
        end;
      end;
      else
        raise Exception.CreateFmt('STT: Unhandled string type in Write (%.2X) # %d',[PXLSString(FSST[i]).Options,i]);
    end;
  end;
  Stream.Seek(RecPos,soFromBeginning);
  W := FMaxBufSize - RecSize;
  Stream.Write(W,2);
  Stream.Seek(0,soFromEnd);
  FExtSST.Write(Stream);
  FExtSST.Clear;
end;

function TSST2.StrSeek(Stream: TXLSStream; ExtSSTPos,Index: integer): WideString;
var
  i,j: integer;
  Header: TBIFFHeader;
  Rec: TRecEXTSST;
  Bucket: TRecISSTINF;
  BucketPos,BucketOffs: integer;
  RecSize: word;
  P,pData: PByteArray;
begin
  pData := Nil;
  Stream.Seek(ExtSSTPos,soFromBeginning);
  Stream.ReadHeader(Header);
  if Header.RecID <> BIFFRECID_EXTSST then
    raise Exception.Create('Expected record missing: EXTSST');
  Stream.Read(Rec,SizeOf(TRecEXTSST));
  BucketPos := (Index div Rec.BucketSize) * SizeOf(TRecISSTINF);
  BucketOffs := Index mod Rec.BucketSize;
  Stream.Seek(BucketPos,soFromCurrent);
  Stream.Read(Bucket,SizeOf(TRecISSTINF));

  Stream.Seek(Bucket.Pos - Bucket.Offset,soFromBeginning);
  Stream.ReadHeader(Header);
  if (Header.RecId <> BIFFRECID_SST) and (Header.RecId <> BIFFRECID_CONTINUE) then
    raise Exception.Create('Expected record missing: SST or CONTINUE');
  RecSize := Header.Length - Bucket.Offset + 4;
  Stream.Seek(Bucket.Pos,soFromBeginning);
  P := Nil;
  try
    for i := 0 to BucketOffs do begin
      P := StreamReadString(Stream,RecSize);
      case PXLSString(P).Options of
        STRID_COMPRESSED     : pData := @PXLSString(P).Data;
        STRID_UNICODE        : pData := @PXLSStringUC(P).Data;
        STRID_RICH           : pData := @PXLSStringRich(P).Data;
        STRID_RICH_UNICODE   : pData := @PXLSStringRichUC(P).Data;
        STRID_FAREAST        : pData := @PXLSStringFarEast(P).Data;
        STRID_FAREAST_UC     : pData := @PXLSStringFarEastUC(P).Data;
        STRID_FAREAST_RICH   : pData := @PXLSStringFarEastRich(P).Data;
        STRID_FAREAST_RICH_UC: pData := @PXLSStringFarEastRichUC(P).Data;
        else
          raise Exception.Create('STT: Unhandled string type.');
      end;
      SetLength(Result,PXLSString(P).Len);
      if (PXLSString(P).Options and $01) = $01 then
        Move(pData^,Pointer(Result)^,PXLSString(P).Len * 2)
      else begin
        for j := 1 to PXLSString(P).Len do
          Result[j] := WideChar(pData[j - 1]);
      end;
    end;
  finally
    FreeMem(P);
  end;
end;

procedure TSST2.Sort;

function SortCompare(const Item1, Item2: PXLSString): Integer;
begin
  Result := Item1.Hash - Item2.Hash;
end;

procedure ShellSort;
var
  gap, hi, low,sz : integer;
  T : PXLSString;
begin
  sz := FSST.Count;
  gap := 1;
  repeat
    gap := 3 * gap + 1;
  until (gap >= sz);
  gap := gap div 3;
  while gap >= 1 do begin
    for hi := gap to sz - 1 do begin
      T := FSST[hi];
      low := hi - gap;
      while (low >= 0) and (T.Hash < PXLSString(FSST[low]).Hash) do begin
        FSST[low + gap] := FSST[low];
        PXLSString(FSST[low + gap]).Index := low + gap;
        Dec(low,gap);
      end;
      FSST[low + gap] := T;
      PXLSString(FSST[low + gap]).Index := low + gap;
    end;
    gap := gap div 3;
  end;
end;


procedure QuickSort(Start,Stop: integer);
var
  Left, Right: Integer;
  T: PXLSString;
  V: longword;
begin
  Left  := Start;
  Right := Stop;
  V := PXLSString(FSST[(Start + Stop) shr 1]).Hash;
  repeat
    while PXLSString(FSST[Left]).Hash < V do Inc(Left);
    while V <  PXLSString(FSST[Right]).Hash do Dec(Right);
    if Left <= Right then
    begin
      T := FSST[Left];
      FSST[Left] := FSST[Right];
      FSST[Right] := T;
      PXLSString(FSST[Left]).Index := Left;
      PXLSString(FSST[Right]).Index := Right;
      Inc(Left);
      Dec(Right);
    end;
  until Left > Right;
  if Start < Right then QuickSort(Start,Right);
  if Left < Stop then QuickSort(Left,Stop);
end;

begin
  if FSST.Count < 2 then
    Exit;
//  ShellSort;
  QuickSort(0,FSST.Count - 1);
end;

function TSST2.GetSST(Index: integer): PXLSString;
begin
  Result := FSST[Index];
end;

function TSST2.Check: boolean;
var
  i: integer;
begin
  Result := True;
  for i := 0 to FSST.Count - 2 do begin
    if PXLSString(FSST[i]).Hash > PXLSString(FSST[i + 1]).Hash then begin
      Result := False;
      Exit;
    end;
  end;
end;

procedure TSST2.BeginUpdate;
begin
  FIsUpdating := True;
end;

procedure TSST2.EndUpdate;
begin
  FIsUpdating := False;
  Sort;
end;

{ TExtSST }

procedure TExtSST.Add(StreamPos: longword; RecPos: word);
var
  P: PExtSSTRec;
begin
  New(P);
  P.StreamPos := StreamPos;
  P.RecPos := RecPos;
  inherited Add(P);
end;

procedure TExtSST.Clear;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    FreeMem(Items[i]);
  inherited;
end;

procedure TExtSST.SetStringCount(const Value: integer);
begin
//  FBucketSize := Value div ((MAXRECSZ_97 - SizeOf(TRecEXTSST) div SizeOf(TRecISSTINF))) + 1;
  FBucketSize := (Value * SizeOf(TRecISSTINF)) div (MAXRECSZ_97 - SizeOf(TRecEXTSST)) + 1;
  if FBucketSize < 8 then
    FBucketSize := 8;
end;

procedure TExtSST.Write(Stream: TXLSStream);
var
  i: integer;
  Rec: TRecISSTINF;
begin
  Stream.WriteHeader(BIFFRECID_EXTSST,SizeOf(TRecEXTSST) + Count * SizeOf(TRecISSTINF));
  Stream.WWord(FBucketSize);
  for i := 0 to Count - 1 do begin
    Rec.Pos := PExtSSTRec(Items[i]).StreamPos;
    Rec.Offset := PExtSSTRec(Items[i]).RecPos;
    Rec.Reserved := 0;
    Stream.Write(Rec,SizeOf(TRecISSTINF));
  end;
end;

end.