rm_wawwriters.pas

这是一个功能强大

            else
              if (i = MinPos) and (j >= 0) then
              begin
                WriteCellTag(Sheet, i, j, 2);
                WriteCloseTagFormat(FileStream, wawCELLTAG, 2);
              end;
          end;
          WriteCloseTagFormat(FileStream, wawROWTAG, 1);
        end;
        WriteCloseTagFormat(FileStream, wawTABLETAG, 1);
        WriteCloseTagFormat(FileStream, wawFORMTAG, 0);
        WriteCloseTagFormat(FileStream, wawBODYTAG, 0);
        WriteCloseTagFormat(FileStream, wawHTMLTAG, 0);
      finally
        FreeMem(HtmlCells);
      end;
    end;
  finally
    FileStream.Free;
  end;
end;

function TwawHTMLWriter.GetCellTagString(Range: TwawXLSRange): string;
var
  ColSpan: Integer;
  RowSpan: Integer;
begin
  Result := '';
  with Range do
  begin
    RowSpan := Place.Bottom - Place.Top + 1;
    ColSpan := Place.Right - Place.Left + 1;
  end;
  if RowSpan > 1 then
    Result := Result + Format(' %s=%d', [wawROWSPANATTRIBUTE, rowspan]);
  if ColSpan > 1 then
    Result := Result + Format(' %s=%d', [wawCOLSPANATTRIBUTE, colspan]);
end;

function TwawHTMLWriter.GetCellTagStringImg(Image: TwawImage): string;
var
  ColSpan: Integer;
  RowSpan: Integer;
begin
  Result := '';
  RowSpan := Image.Bottom - Image.Top;
  ColSpan := Image.Right - Image.Left;
  if RowSpan > 1 then
    Result := Result + Format(' %s=%d', [wawROWSPANATTRIBUTE, rowspan]);
  if ColSpan > 1 then
    Result := Result + Format(' %s=%d', [wawCOLSPANATTRIBUTE, colspan]);
end;

procedure wbiff(Stream: TStream; code: Word; buf: Pointer; size: Integer);
var
  sz: Word;
begin
  repeat
    Stream.Write(code, 2);
    sz := Min(size, MaxBiffRecordSize - 4);
    Stream.Write(sz, 2);
    if sz > 0 then
    begin
      Stream.Write(buf^, sz);
      buf := PChar(buf) + sz;
      size := size - sz;
      code := b8_CONTINUE;
    end;
  until size <= 0;
end;

procedure wbiffFont(Stream: TStream; f: TFont; ColorPaletteIndex: Word);
var
  font: pb8FONT;
  lf: TLogFont;
  lfont: Integer;
begin
  lfont := Length(f.Name) * sizeof(WideChar);
  font := AllocMem(sizeof(rb8FONT) + lfont);
  try
    GetObject(f.Handle, SizeOf(TLogFont), @lf);
    font.dyHeight := f.Size * 20;
    if fsItalic in f.Style then
      font.grbit := font.grbit or b8_FONT_grbit_fItalic;
    if fsStrikeout in f.Style then
      font.grbit := font.grbit or b8_FONT_grbit_fStrikeout;
    font.icv := ColorPaletteIndex;
    if fsBold in f.Style then
      font.bls := $3E8 // from MSDN
    else
      font.bls := $64; // from MSDN
    if fsUnderline in f.Style then
      font.uls := 1; // from MSDN
    font.bFamily := lf.lfPitchAndFamily;
    font.bCharSet := lf.lfCharSet;
    font.cch := FormatStrToWideChar(f.Name, PWideChar(PChar(font) + sizeof(rb8FONT)));
    font.cchgrbit := $01;

    wbiff(Stream, b8_FONT, font, sizeof(rb8FONT) + (font.cch shl 1));
  finally
    FreeMem(font);
  end;
end;

procedure wbiffFormat(Stream: TStream; FormatString: string;
  FormatCode: Word);
var
  lformat: Integer;
  format: pb8FORMAT;
begin
  lformat := Length(FormatString) * sizeof(WideChar);
  format := AllocMem(sizeof(rb8FORMAT) + lformat);
  try
    format.ifmt := FormatCode;
    format.cch := FormatStrToWideChar(FormatString, PWideChar(PChar(format) + sizeof(rb8FORMAT)));
    format.cchgrbit := 1;
    wbiff(Stream, b8_FORMAT, format, sizeof(rb8FORMAT) + (format.cch shl 1));
  finally
    FreeMem(format);
  end;
end;

function HexStringToString(s: string): string;
var
  b1: string;
  i: Integer;
  ls: Integer;
begin
  Result := '';
  ls := length(s);
  i := 1;
  while i <= ls do
  begin
    while (i <= ls) and not (s[i] in ['0'..'9', 'a'..'f', 'A'..'F']) do Inc(i);
    if i > ls then break;
    b1 := '';
    while (i <= ls) and (s[i] in ['0'..'9', 'a'..'f', 'A'..'F']) do
    begin
      b1 := b1 + s[i];
      Inc(i);
    end;
    if b1 <> '' then
      Result := Result + char(StrToInt('$' + b1));
    if (b1 = '') or (i > ls) then break;
  end;
end;

procedure wbiffHexString(Stream: TStream; HexString: string);
var
  s: string;
begin
  s := HexStringToString(HexString);
  UniqueString(s);
  Stream.Write(s[1], Length(s));
end;

constructor TwawExcelWriter.Create;
begin
  FCompiler := TwawExcelFormulaCompiler.Create;
  FUsedColors := TList.Create;
end;

destructor TwawExcelWriter.Destroy;
begin
  FCompiler.Free;
  FUsedColors.Free;
end;

procedure TwawExcelWriter.BuildFontList(l: TList);
var
  f: TFont;
  sh: TwawXLSWorksheet;
  ran: TwawXLSRange;
  i: Integer;
  j: Integer;
  k: Integer;
  n: Integer;
begin
  n := 0;
  for i := 0 to FWorkBook.SheetsCount - 1 do
  begin
    sh := FWorkBook.Sheets[i];
    for j := 0 to sh.RangesCount - 1 do
    begin
      ran := sh.RangeByIndex[j];
      ran.ExportData := Addr(FRangesRecs^[n]);
      f := ran.Font;
      k := 0;
      while (k < L.Count) and
        ((TFont(L[k]).Charset <> f.Charset) or
        (TFont(L[k]).Color <> f.Color) or
        (TFont(L[k]).Height <> f.Height) or
        (TFont(L[k]).Name <> f.Name) or
        (TFont(L[k]).Pitch <> f.Pitch) or
        (TFont(L[k]).Size <> f.Size) or
        (TFont(L[k]).Style <> f.Style)) do Inc(k);
      if k >= L.Count then
      begin
        k := L.Add(TFont.Create);
        TFont(L[k]).Assign(f);
      end;
      FRangesRecs[n].iFont := k + 1;
      Inc(n);
    end;
  end;
end;

procedure TwawExcelWriter.BuildFormatList(sl: TStringList);
var
  sh: TwawXLSWorksheet;
  ran: TwawXLSRange;
  i: Integer;
  j: Integer;
  k: Integer;
  n: Integer;
  m: Integer;
begin
  n := sl.Count;
  m := 0;
  for i := 0 to FWorkBook.SheetsCount - 1 do
  begin
    sh := FWorkBook.Sheets[i];
    for j := 0 to sh.RangesCount - 1 do
    begin
      ran := sh.RangeByIndex[j];
      if ran.Format = '' then
        FRangesRecs^[m].iFormat := 0
      else
      begin
        k := sl.IndexOf(ran.Format);
        if k = -1 then
          k := sl.AddObject(ran.Format, TObject(sl.Count - n + $32));
        FRangesRecs^[m].iFormat := integer(sl.Objects[k]);
      end;
      Inc(m);
    end;
  end;
end;

procedure TwawExcelWriter.BuildXFRecord(Range: TwawXLSRange;
  var XF: rb8XF; prr: pXLSRangeRec);
var
  DiagBorderLineStyle: TwawXLSLineStyleType;
  DiagBorderColorIndex: Integer;
const
  aFillPattern: array[TwawXLSFillPattern] of Integer =
  (0, -4105, 9, 16, -4121, 18, 17, -4124, -4125, -4126, 15, -4128, 13, 11, 14, 12, 10, 1, -4162, -4166);
  aHorizontalAlignment: array[TwawXLSHorizontalAlignmentType] of Integer =
  (b8_XF_Opt2_alcGeneral,
    b8_XF_Opt2_alcLeft,
    b8_XF_Opt2_alcCenter,
    b8_XF_Opt2_alcRight,
    b8_XF_Opt2_alcFill,
    b8_XF_Opt2_alcJustify,
    b8_XF_Opt2_alcCenterAcrossSelection);
  aVerticalAlignment: array[TwawXLSVerticalAlignmentType] of Integer =
  (b8_XF_Opt2_alcVTop,
    b8_XF_Opt2_alcVCenter,
    b8_XF_Opt2_alcVBottom,
    b8_XF_Opt2_alcVJustify);
  aWrapText: array[Boolean] of Integer = (0, b8_XF_Opt2_fWrap);
  aBorderLineStyle: array[TwawXLSLineStyleType] of Word =
  (b8_XF_Border_None,
    b8_XF_Border_Thin,
    b8_XF_Border_Medium,
    b8_XF_Border_Dashed,
    b8_XF_Border_Dotted,
    b8_XF_Border_Thick,
    b8_XF_Border_Double,
    b8_XF_Border_Hair,
    b8_XF_Border_MediumDashed,
    b8_XF_Border_DashDot,
    b8_XF_Border_MediumDashDot,
    b8_XF_Border_DashDotDot,
    b8_XF_Border_MediumDashDotDot,
    b8_XF_Border_SlantedDashDot);
  function GetBorderColorIndex(b: TwawXLSBorderType): Integer;
  begin
    if Range.Borders[b].LineStyle = wawlsNone then
      Result := 0
    else
      Result := GetColorPaletteIndex(Range.Borders[b].Color);
  end;
begin
  ZeroMemory(@XF, sizeof(XF));
  XF.ifnt := prr.iFont;
  XF.ifmt := pXLSRangeRec(Range.ExportData).iFormat;
  XF.Opt1 := $0001; //b8_XF_Opt1_fLocked or b8_XF_Opt1_fHidden;
  XF.Opt2 := aHorizontalAlignment[Range.HorizontalAlignment] or
    aWrapText[Range.WrapText] or
    aVerticalAlignment[Range.VerticalAlignment];
  XF.trot := Range.Rotation;
  XF.Opt3 := b8_XF_Opt3_fAtrNum or
    b8_XF_Opt3_fAtrFnt or
    b8_XF_Opt3_fAtrAlc or
    b8_XF_Opt3_fAtrBdr or
    b8_XF_Opt3_fAtrPat; // $7C00
  if (Range.Place.Left <> Range.Place.Right) or (Range.Place.Top <> Range.Place.Bottom) then
    XF.Opt3 := XF.Opt3 or b8_XF_Opt3_fMergeCell;

// borders
  XF.Borders1 := (aBorderLineStyle[Range.Borders[wawxlEdgeLeft].LineStyle]) or
    (aBorderLineStyle[Range.Borders[wawxlEdgeRight].LineStyle] shl 4) or
    (aBorderLineStyle[Range.Borders[wawxlEdgeTop].LineStyle] shl 8) or
    (aBorderLineStyle[Range.Borders[wawxlEdgeBottom].LineStyle] shl 12);
  DiagBorderLineStyle := wawlsNone;
  DiagBorderColorIndex := 0;
  XF.Borders2 := 0;
  if Range.Borders[wawxlDiagonalDown].LineStyle <> wawlsNone then
  begin
    XF.Borders2 := XF.Borders2 or $4000;
    DiagBorderLineStyle := Range.Borders[wawxlDiagonalDown].LineStyle;
    DiagBorderColorIndex := GetColorPaletteIndex(Range.Borders[wawxlDiagonalDown].Color) + 8;
  end;
  if Range.Borders[wawxlDiagonalUp].LineStyle <> wawlsNone then
  begin
    XF.Borders2 := XF.Borders2 or $8000;
    DiagBorderLineStyle := Range.Borders[wawxlDiagonalUp].LineStyle;
    DiagBorderColorIndex := GetColorPaletteIndex(Range.Borders[wawxlDiagonalUp].Color) + 8;
  end;
  XF.Borders2 := XF.Borders2 or
    (GetBorderColorIndex(wawxlEdgeLeft)) or
    (GetBorderColorIndex(wawxlEdgeRight) shl 7);
  XF.Borders3 := (GetBorderColorIndex(wawxlEdgeTop)) or
    (GetBorderColorIndex(wawxlEdgeBottom) shl 7) or
    (DiagBorderColorIndex shl 14) or
    (aBorderLineStyle[DiagBorderLineStyle] shl 21) or
    (aFillPattern[Range.FillPattern] shl 26);
  XF.Colors := GetColorPaletteIndex(Range.ForegroundFillPatternColor) or
    (GetColorPaletteIndex(Range.BackgroundFillPatternColor) shl 7); // colors for fill pattern
end;

procedure TwawExcelWriter.BuildXFList(l: TList);
var
  p: Pointer;
  XF: rb8XF;
  sh: TwawXLSWorksheet;
  ran: TwawXLSRange;
  i: Integer;
  j: Integer;
  k: Integer;
  n: Integer;
begin
  n := 0;
  for i := 0 to FWorkBook.SheetsCount - 1 do
  begin
    sh := FWorkBook.Sheets[i];
    for j := 0 to sh.RangesCount - 1 do
    begin
      ran := sh.RangeByIndex[j];
      BuildXFRecord(ran, XF, @FRangesRecs^[n]);
      k := 0;
      while (k < l.Count) and not CompareMem(l[k], @XF, sizeof(rb8XF)) do Inc(k);
      if k >= l.Count then
      begin
        GetMem(p, sizeof(rb8XF));
        CopyMemory(p, @XF, sizeof(rb8XF));
        k := l.Add(p);
      end;
      FRangesRecs^[n].iXF := k + 15; // 15 - count of STYLE XF records
      Inc(n);
    end;
  end;
end;

procedure TwawExcelWriter.BuildFormulas;
var
  sh: TwawXLSWorksheet;
  ran: TwawXLSRange;
  i: Integer;
  j: Integer;
  n: Integer;
begin
  n := 0;
  for i := 0 to FWorkBook.SheetsCount - 1 do
  begin
    sh := FWorkBook.Sheets[i];
    for j := 0 to sh.RangesCount - 1 do
    begin
      ran := sh.RangeByIndex[j];
      FRangesRecs^[n].Ptgs := nil;
      FRangesRecs^[n].PtgsSize := 0;
      if ran.CellDataType = wawcdtFormula then
        FCompiler.CompileFormula(ran.Formula,
          FRangesRecs^[n].Ptgs,
          FRangesRecs^[n].PtgsSize);
      Inc(n);
    end;
  end;
end;

function TwawExcelWriter.GetColorPaletteIndex(Color: TColor): Integer;
  function DefaultColorIndex(c: TColor): Integer;
  begin
    Result := 0;
    while (Result < MaxDefaultColors) and (aDefaultColors[Result] <> c) do Inc(Result);
    if Result >= MaxDefaultColors then
      Result := Result or -1;
  end;
begin
  if (Color and $80000000) <> 0 then
    Color := GetSysColor(Color and $00FFFFFF);
  if FUsedColors.IndexOf(Pointer(Color)) = -1 then
    FUsedColors.Add(Pointer(Color));
  Result := 0;
  while (Result < XLSMaxColorsInPalette) and (FColorPalette[Result] <> Color) do Inc(Result);
  if Result < XLSMaxColorsInPalette then
  begin
    Result := Result + 8;
    exit; // color exist in current palette
  end;
  Result := 0;