xlsnames2.pas

一个经典的读写Excel的控件

function TExternalNames.ExtSeekValue(Filename: WideString; SheetIndex, Col, Row: integer): TFormulaValue;
begin
  FExtSeek.Filename := Filename;
  if FExtSeek.Seek(SheetIndex,Col,Row) then
    Result := FExtSeek.Value
  else
    FVSetError(Result,errValue);
end;

function TExternalNames.GetAsString(SheetIndex, NameIndex: integer): WideString;
var
  i,j: integer;
  S: WideString;
begin
  i := FExtSheets[SheetIndex].SupBookIndex;
  Result := FSupBooks[i].Filename;
  if NameIndex >= 0 then
    Result := Result + FSupBooks[i].ExtNames[NameIndex - 1].Name
  else begin
    j := FExtSheets[SheetIndex].FirstTab;
    if (j >= 0) and (j <= $FF) then
      S := FSupBooks[i].Sheets[j].Name;
    Result := '''' + Result + S + '''!';
  end;
end;

function TExternalNames.GetNameValue(SheetIndex, NameIndex: integer): TFormulaValue;
var
  SupBook: integer;
  Ref: PPTGRef3d8;
  Name: TExtNameName;
begin
  if (SheetIndex < 0) or (SheetIndex >= FExtSheets.Count) then
    raise Exception.Create('Extrensheet index out of range.');
  if (FExtSheets[SheetIndex].FirstTab <= $00FF) or (FExtSheets[SheetIndex].LastTab <= $00FF) then
    raise Exception.Create('Extern name is a reference.');
  SupBook := FExtSheets[SheetIndex].SupBookIndex;
  case FSupBooks[SupBook].FExtNames[NameIndex - 1].NameType of
    entName : begin
      Name := TExtNameName(FSupBooks[SupBook].FExtNames[NameIndex - 1]);
      if (Length(Name.NameDef) > 0) and (Name.NameDef[0] = ptgRef3d) then begin
        // There is a dog burried here... PPTGRef3d8 shall follows imidiatelly after ptgRef3d
        // but there are two extra bytes, that seems to repeat the index.
        Ref := PPTGRef3d8(@Name.NameDef[3]);
        Result := FSupBooks[SupBook].Sheets[Ref.Index].GetCachedValue(Ref.Col and $3FFF,Ref.Row);
      end
      else
        raise Exception.Create('Name def error for external value.');
    end;
    entDDE:
      raise Exception.Create('Can not access DDE values.');
    entOLE:
      raise Exception.Create('Can not access OLE values.');
  end;
end;

function TExternalNames.GetValue(Index, Col, Row: integer): TFormulaValue;
var
  SupBook: integer;

function DoLookup: boolean;
var
  S: WideString;
begin
  Result := False;
  S := FFilepath + FSupBooks[SupBook].Filename;
  if FileExists(S) then begin
    FExtSeek.Filename := S;
    if FExtSeek.Seek(FExtSheets[Index].FirstTab,Col,Row) then
      Result := True;
  end;
end;

begin
  if (FExtSheets[Index].FirstTab > $00FF) or (FExtSheets[Index].LastTab > $00FF) then
    raise Exception.Create('Extern name is a reference.');
  SupBook := FExtSheets[Index].SupBookIndex;
  case FExternalLookup of
    elFail:
      FVSetError(Result,errValue);
    elCached:
      Result := FSupBooks[SupBook].Sheets[FExtSheets[Index].FirstTab].GetCachedValue(Col and $3FFF,Row);
    elLookup: begin
      if DoLookup then
        Result := FExtSeek.Value
      else
        FVSetError(Result,errValue);
    end;
    elCachedIfNoLookup: begin
      if DoLookup then
        Result := FExtSeek.Value
      else
        Result := FSupBooks[SupBook].Sheets[FExtSheets[Index].FirstTab].GetCachedValue(Col and $3FFF,Row);
    end;
  end;
end;

function TExternalNames.IsSelf(SheetIndex: integer): integer;
var
  i: integer;
begin
  i := FExtSheets[SheetIndex].SupBookIndex;
  if FSupBooks[i].FEncoded = $0401 then
    Result := FExtSheets[SheetIndex].FirstTab
  else
    Result := -1;
end;

procedure TExternalNames.SetCRN(SheetIndex: integer; P: PRecCRN; Size: word);
begin
  if FSupBooks.Count <= 0 then
    raise Exception.Create('No SUPBOOK for CRN');
  if SheetIndex >= FSupBooks[FSupBooks.Count - 1].Count then
    raise Exception.Create('Invalid SUPBOOK Sheet Index');
  FSupBooks[FSupBooks.Count - 1].Sheets[SheetIndex].SetCRN(P,Size);
end;

procedure TExternalNames.SetEXTERNNAME(P: PRecEXTERNNAME8);
begin
  FSupBooks[FSupBooks.Count - 1].SetEXTERNNAME(P);
end;

procedure TExternalNames.SetEXTERNSHEET(P: PByteArray);
var
  i: integer;
begin
  for i := 0 to PRecEXTERNSHEET8(P).XTICount - 1 do
    FExtSheets.Add(PRecEXTERNSHEET8(P).XTI[i].SupBook,PRecEXTERNSHEET8(P).XTI[i].FirstTab,PRecEXTERNSHEET8(P).XTI[i].LastTab);
end;

procedure TExternalNames.SetSUPBOOK(P: PRecSUPBOOK);
begin
  FSupBooks.Add(P);
end;

procedure TExternalNames.UpdateIntSupbooks(TabCount: integer);
var
  i,j: integer;
begin
  for i := 0 to FSupBooks.Count - 1 do begin
    j := FExtSheets[i].SupBookIndex;
    if FSupBooks[j].FEncoded = $0401 then
      FSupBooks[j].FTabCount := TabCount;
  end;
end;

procedure TExternalNames.WriteRecords(Stream: TXLSStream);
var
  i: integer;
begin
  for i := 0 to FSupBooks.Count - 1 do
    FSupBooks[i].WriteRecords(Stream);
  FExtSheets.WriteRecords(Stream);
end;

{ TCRNList }

procedure TCRNList.Add(Value: PRecCRN; Size: word);
var
  P: PCRNValue;
begin
  New(P);
  P.FirstCol := Value.FirstCol;
  P.LastCol := Value.LastCol;
  P.Row := Value.Row;
  P.Size := Size - 4;
  GetMem(P.Value,P.Size);
  System.Move(Pointer(@Value.OPER)^,P.Value^,P.Size);
  inherited Add(P);
end;

destructor TCRNList.Destroy;
var
  i: integer;
begin
  for i := 0 to Count - 1 do begin
    FreeMem(Items[i].Value);
    FreeMem(inherited Items[i]);
  end;
  inherited;
end;

function TCRNList.GetItems(Index: integer): PCRNValue;
begin
  Result := PCRNValue(inherited Items[Index]);
end;

procedure TCRNList.WriteRecords(Stream: TXLSStream; Index: integer);
var
  i: integer;
begin
  if Count > 0 then begin
    Stream.WriteHeader(BIFFRECID_XCT,SizeOf(TRecXCT));
    Stream.WWord(Count);
    Stream.WWord(Index);
    for i := 0 to Count - 1 do begin
      Stream.WriteHeader(BIFFRECID_CRN,Items[i].Size + 4);
      Stream.WByte(Items[i].LastCol);
      Stream.WByte(Items[i].FirstCol);
      Stream.WWord(Items[i].Row);
      Stream.Write(Items[i].Value^,Items[i].Size);
    end;
  end;
end;

{ TSupBookSheet }

constructor TSupBookSheet.Create(Name: PByteArray; NameLen: integer);
begin
  FName := ExcelStrToString(Name,NameLen);
  FCRN := TCRNList.Create;
end;

constructor TSupBookSheet.Create(Sheetname: WideString);
begin
  SetName(Sheetname);
  FCRN := TCRNList.Create;
end;

destructor TSupBookSheet.Destroy;
begin
  FCRN.Free;
  inherited;
end;

function TSupBookSheet.GetCachedValue(Col, Row: integer): TFormulaValue;
var
  i,L: integer;
  pD: PDouble;
begin
  for i := 0 to FCRN.Count - 1 do begin
    if (Row = FCRN[i].Row) and (Col >= FCRN[i].FirstCol) and (Col <= FCRN[i].LastCol) then begin
      case FCRN[i].Value[0] of
        $01: begin
          pD := @FCRN[i].Value[1];
          FVSetFloat(Result,pD^);
          Exit;
        end;
        $02: begin
          L := PWordArray(@FCRN[i].Value[1])[0];
          FVSetString(Result,ByteStrToWideString(@FCRN[i].Value[3],L));
          Exit;
        end;
        $04: begin
          FVSetBoolean(Result,FCRN[i].Value[1] <> 0);
          Exit;
        end;
        $10: begin
          FVSetError(Result,TCellError(FCRN[i].Value[1]));
          Exit;
        end;
      end;
    end;
  end;
  FVSetError(Result,errValue);
end;

function TSupBookSheet.GetName: WideString;
begin
  Result := ExcelStrToWideString(FName);
end;

procedure TSupBookSheet.SetCRN(P: PRecCRN; Size: word);
begin
  FCRN.Add(P,Size);
end;

procedure TSupBookSheet.SetName(const Value: WideString);
begin
  SetLength(FName,Length(Value) * 2);
  Move(Pointer(Value)^,Pointer(FName)^,Length(Value) * 2);
  FName := #1 + FName;
end;

{ TSupBook }

procedure TSupBook.SetEXTERNNAME(P: PRecEXTERNNAME8);
begin
  FExtNames.Add(P);
end;

function TSupBook.Count: integer;
begin
  Result := Length(FSheets);
end;

constructor TSupBook.Create(P: PRecSUPBOOK);
var
  i,L: integer;
begin
  FExtNames := TExtNameList.Create;
  FTabCount := PWord(P)^;
  P := Pointer(Integer(P) + 2);
  if (PWordArray(P)[0] = $0401) or (PWordArray(P)[0] = $3A01) then begin
    FEncoded := PWordArray(P)[0];
    FFilename := '';
  end
  else begin
    SetLength(FSheets,FTabCount);
    L := PWord(P)^;
    P := Pointer(Integer(P) + 2);
    FFilename := ExcelStrToString(PByteArray(P),L);
    for i := 0 to FTabCount - 1 do begin
      if PByteArray(P)[0] = $01 then
        P := Pointer(Integer(P) + L);
      P := Pointer(Integer(P) + L + 1);
      L := PWord(P)^;
      P := Pointer(Integer(P) + 2);
      FSheets[i] := TSupBookSheet.Create(PByteArray(P),L);
    end;
  end;
end;

destructor TSupBook.Destroy;
var
  i: integer;
begin
  for i := 0 to High(FSheets) do
    FSheets[i].Free;
  SetLength(FSheets,0);
  FExtNames.Free;
  inherited;
end;

function TSupBook.GetSheets(Index: integer): TSupBookSheet;
begin
  Result := FSheets[Index];
end;

function TSupBook.GetExtNames(Index: integer): TExtName;
begin
  Result := FExtNames[Index];
end;

function TSupBook.GetFilename: string;
var
  i: integer;
  IsDDE: boolean;
begin
  IsDDE := Length(FSheets) <= 0;
  i := 2;
  if (Length(FFilename) > 2) and (FFilename[i] in [#00,#01,#02]) then
    Inc(i);
  Result := '';
  while i <= Length(FFilename) do begin
    case FFilename[i] of
      #01: begin
        if FFilename[i + 1] = '@' then
          Result := Result + '\\'
        else
          Result := FFilename[i + 1] + Result + ':\';
        Inc(i);
      end;
      #02,#03: begin
        if IsDDE then
          Result := Result + '|'
        else
          Result := Result + '\[';
      end;
      #04:
        Result := Result + '..\';
      #05,#06,#07,#08: ;
      else
        Result := Result + FFilename[i];
    end;
    Inc(i);
  end;
{
  if IsDDE then
    Result := Result + '!'
  else
    Result := Result + ']';
}
end;

procedure TSupBook.WriteRecords(Stream: TXLSStream);
var
  Sz,i: integer;
begin
  if FEncoded <> 0 then begin
    Stream.WriteHeader(BIFFRECID_SUPBOOK,4);
    Stream.WWord(FTabCount);
    Stream.WWord(FEncoded);
  end
  else begin
    // Tabs + Length filename + Filename.
    Sz := 2 + 2 + Length(FFilename);
    for i := 0 to High(FSheets) do
      Inc(Sz,2 + Length(FSheets[i].FName));
    Stream.WriteHeader(BIFFRECID_SUPBOOK,Sz);
    Stream.WWord(FTabCount);
    Stream.WriteUnicodeStr16(FFilename);
    for i := 0 to High(FSheets) do
      Stream.WriteUnicodeStr16(FSheets[i].RawName);
  end;
  for i := 0 to FExtNames.Count - 1 do
    FExtNames[i].WriteRecords(Stream);
  for i := 0 to High(FSheets) do
    FSheets[i].CRN.WriteRecords(Stream,i);
end;

constructor TSupBook.CreateEncoded(Tabs: integer; Code: word);
begin
  FExtNames := TExtNameList.Create;
  FTabCount := Tabs;
  FEncoded := Code;
  FFilename := '';
end;

procedure TSupBook.AddSheet(Sheetname: WideString);
begin
  SetLength(FSheets,Length(FSheets) + 1);
  FSheets[High(FSheets)] := TSupBookSheet.Create(Sheetname);
end;

{ TSupBookList }

procedure TSupBookList.Add(P: PRecSUPBOOK);
begin
  inherited Add(TSupBook.Create(P));
end;

procedure TSupBookList.Add(Filename, SheetName: WideString);
var
  S: string;
  SupBook: TSupBook;
begin
  SupBook := TSupBook.CreateEncoded(1,0);
  SetLength(S,Length(Filename) * 2);
  System.Move(Pointer(Filename)^,Pointer(S)^,Length(Filename) * 2);
  SupBook.FFilename := #1 + S;
  SupBook.AddSheet(Sheetname);
  inherited Add(SupBook);
end;

function TSupBookList.AddEncodec(Tabs: integer; Code: word): integer;
begin
  inherited Add(TSupBook.CreateEncoded(Tabs,Code));
  Result := Count - 1;
end;

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

destructor TSupBookList.Destroy;
begin
  Clear;
  inherited;
end;

function TSupBookList.GetItems(Index: integer): TSupBook;
begin
  Result := TSupBook(inherited Items[Index]);
end;

{ TExtNameList }

procedure TExtNameList.Add(P: PRecEXTERNNAME8);
begin
  if (P.Options and $FFFE) = $0000 then
    inherited Add(TExtNameName.Create(P))
  else if (P.Options and $0010) = $0010 then
    inherited Add(TExtNameOLE.Create(P))
  else
    inherited Add(TExtNameDDE.Create(P));
end;

destructor TExtNameList.Destroy;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    TExtName(inherited Items[i]).Free;
  inherited;
end;

function TExtNameList.GetItems(Index: integer): TExtName;
begin
  Result := TExtName(inherited Items[Index]);
end;

{ TExtNameName }

constructor TExtNameName.Create(P: PRecEXTERNNAME8);
begin
  inherited Create(P);
  // After Create, P is no more a pointer to PRecEXTERNNAME8
  if PWordArray(P)[0] > 0 then begin
    SetLength(FNameDef,PWordArray(P)[0]);
    Move(PWordArray(P)[1],FNameDef[0],PWordArray(P)[0]);
  end;
end;