rm_wawwriters.pas

这是一个功能强大

unit RM_wawWriters;

{$I rm.inc}

interface

uses
  Windows, Classes, SysUtils, Graphics, AxCtrls, ActiveX,
{$IFDEF COMPILER6_UP}Variants, {$ENDIF}
  RM_wawConsts, RM_wawExcelFmt, RM_wawExcel, RM_wawFormula, RM_wawBIFF8;

type
  TwawHtmlCell = record
    Image: TwawImage;
    Range: TwawXLSRange;
    StyleId: Word;
    Hide: Word;
    ImageNum: Integer;
    BordersStyleId: Word;
  end;

  THtmlCells = array[$0..$0] of TwawHtmlCell;

  PHtmlCells = ^THtmlCells;

  TwawHTMLWriter = class(TwawCustomWriter)
  private
    FileStream: TFileStream;
    FFileName: string;
    FilesDir: string;
    FName: string;
    FileExt: string;
    DirName: string;
    FWorkBook: TwawXLSWorkbook;
    HtmlCells: PHtmlCells;
    MinPos: Integer;
    RowCount: Integer;
    ColCount: Integer;
    Styles: TStrings;
    SpansPresent: Boolean;
    function GetBackgroundColor(Range: TwawXLSRange): string;
    function GetBorders(Range: TwawXLSRange): string;
    procedure CheckBounds(Images: TwawImages);
    procedure AddImage(Sheet: TwawXLSWorksheet; Image: TwawImage; FileName: string;
      ImageNum: Integer);
    procedure AddRange(Range: TwawXLSRange);
    procedure SaveBmpToFile(Picture: TPicture; FileName: string);
    function GenStyle(Range: TwawXLSRange): string;
    function GenCellStyle(Range: TwawXLSRange): string;
    procedure SaveHeadFiles;
    procedure SaveMainFile;
    procedure SaveHeadFile;
    procedure WriteStyles;
    procedure WriteRowTag(Sheet: TwawXLSWorksheet; RowIndex: Integer; Level: Integer);
    procedure WriteCellTag(Sheet: TwawXLSWorksheet; RowIndex: Integer;
      ColumnIndex: Integer; Level: Integer);
    function GetSheetFileName(SheetNumber: Integer): string;
    function GetCellTagString(Range: TwawXLSRange): string;
    function GetCellTagStringImg(Image: TwawImage): string;
    procedure InitStrings;
    function CalcTableWidth(Sheet: TwawXLSWorksheet): Integer;
    function CalcTableHeight(Sheet: TwawXLSWorksheet): Integer;
    function GetTableTag(Sheet: TwawXLSWorksheet): string;
    function GetImgStyle(Image: TwawImage): string;
  public
    constructor Create;
    destructor Destroy; override;
    procedure SaveSheet(Sheet: TwawXLSWorksheet; FileName: string);
    procedure Save(WorkBook: TwawXLSWorkbook; FileName: string); override;
  end;

  rXLSRangeRec = record
    iXF: Integer;
    iSST: Integer;
    iFont: Integer;
    iFormat: Integer;
    Ptgs: PChar;
    PtgsSize: Integer;
  end;

  pXLSRangeRec = ^rXLSRangeRec;

  rXLSRangesRec = array[$0..$0] of rXLSRangeRec;

  pXLSRangesRec = ^rXLSRangesRec;

  rXLSSheetRec = record
    StreamBOFOffset: Integer;
    StreamBOFOffsetPosition: Integer;
  end;

  rXLSSheetsRecs = array[$0..$0] of rXLSSheetRec;

  pXLSSheetsRecs = ^rXLSSheetsRecs;

  rXLSImageRec = record
    BorderLineColorIndex: Integer;
    ForegroundFillPatternColorIndex: Integer;
    BackgroundFillPatternColorIndex: Integer;
  end;

  pXLSImageRec = ^rXLSImageRec;

  rXLSImagesRecs = array[$0..$0] of rXLSImageRec;

  pXLSImagesRecs = ^rXLSImagesRecs;

  TwawExcelWriter = class(TwawCustomWriter)
  private
    FBOFOffs: Integer;
    FWorkBook: TwawXLSWorkbook;
    FUsedColors: TList;
    FRangesRecs: pXLSRangesRec;
    FColorPalette: array[$0..XLSMaxColorsInPalette - 1] of TColor;
    FPaletteModified: Boolean;
    FSheetsRecs: pXLSSheetsRecs;
    FImagesRecs: pXLSImagesRecs;
    FCompiler: TwawExcelFormulaCompiler;
    function GetColorPaletteIndex(Color: TColor): Integer;
    procedure BuildFontList(l: TList);
    procedure BuildFormatList(sl: TStringList);
    procedure BuildXFRecord(Range: TwawXLSRange; var XF: rb8XF; prr: pXLSRangeRec);
    procedure BuildXFList(l: TList);
    procedure BuildFormulas;
    procedure BuildImagesColorsIndexes;
    procedure WriteRangeToStream(Stream: TStream; Range: TwawXLSRange;
      CurrentRow: Integer; var IndexInCellsOffsArray: Integer;
      var CellsOffs: Tb8DBCELLCellsOffsArray);
    procedure WriteSheetToStream(Stream: TStream; Sheet: TwawXLSWorksheet);
    procedure WriteSheetImagesToStream(Stream: TStream; Sheet: TwawXLSWorksheet);
  public
    constructor Create;
    destructor Destroy; override;
    procedure SaveAsBIFFToStream(WorkBook: TwawXLSWorkbook; Stream: TStream);
    procedure Save(WorkBook: TwawXLSWorkbook; FileName: string); override;
  end;

const
  aDefaultColorPalette: array[$0..XLSMaxColorsInPalette - 1] of TColor =
  ($00000000, $00FFFFFF, $000000FF, $0000FF00,
    $00FF0000, $0000FFFF, $00FF00FF, $00FFFF00,
    $00000080, $00008000, $00800000, $00008080,
    $00800080, $00808000, $00C0C0C0, $00808080,
    $00FF9999, $00663399, $00CCFFFF, $00FFFFCC,
    $00660066, $008080FF, $00CC6600, $00FFCCCC,
    $00800000, $00FF00FF, $0000FFFF, $00FFFF00,
    $00800080, $00000080, $00808000, $00FF0000,
    $00FFCC00, $00FFFFCC, $00CCFFCC, $0099FFFF,
    $00FFCC99, $00CC99FF, $00FF99CC, $0099CCFF,
    $00FF6633, $00CCCC33, $0000CC99, $0000CCFF,
    $000099FF, $000066FF, $00996666, $00969696,
    $00663300, $00669933, $00003300, $00003333,
    $00003399, $00663399, $00993333, $00333333);

  aDefaultColors: array[$0..$F] of Integer =
  (clWhite, clBlack, clSilver, clGray,
    clRed, clMaroon, clYellow, clOlive,
    clLime, clGreen, clAqua, clTeal,
    clBlue, clNavy, clFuchsia, clPurple);

  aHtmlCellBorders: array[$2..$5] of string =
  ('bottom', 'left', 'right', 'top');

  aBorderLineStyles: array[$0..$D] of string =
  ('none',
    '.5pt solid',
    '1.0pt solid',
    '.5pt dashed',
    '.5pt dotted',
    '1.5pt solid',
    '2.0pt double',
    '.5pt hairline',
    '1.0pt dashed',
    '.5pt dot-dash',
    '1.0pt dot-dash',
    '.5pt dot-dot-dash',
    '1.0pt dot-dot-dash',
    '1.0pt dot-dash-slanted');

  aBorderImageLineStyles: array[$0..$8] of string =
  ('.5pt solid',
    '.5pt dashed',
    '.5pt dotted',
    '.5pt dot-dash',
    '.5pt dot-dot-dash',
    'none',
    '.5pt solid DarkGray',
    '.5pt solid MediumGray',
    '.5 pt solid LightGray');

implementation

uses
  Math, ComObj;

function MakeHTMLString(Value: string): string;
var
  i: Integer;
begin
  Result := '';
  for i := 1 to Length(Value) do
    case Value[i] of
      Char(34): Result := Result + wawHtml_quot;
      Char(38): Result := Result + wawHtml_amp;
      Char(60): Result := Result + wawHtml_lt;
      Char(62): Result := Result + wawHtml_gt;
      Char(13): Result := Result + wawHtml_crlf;
      Char(10): if ((i = 1) or (Value[i - 1] <> Char(13))) then
          Result := Result + wawHtml_crlf;
      Char(32): if ((i = 1) or (Value[i - 1] = Char(32))) then
          Result := Result + wawHtml_space
        else
          Result := Result + Value[i];
    else
      Result := Result + Value[i];
    end;
end;

procedure WriteBlockSeparator(AStream: TStream);
var
  P: PChar;
begin
  P := @(wawBLOCKSEPARATOR[1]);
//  UniqueString(wawBLOCKSEPARATOR);
  AStream.Write(P^, Length(wawBLOCKSEPARATOR));
end;

procedure WriteStringToStream(AStream: TStream; Value: string);
var
  P: PChar;
begin
  P := @Value[1];
//  UniqueString(Value);
  AStream.Write(P^, Length(Value));
end;

procedure WriteLevelMargin(AStream: TStream; Level: Integer);
begin
  AStream.Write(wawMAXMARGINSTRING, Min(Length(wawMAXMARGINSTRING), Level));
end;

procedure WriteStringWithFormatToStream(AStream: TStream;
  Value: string; Level: Integer);
begin
  WriteLevelMargin(AStream, Level);
  WriteStringToStream(AStream, Value);
  WriteBlockSeparator(AStream);
end;

procedure WriteOpenTagFormat(AStream: TStream; Tag: string;
  Level: Integer);
begin
  WriteStringWithFormatToStream(AStream, Format('%s%s%s', [wawOPENTAGPREFIX, tag, wawTAGPOSTFIX]), Level);
end;

procedure WriteOpenTagClassFormat(AStream: TStream; Tag: string;
  Level: Integer; ClassId: Integer);
var
  ClName: string;
begin
  ClName := Format(wawSTYLEFORMAT, [ClassId]);
  WriteStringWithFormatToStream(AStream, Format('%s%s class=%s %s', [wawOPENTAGPREFIX, tag, ClName, wawTAGPOSTFIX]), Level);
end;

procedure WriteCloseTagFormat(AStream: TStream; Tag: string;
  Level: Integer);
begin
  WriteStringWithFormatToStream(AStream, Format('%s%s%s', [wawCLOSETAGPREFIX, tag, wawTAGPOSTFIX]), Level);
end;

constructor TwawHTMLWriter.Create;
begin
  Styles := TStringList.Create;
  Styles.Add(wawTABLESTYLE);
end;

destructor TwawHTMLWriter.Destroy;
begin
  Styles.Free;
end;

procedure TwawHTMLWriter.SaveHeadFiles;
var
  Code: Integer;
begin
  Code := GetFileAttributes(PChar(FilesDir));
  if (Code = -1) or (Code = $10) then
    CreateDir(FilesDir);
  SaveMainFile;
  SaveHeadFile;
end;

procedure TwawHTMLWriter.SaveMainFile;
begin
  WriteStringWithFormatToStream(FileStream, wawHTML_VERSION, 0);
  WriteOpenTagFormat(FileStream, wawHTMLTAG, 0);
  WriteOpenTagFormat(FileStream, wawHEADTAG, 0);
  WriteOpenTagFormat(FileStream, wawTITLETAG, 1);
  WriteStringWithFormatToStream(FileStream, MakeHTMLString(FName), 2);
  WriteCloseTagFormat(FileStream, wawTITLETAG, 1);
  WriteCloseTagFormat(FileStream, wawHEADTAG, 0);
  WriteStringWithFormatToStream(FileStream, '<FRAMESET rows="39,*" border=0 width=0 frameborder=no framespacing=0>', 1);
  WriteStringWithFormatToStream(FileStream, Format('<FRAME name="header" src="%s/header.htm" marginwidth=0 marginheight=0>', [DirName]), 2);
  WriteStringWithFormatToStream(FileStream, Format('<FRAME name="sheet" src="%s/Sheet0.htm">', [DirName]), 2);
  WriteStringWithFormatToStream(FileStream, '</FRAMESET>', 1);
  WriteCloseTagFormat(FileStream, wawHTMLTAG, 0);
end;

procedure TwawHTMLWriter.SaveHeadFile;
var
  fs: TFileStream;
  i: Integer;
begin
  fs := TFileStream.Create(FilesDir + '\header.htm', fmCreate or fmShareDenyWrite);
  try
    WriteStringWithFormatToStream(fs, wawHTML_VERSION, 0);
    WriteOpenTagFormat(fs, wawHTMLTAG, 0);
    WriteOpenTagFormat(fs, wawHEADTAG, 0);
    WriteOpenTagFormat(fs, wawTITLETAG, 1);
    WriteStringWithFormatToStream(fs, MakeHTMLString(FName), 2);
    WriteCloseTagFormat(fs, wawTITLETAG, 1);
    WriteOpenTagFormat(fs, wawSTYLETAG, 0);
    WriteStringWithFormatToStream(fs, '<!--'#13#10'A { text-decoration:none; color:#000000; font-size:9pt; } A:Active { color : #0000E0}'#13#10'-->', 1);
    WriteCloseTagFormat(fs, wawSTYLETAG, 0);
    WriteCloseTagFormat(fs, wawHEADTAG, 0);
    WriteStringWithFormatToStream(fs, '<BODY topmargin=0 leftmargin=0 bgcolor="#808080">', 0);
    WriteStringWithFormatToStream(fs, '<TABLE border=0 cellspacing=1 height=100%>', 0);
    WriteStringWithFormatToStream(fs, '<TR height=10><TD>', 1);
    WriteStringWithFormatToStream(fs, '<TR>', 1);
    for i := 0 to FWorkBook.SheetsCount - 1 do
    begin
      WriteStringToStream(fs, Format('<td bgcolor="#FFFFFF" nowrap><b><small><small>&nbsp;<A href="Sheet%d.htm" target=sheet><font face="Arial">%s</FONT></A>&nbsp;</small></small></b></td>'#13#10,
        [i, TwawXLSWorksheet(FWorkBook.Sheets[i]).Title]));
    end;
    WriteCloseTagFormat(fs, wawROWTAG, 0);
    WriteCloseTagFormat(fs, wawTABLETAG, 0);
    WriteCloseTagFormat(fs, wawBODYTAG, 0);
    WriteCloseTagFormat(fs, wawHTMLTAG, 0);
  finally
    fs.Free;
  end;
end;

procedure TwawHTMLWriter.WriteStyles;
var
  i: Integer;
begin
  WriteOpenTagFormat(FileStream, wawSTYLETAG, 2);
  for i := 0 to Styles.Count - 1 do
    WriteStringToStream(FileStream, Format('.' + wawSTYLEFORMAT + ' { %s } '#13#10, [i, Styles[i]]));
  WriteCloseTagFormat(FileStream, wawSTYLETAG, 2);
end;

procedure TwawHTMLWriter.WriteRowTag(Sheet: TwawXLSWorksheet;
  RowIndex: Integer; Level: Integer);
var
  Row: TwawXLSRow;
  RowHeight: Integer;
begin
  if RowIndex >= 0 then
  begin
    Row := Sheet.FindRow(RowIndex);
    if Row = nil then
      RowHeight := Sheet.GetDefaultRowPixelHeight
    else
      RowHeight := Row.PixelHeight;
  end
  else
    RowHeight := 0;
  WriteStringWithFormatToStream(FileStream, Format('%s%s style="%s:%dpx" %s', [wawOPENTAGPREFIX, wawROWTAG, wawHEIGHTATTRIBUTE, RowHeight, wawTAGPOSTFIX]), Level);
end;

procedure TwawHTMLWriter.WriteCellTag(Sheet: TwawXLSWorksheet;
  RowIndex: Integer; ColumnIndex: Integer; Level: Integer);
var
  S: string;
  Col: TwawXLSCol;
  ColWidth: Integer;
begin
  S := wawOPENTAGPREFIX + wawCELLTAG;
  if (RowIndex = MinPos) then
  begin
    if (ColumnIndex >= 0) then
    begin
      Col := Sheet.FindCol(ColumnIndex);
      if Col <> nil then
        ColWidth := Col.PixelWidth
      else
        ColWidth := Sheet.GetDefaultColumnPixelWidth;
    end
    else
      ColWidth := 0;
    S := S + Format(' style="%s:%dpx"', [wawWIDTHATTRIBUTE, ColWidth]);
  end;
  if (RowIndex >= 0) and (ColumnIndex >= 0) and (HtmlCells^[RowIndex * ColCount + ColumnIndex].Image <> nil) then
  begin
    S := S + GetCellTagStringImg(HtmlCells^[RowIndex * ColCount + ColumnIndex].Image);
    S := S + ' CLASS=' + Format(wawSTYLEFORMAT, [HtmlCells^[RowIndex * ColCount + ColumnIndex].BordersStyleId]);
  end;
  if (RowIndex >= 0) and (ColumnIndex >= 0) and (HtmlCells^[RowIndex * ColCount + ColumnIndex].Range <> nil) then
  begin
    S := S + GetCellTagString(HtmlCells^[RowIndex * ColCount + ColumnIndex].Range);
    S := S + ' CLASS=' + Format(wawSTYLEFORMAT, [HtmlCells^[RowIndex * ColCount + ColumnIndex].BordersStyleId]);
  end;
  S := S + wawTAGPOSTFIX;
  WriteStringWithFormatToStream(FileStream, S, Level);
end;

procedure TwawHTMLWriter.AddImage(Sheet: TwawXLSWorksheet; Image: TwawImage; FileName: string;
  ImageNum: Integer);
var
  i: Integer;