cellformats2.pas

一个经典的读写Excel的控件

  if (PRecXF4(P).Data2 and $08) = $08 then FormatOptions := [foWrapText];

  case (PRecXF4(P).Data2 and $30) shr 4 of
    0: VertAlignment := cvaTop;
    1: VertAlignment := cvaCenter;
    2: VertAlignment := cvaBottom;
  end;

  if (PRecXF4(P).UsedAttributes and $20) = $20 then begin
    FillPatternPattern := TExcelFillPattern(PRecXF4(P).CellColor and $003F);
    FillPatternForeColor := TExcelColor((PRecXF4(P).CellColor and $07C0) shr 6);
    FillPatternBackColor := TExcelColor((PRecXF4(P).CellColor and $F800) shr 11);
  end;

  BorderTopStyle    := Get4BorderStyle(PRecXF4(P).TopBorder and $07);
  BorderLeftStyle   := Get4BorderStyle(PRecXF4(P).LeftBorder and $07);
  BorderBottomStyle := Get4BorderStyle(PRecXF4(P).BottomBorder and $07);
  BorderRightStyle  := Get4BorderStyle(PRecXF4(P).RightBorder and $07);
end;

procedure TCellFormat.FromXF7(P: PByteArray);
begin
  FXF.Data1 := 0;
  FXF.Data2 := 0;
  FXF.Data3 := 0;
  FXF.Data4 := 0;
  FXF.Data5 := 0;
  FXF.Data6 := 0;
  FXF.Data7 := 0;
  FXF.FontIndex := PRecXF7(P).FontIndex;

  FXF.NumFmtIndex := PRecXF7(P).FormatIndex;
  FXF.Data1 := PRecXF7(P).Data1;
  FXF.Data2 := PRecXF7(P).Data2 and $00FF;
  case (PRecXF7(P).Data2 and $0300) shr 8 of
    1: FXF.Data2 := FXF.Data2 + $FF00;
    2: FXF.Data2 := FXF.Data2 +  (90 shl 8);
    3: FXF.Data2 := FXF.Data2 + (180 shl 8);
  end;
  FXF.Data3 := PRecXF7(P).Data2 and $FC00;
  FXF.Data4 := FXF.Data4 + ((PRecXF7(P).Data5 and $0038) shr 3); // Left
  FXF.Data4 := FXF.Data4 + ((PRecXF7(P).Data5 and $01C0) shr 2); // Right
  FXF.Data4 := FXF.Data4 + ((PRecXF7(P).Data5 and $0007) shl 8); // Top
  FXF.Data4 := FXF.Data4 + ((PRecXF7(P).Data4 and $01C0) shl 6); // Bottom
  FXF.Data5 := FXF.Data5 +  (PRecXF7(P).Data6 and ($007F + $3F80));
  FXF.Data6 := FXF.Data6 + ((PRecXF7(P).Data5 and $FE00) shr 9);
  FXF.Data6 := FXF.Data6 + ((PRecXF7(P).Data4 and $FE00) shr 2);
  FXF.Data6 := FXF.Data6 + ((PRecXF7(P).Data4 and $003F) shl 26);  // Fill pattern
  FXF.Data7 := FXF.Data7 +  (PRecXF7(P).Data3 and $007F);
  FXF.Data7 := FXF.Data7 +  (PRecXF7(P).Data3 and $1F80);
  FXF.Data7 := FXF.Data7 + ((PRecXF7(P).Data3 and $2000) shl 1);
end;

procedure TCellFormat.FromXF8(P: PByteArray);
begin
  FXF.FontIndex := PRecXF8(P).FontIndex;
  FXF.NumFmtIndex := PRecXF8(P).NumFmtIndex;
  FParent.FNumberFormats.IncUsageById(FXF.NumFmtIndex);
  FXF.Data1 := PRecXF8(P).Data1;
  FXF.Data2 := PRecXF8(P).Data2;
  FXF.Data3 := PRecXF8(P).Data3;
  FXF.Data4 := PRecXF8(P).Data4;
  FXF.Data5 := PRecXF8(P).Data5;
  FXF.Data6 := PRecXF8(P).Data6;
  FXF.Data7 := PRecXF8(P).Data7;
end;

procedure TCellFormat.ToXF4(var P: PByteArray);
function Get4BorderValue(Value: TCellBorderStyle): byte;
begin
  case Value of
    cbsNone:   Result := 0;
    cbsThin:   Result := 1;
    cbsMedium: Result := 2;
    cbsDashed: Result := 3;
    cbsDotted: Result := 4;
    cbsThick:  Result := 5;
    cbsDouble: Result := 6;
    cbsHair:   Result := 7;
    else
      Result := 0;
  end;
end;

begin
  PRecXF4(P).FontIndex := FXF.FontIndex;
  PRecXF4(P).FormatIndex := FXF.NumFmtIndex - Length(ExcelStandardNumFormats);

  PRecXF4(P).Data1 := $0000;
  if cpLocked in Protection then
    PRecXF4(P).Data1 := PRecXF4(P).Data1 or $0001;
  if cpHidden in Protection then
    PRecXF4(P).Data1 := PRecXF4(P).Data1 or $0002;

  case HorizAlignment of
    chaGeneral:      PRecXF4(P).Data2 := 0;
    chaLeft:         PRecXF4(P).Data2 := 1;
    chaCenter:       PRecXF4(P).Data2 := 2;
    chaRight:        PRecXF4(P).Data2 := 3;
    chaFill:         PRecXF4(P).Data2 := 4;
    chaJustify:      PRecXF4(P).Data2 := 5;
    chaCenterAcross: PRecXF4(P).Data2 := 6;
    else
      PRecXF4(P).Data2 := 0;
  end;
  if foWrapText in FormatOptions then
    PRecXF4(P).Data2 := PRecXF4(P).Data2 or $0008;
  case VertAlignment of
    cvaCenter: PRecXF4(P).Data2 := PRecXF4(P).Data2 or (1 shl 4);
    cvaBottom: PRecXF4(P).Data2 := PRecXF4(P).Data2 or (2 shl 4);
  end;

  PRecXF4(P).UsedAttributes := 0;
  if FXF.NumFmtIndex > 0 then
    PRecXF4(P).UsedAttributes := PRecXF4(P).UsedAttributes or $04;
  PRecXF4(P).UsedAttributes := PRecXF4(P).UsedAttributes or $08;
  if (HorizAlignment <> chaGeneral) or (foWrapText in FormatOptions) or (VertAlignment <> cvaBottom) then
    PRecXF4(P).UsedAttributes := PRecXF4(P).UsedAttributes or $10;
  if (BorderTopStyle <> cbsNone) or (BorderLeftStyle <> cbsNone) or (BorderBottomStyle <> cbsNone) or (BorderRightStyle <> cbsNone) then
    PRecXF4(P).UsedAttributes := PRecXF4(P).UsedAttributes or $20;
  if Protection <> [cpLocked] then
    PRecXF4(P).UsedAttributes := PRecXF4(P).UsedAttributes or $80;

  PRecXF4(P).CellColor := $0000;
  PRecXF4(P).CellColor := Integer(FillPatternPattern) and $003F;
  PRecXF4(P).CellColor := (PRecXF4(P).CellColor and $07C0) shl 6;
  PRecXF4(P).CellColor := (PRecXF4(P).CellColor and $F80) shl 11;

  PRecXF4(P).TopBorder := Get4BorderValue(BorderTopStyle);
  PRecXF4(P).LeftBorder := Get4BorderValue(BorderLeftStyle);
  PRecXF4(P).BottomBorder := Get4BorderValue(BorderBottomStyle);
  PRecXF4(P).RightBorder := Get4BorderValue(BorderRightStyle);

  if PRecXF4(P).TopBorder <> 0    then PRecXF4(P).TopBorder :=    PRecXF4(P).TopBorder or $C0;
  if PRecXF4(P).LeftBorder <> 0   then PRecXF4(P).LeftBorder :=   PRecXF4(P).LeftBorder or $C0;
  if PRecXF4(P).BottomBorder <> 0 then PRecXF4(P).BottomBorder := PRecXF4(P).BottomBorder or $C0;
  if PRecXF4(P).RightBorder <> 0  then PRecXF4(P).RightBorder :=  PRecXF4(P).RightBorder or $C0;
end;

procedure TCellFormat.ToXF7(var P: PByteArray);
var
  V: word;
begin
  FillChar(P^,SizeOf(TRecXF7),#0);

  with PRecXF7(P)^ do begin
    FontIndex := FXF.FontIndex;
    FormatIndex := FXF.NumFmtIndex;
    Data1 := FXF.Data1;
    Data2 := FXF.Data2 and $00FF;
    V := FXF.Data2 shr 8;
    if V = $00FF then
      Data2 := Data2 + $0100
    else if V > 135 then
      Data2 := Data2 + $0300
    else if V > 45 then
      Data2 := Data2 + $0200;

    Data2 := Data2 + FXF.Data3 and $FC00;
    Data5 := Data5 + ((FXF.Data4 shl 3) and $0038);
    Data5 := Data5 + ((FXF.Data4 shl 2) and $01C0);
    Data5 := Data5 + ((FXF.Data4 shr 8) and $0007);
    Data4 := Data4 + ((FXF.Data4 shr 6) and $01C0);
    Data6 := FXF.Data5 and ($007F + $3F80);
    Data5 := Data5 + ((FXF.Data6 shl 9) and $FE00);
    Data4 := Data4 + ((FXF.Data6 shl 2) and $FE00);
    Data4 := Data4 + ((FXF.Data6 shr 26) and $003F);
    Data3 := Data3 + (FXF.Data7 and $007F);
    Data3 := Data3 + (FXF.Data7 and $1F80);
    Data3 := Data3 + ((FXF.Data7 shr 1) and $2000);
  end;
end;

procedure TCellFormat.ToXF8(var P: PByteArray);
begin
  PRecXF8(P).FontIndex := FXF.FontIndex;
  PRecXF8(P).NumFmtIndex := FXF.NumFmtIndex;
  PRecXF8(P).Data1 := FXF.Data1;
  PRecXF8(P).Data2 := FXF.Data2;
  PRecXF8(P).Data3 := FXF.Data3;
  PRecXF8(P).Data4 := FXF.Data4;
  PRecXF8(P).Data5 := FXF.Data5;
  PRecXF8(P).Data6 := FXF.Data6;
  PRecXF8(P).Data7 := FXF.Data7;
end;

function TCellFormat.Equal(F: TCellFormat): boolean;
begin
  Result := CompareMem(@F.FXF,@FXF,SizeOf(TRecXF8));
end;

destructor TCellFormat.Destroy;
begin
  if FParent.FNumberFormats <> nil then
    FParent.FNumberFormats.DeleteById(FXF.NumFmtIndex);
  inherited;
end;

{
procedure TCellFormat.OnFontChanged(NewIndex: word);
begin
  FXF.FontIndex := NewIndex;
end;
}

function TCellFormat.GetXFont: TXFont;
begin
  Result := FParent.FFonts[FXF.FontIndex];
end;

{ TNumberFormats }

function TNumberFormats.Add(Value: WideString): TNumberFormat;
var
  i: integer;
begin
  i := FindValue(Value);
  if i >= 0 then begin
    Result := ItemsByIndex[i];
    Inc(Result.FUsageCount);
  end
  else begin
    Inc(FCurrentId);
    Result := TNumberFormat.Create;
    Result.FValue := Value;
    Result.FIndexId := FCurrentId;
    Result.FUsageCount := 1;
    Result.CreateHash;
    inherited Add(Result);
  end;
end;

function TNumberFormats.AddSorted(Value: WideString; IndexId,UsageCount: integer): TNumberFormat;
var
  i: integer;
begin
  i := Find(IndexId);
  if i > 0 then begin
    Result := TNumberFormat(inherited Items[i]);
    Result.FValue := Value;
    if Result.FUsageCount >= 0 then
      Inc(Result.FUsageCount,UsageCount)
    else
      Result.FUsageCount := UsageCount;
  end
  else begin
    Result := TNumberFormat.Create;
    Result.FValue := Value;
    Result.FIndexId := IndexId;
    Result.FUsageCount := UsageCount;
    inherited Add(Result);
  end;
  Result.CreateHash;
  if IndexId > FCurrentId then
    FCurrentId := IndexId;
end;

procedure TNumberFormats.SetDefault;
var
  i: integer;
begin
  FCurrentId := 0;
  for i := 0 to High(ExcelStandardNumFormats) do
    AddSorted(ExcelStandardNumFormats[i],i,-1);
end;

constructor TNumberFormats.Create;
begin
  inherited Create;
//  SetDefault;
end;

procedure TNumberFormats.DeleteById(IndexId: integer);
var
  i: integer;
  NF: TNumberFormat;
begin
  if IndexId <= High(ExcelStandardNumFormats) then
    Exit;
  i := Find(IndexId);
  if i < 0 then
    raise Exception.CreateFmt('Can not find number format# %d',[IndexId]);
  NF := TNumberFormat(inherited Items[i]);
  if NF.FUsageCount >= 0 then begin
    Dec(NF.FUsageCount);
    if NF.FUsageCount <= 0 then begin
      if IndexId <= High(ExcelStandardNumFormats) then begin
        NF.FValue := ExcelStandardNumFormats[i];
        NF.FIndexId := i;
        NF.FUsageCount := -1;
      end
      else
        inherited Delete(i);
    end;
  end;
end;

destructor TNumberFormats.Destroy;
begin

  inherited;
end;

function TNumberFormats.Find(IndexId: integer): integer;
var
  i,lo,hi: integer;
begin
  if (IndexId < 0) or (Count <= 0) then begin
    Result := -1;
    Exit;
  end;
  i := 0;
  lo := 0;
  hi := Count - 1;
  while lo <= hi do begin
    i := (lo + hi) div 2;
    if IndexId > ItemsByIndex[i].FIndexId then
      lo := i + 1
    else if IndexId < ItemsByIndex[i].FIndexId then
      hi := i - 1
    else
      Break;
  end;
  if IndexId = ItemsByIndex[i].FIndexId then
    Result := i
  else
    Result := -1;
end;

function TNumberFormats.FindValue(Value: WideString): integer;
var
  Hash: word;
begin
  if Value = '' then
    Result := 0
  else begin
    Hash := GetHashCode(Pointer(Value)^,Length(Value) * 2);
    for Result := 0 to Count - 1 do begin
      if (ItemsByIndex[Result].FHash = Hash) and (ItemsByIndex[Result].FValue = Value) then
        Exit;
    end;
    Result := -1;
  end;
end;

function TNumberFormats.GetItems(IndexId: integer): TNumberFormat;
begin
  Result := TNumberFormat(inherited Items[Find(IndexId)]);
end;

function TNumberFormats.GetItemsByIndex(Index: integer): TNumberFormat;
begin
  Result := TNumberFormat(inherited Items[Index]);
end;

procedure TNumberFormats.SetItemsByIndex(Index: integer; const Value: TNumberFormat);
begin
  inherited Items[Index] := Value;
end;

{
procedure TNumberFormats.Sort;

procedure QSort(L, R: Integer);
var
  i, j, IndexId: Integer;
  T: TNumberFormat;
begin
  repeat
    i := L;
    j := R;
    IndexId := ItemsByIndex[(L + R) shr 1].FIndexId;
    repeat
      while ItemsByIndex[i].FIndexId < IndexId do Inc(i);
      while ItemsByIndex[j].FIndexId > IndexId do Dec(j);
      if I <= J then
      begin
        T := ItemsByIndex[i];
        ItemsByIndex[i] := ItemsByIndex[j];
        ItemsByIndex[j] := T;
        Inc(i);
        Dec(j);
      end;
    until i > j;
    if L < j then QSort(L, j);
    L := i;
  until i >= R;
end;

begin
  if Count > 0 then
    QSort(0,Count - 1);
end;
}

procedure TNumberFormats.IncUsageById(IndexId: integer);
var
  i: integer;
  NF: TNumberFormat;
begin
  if IndexId <= High(ExcelStandardNumFormats) then
    Exit;
  i := Find(IndexId);
  if i < 0 then
    raise Exception.CreateFmt('Can not find number format# %d',[IndexId]);
  NF := TNumberFormat(inherited Items[i]);
  Inc(NF.FUsageCount);
end;

{ TNumberFormat }

procedure TNumberFormat.CreateHash;
begin
  if FValue = '' then
    FHash := 0
  else
    FHash := GetHashCode(Pointer(FValue)^,Length(FValue) * 2);
end;

function TNumberFormat.IsDefault: boolean;
begin
  Result := FUsageCount < 0;
end;

end.