xlsfile3.pas

Advanced Data Import Component Suite for Borland Delphi and C++ Builder allows you to import your da

    varBoolean: SetAsBoolean(Value);
    varOleStr,
    varString: begin
      Data[7] := 1;
      Data[6] := StringToErrcode(Value);
    end;
    varNull: raise ExlsFileError.CreateFmt(sInvalidCellValue, ['']);

    else raise Exception.CreateFmt(sInvalidCellValue, [VarAsType(Value, varString)]);
  end;
end;

function TbiffBoolErr.GetAsString: WideString;
begin
  if GetAsBoolean
    then Result := 'true'
    else Result := 'false';
end;

procedure TbiffBoolErr.SetAsString(const Value: WideString);
begin
  if AnsiCompareText(Value, 'true') = 0
    then SetAsBoolean(true)
    else SetAsBoolean(false);
end;

{ TbiffNumber }

function TbiffNumber.GetAsFloat: double;
var
  D: double;
begin
  Move(Data[6], D, SizeOf(d));
  Result := D;
end;

procedure TbiffNumber.SetAsFloat(Value: double);
var
  D: double;
begin
  D := Value;
  Move(D, Data[6], SizeOf(D));
end;

function TbiffNumber.GetAsDateTime: TDateTime;
begin
  Result := GetAsFloat;
end;

procedure TbiffNumber.SetAsDateTime(Value: TDateTime);
begin
  SetAsFloat(Value);
end;

function TbiffNumber.GetAsVariant: variant;
begin
  Result := GetAsFloat;
end;

procedure TbiffNumber.SetAsVariant(Value: variant);
begin
  SetAsFloat(Value);
end;

function TbiffNumber.GetAsString: WideString;
begin
  if GetCellType = bctNumeric then
    Result := FloatToStr(GetAsFloat)
  else begin
    if IsDateOnly then
      Result := DateToStr(GetAsDateTime)
    else if IsTimeOnly then
      Result := TimeToStr(GetAsDateTime)
    else Result := DateTimeToStr(GetAsDateTime);
  end;
end;

procedure TbiffNumber.SetAsString(const Value: WideString);
var
  D: double;
begin
  D := StrToFloat(Value);
  SetAsFloat(D);
end;

{ TbiffRK }

function TbiffRK.GetCellType: TbiffCellType;
begin
  if CellIsDateTime(Self)
    then Result := bctDateTime
    else Result := bctNumeric;
end;

function TbiffRK.GetAsFloat: double;
var
  RK, PD: ^longint;
  D: double;
begin
  RK := @(Data[6]);
  if RK^ and $2 = $2 then // integer
    if RK^ and (1 shl 31) = (1 shl 31) // negative
      then D := not (not (RK^) shr 2)
      else D := RK^ shr 2
  else begin
    PD := @D;
    PD^ := 0;
    Inc(PD);
    PD^ := RK^ and $FFFFFFFC;
  end;

  Result := D;
  if RK^ and $1 = $1 then Result := Result / 100;
end;

procedure TbiffRK.SetAsFloat(Value: double);
var
  RK: ^longint;
begin
  RK := @(Data[6]);
  if not EncodeRK(Value, RK^) then
    raise ExlsFileError.CreateFmt(sInvalidCellValue, [FloatToStr(Value)]);
end;

function TbiffRK.GetAsDateTime: TDateTime;
begin
  Result := GetAsFloat;
end;

procedure TbiffRK.SetAsDateTime(Value: TDateTime);
begin
  SetAsFloat(Value);
end;

function TbiffRK.GetAsVariant: variant;
begin
  Result := GetAsFloat;
end;

procedure TbiffRK.SetAsVariant(Value: variant);
begin
  SetAsFloat(Value);
end;

function TbiffRK.GetAsString: WideString;
begin
  if GetCellType = bctNumeric then
    Result := FloatToStr(GetAsFloat)
  else begin
    if IsDateOnly then
      Result := DateToStr(GetAsDateTime)
    else if IsTimeOnly then
      Result := TimeToStr(GetAsDateTime)
    else Result := DateTimeToStr(GetAsDateTime);
  end;
end;

procedure TbiffRK.SetAsString(const Value: WideString);
var
  D: double;
  DT: TDateTime;
begin
  if GetCellType = bctNumeric then begin
    D := StrToFloat(Value);
    SetAsFloat(D);
  end
  else begin
    DT := StrToDateTime(Value);
    SetAsDateTime(DT);
  end;
end;

{ TxlsString }

constructor TxlsString.CreateR(IsWideStr: boolean; var ARecord: TbiffRecord;
  var Offset: integer);
var
  ByteLength: byte;
  RealOptionFlags: byte;
  DestPos: integer;
begin
  inherited Create;
  FIsWideStr := IsWideStr;
  if not FIsWideStr then begin
    ReadMem(ARecord, Offset, LenOfLen, @ByteLength);
    FStrLen := ByteLength
  end
  else
    ReadMem(ARecord, Offset, LenOfLen, @FStrLen);

  ReadMem(ARecord, Offset, SizeOf(FOptionFlags), @FOptionFlags);
  RealOptionFlags := FOptionFlags;

  if HasRichText
    then ReadMem(ARecord, Offset, SizeOf(FRTFNumber), @FRTFNumber)
    else FRTFNumber := 0;

  if HasFarEast
    then ReadMem(ARecord, Offset, SizeOf(FFarEastDataSize), @FFarEastDataSize)
    else FFarEastDataSize := 0;

  DestPos := 0;
  SetLength(FShortData, FStrLen);
  SetLength(FWideData, FStrLen);
  ReadStr(ARecord, Offset, FShortData, FWideData, FOptionFlags, RealOptionFlags,
    DestPos, FStrLen);
  if (Integer(HasWideChar) + 1) = 1
    then FWideData := EmptyStr
    else FShortData := {$IFDEF VCL12}EmptyAnsiStr{$ELSE}EmptyStr{$ENDIF};

  if FRTFNumber > 0 then begin
    GetMem(FRTFData, 4 * FRTFNumber);
    ReadMem(ARecord, Offset, 4 * FRTFNumber, FRTFData);
  end;

  if FFarEastDataSize > 0 then begin
    GetMem(FFarEastData, FFarEastDataSize);
    ReadMem(ARecord, Offset, FFarEastDataSize, FFarEastData)
  end;
end;

constructor TxlsString.CreateWS(IsWideStr: boolean; const Str: WideString);
begin
  inherited Create;
  FIsWideStr := IsWideStr;
  if (not FIsWideStr) and (Length(Str) > $FF) then
    raise ExlsFileError.Create(sInvalidStringRecord);

  FStrLen := Length(Str);

  FOptionFlags := 0;
  if IsWide(Str) then FOptionFlags := 1;

  FRTFNumber := 0;
  FFarEastDataSize := 0;

  if not GetHasWideChar
    then FShortData := WideStringToStringNoCodePage(Str)
    else FWideData := Str;
end;

function TxlsString.GetLenOfLen: byte;
begin
  Result := Byte(FIsWideStr) + 1;
end;

function TxlsString.GetHasWideChar: boolean;
begin
  Result :=  not (FOptionFlags and $1 = 0);
end;

function TxlsString.GetFarEast: boolean;
begin
  Result := FOptionFlags and $4 = $4;
end;

function TxlsString.GetHasRichText: boolean;
begin
  Result := FOptionFlags and $8 = $8;
end;

function TxlsString.GetValue: WideString;
begin
  if not GetHasWideChar
    then Result := StringToWideStringNoCodePage(FShortData)
    else Result := WideData;
end;

function TxlsString.Compare(Str: TxlsString): integer;
begin
  if LenOfLen < Str.LenOfLen then begin
    Result := -1;
    Exit;
  end
  else if LenOfLen > Str.LenOfLen then begin
    Result := 1;
    Exit;
  end;

  if FOptionFlags < Str.OptionFlags then begin
    Result := -1;
    Exit;
  end
  else if FOptionFlags > Str.OptionFlags then begin
    Result := 1;
    Exit;
  end;

  if not GetHasWideChar
    then Result := CompareStr(String(FShortData), String(Str.ShortData))
    else Result:= CompareWideStr(FWideData, Str.WideData);
end;

{ TxlsSSTEntry }

constructor TxlsSSTEntry.CreateXS(Str: TxlsString);
begin
  inherited Create;
  FValue := Str;
end;

constructor TxlsSSTEntry.CreateWS(Str: WideString);
begin
  inherited Create;
  FValue := TxlsString.CreateWS(true, Str);
end;

destructor TxlsSSTEntry.Destroy;
begin
  if Assigned(FOnDestroy) then FOnDestroy(Self);
  if Assigned(FValue) then FValue.Free;
  inherited;
end;

procedure TxlsSSTEntry.IncRef;
begin
  Inc(FRefCount);
end;

procedure TxlsSSTEntry.DecRef;
begin
  Dec(FRefCount);
end;

{ TbiffLabelSST }

function TbiffLabelSST.GetCellType: TbiffCellType;
begin
  Result := bctString;
end;

constructor TbiffLabelSST.Create(Section: TxlsSection; ID, DataSize: word;
  Data: PByteArray);
var
  l: integer;
begin
  inherited;
  l := GetInteger(Data, 6);
  if l >= SSTList.Count then
    raise ExlsFileError.Create(sExcelInvalid);

  FSSTEntry := SSTList[l];
  FSSTEntry.IncRef;
  FSSTEntry.OnDestroy := DestroySSTEntry;
end;

destructor TbiffLabelSST.Destroy;
begin
  if Assigned(FSSTEntry) then FSSTEntry.DecRef;
  inherited;
end;

function TbiffLabelSST.GetAsString: WideString;
begin
  Result := FSSTEntry.Value.Value;
end;

procedure TbiffLabelSST.SetAsString(const Value: WideString);
var
  OldSSTEntry: TxlsSSTEntry;
begin
  OldSSTEntry := FSSTEntry;
  FSSTEntry := SSTList[SSTList.AddString(Value)];
  if Assigned(OldSSTEntry) then OldSSTEntry.DecRef;
end;

function TbiffLabelSST.GetAsVariant: variant;
begin
  Result := GetAsString;
end;

procedure TbiffLabelSST.SetAsVariant(Value: variant);
begin
  SetAsString(Value);
end;

procedure TbiffLabelSST.DestroySSTEntry(Sender: TObject);
begin
  FSSTEntry := nil;
end;

{ ETokenException }

constructor ETokenException.Create(Token: integer);
begin
  FToken := Token;
  inherited CreateFmt(sBadToken, [FToken]);
end;

{ TbiffFormula }

constructor TbiffFormula.Create(Section: TxlsSection; ID, DataSize: word;
  Data: PByteArray);
var
  D: double;
begin
  inherited;
  FValue := NULL;
  if GetWord(Data, 12) <> $FFFF then begin // numeric
    Move(Data[6], D, SizeOf(d));
    FValue := D;
  end else begin
    case Data[6] of
      0: FValue := {$IFDEF VCL12}EmptyAnsiStr{$ELSE}EmptyStr{$ENDIF}; // string
      1: FValue := Data[8] = 1; // boolean
      //2 is error. we can't codify this on a variant.
    end;
  end;

  FillChar(Data^[6], 8, 0);
  Data^[6] := 2; //error value
  SetWord(Data, 12, $FFFF);
  FillChar(Data^[16], 4, 0);

  Data^[14] := Data^[14] or 2;
end;

procedure TbiffFormula.MixShared(SharedData: PByteArray;
  SharedDataSize: integer);
var
  NewDataSize: integer;
begin
  // Note: This method changes the size of the record without notifying
  NewDataSize := DataSize - 5 + SharedDataSize - 8;
  ReallocMem(FData, NewDataSize);
  DataSize := NewDataSize;
  Move(SharedData[8], Data[20], SharedDataSize - 8);

  try
    ArrangeSharedFormulas;
  except
    on E: ETokenException do
      raise Exception.CreateFmt(sBadFormula, [Row + 1, Col + 1, E.Token]);
    else raise;
  end;
end;

function TbiffFormula.GetIsFormula: boolean;
begin
  Result := true;
end;

function TbiffFormula.GetAsVariant: variant;
begin
  Result := FValue;
end;

procedure TbiffFormula.SetAsVariant(Value: variant);
begin
  FValue := Value;
end;

function TbiffFormula.GetAsString: WideString;
begin
  Result := VarToStr(GetAsVariant);
end;

procedure TbiffFormula.SetAsString(const Value: WideString);
begin
  SetAsVariant(Value);
end;

function TbiffFormula.GetIsExp: boolean;
begin
  Result := (DataSize = 27) and (GetWord(Data, 20) = 5) and (Data[22] = 1);
end;

function TbiffFormula.GetKey: cardinal;
begin
  Result := 0;
  if GetIsExp then
    Result := GetWord(Data, 23) or (GetWord(Data, 25) shl 16);
end;

procedure TbiffFormula.ArrangeSharedFormulas;
var
  S, F: integer;
  Token: byte;

  procedure ArrangeOperand;
  var
    AbsRef: boolean;
  begin
    if Token in [ptgRefN, ptgRefNV, ptgRefNA,
                 ptgAreaN, ptgAreaNV, ptgAreaNA] then
    begin
      Dec(Data[S], 8);
      Token := Data[S];
    end;

    Inc(S);

    if Token in [ptgRef3d, ptgRef3dV, ptgRef3dA,
                 ptgArea3d, ptgArea3dV, ptgArea3dA,
                 ptgRefErr3d, ptgRefErr3dV, ptgRefErr3dA,
                 ptgAreaErr3d, ptgAreaErr3dV, ptgAreaErr3dA] then begin
      Inc(S, 2);
    end;

    case Token of
      ptgArray,
      ptgArrayV, ptgArrayA: Inc(S, 7);

      ptgName,
      ptgNameV, ptgNameA: Inc(S, 4);

      ptgNameX,
      ptgNameXV, ptgNameXA: Inc(S, 6);

      ptgRef,
      ptgRefV, ptgRefA,
      ptgRefErr,
      ptgRefErrV, ptgRefErrA,
      ptgRef3d,
      ptgRef3dV, ptgRef3dA,
      ptgRefErr3d,
      ptgRefErr3dV, ptgRefErr3dA: begin
        // row defined absolutely
        AbsRef := (GetWord(Data, S + 2) and $8000) <> $8000;
        if not AbsRef then Data[S] := Data[S] + Row;
        // col defined absolutely
        AbsRef := (GetWord(Data, S + 2) and $4000) <> $4000;
        if not AbsRef then Data[S + 2] := Data[S + 2] + Col;
        Inc(S, 4);
      end;

      ptgRefN,
      ptgRefNV, ptgRefNA: Inc(S, 4);

      ptgArea,
      ptgAreaV, ptgAreaA,
      ptgAreaErr,
      ptgAreaErrV, ptgAreaErrA,