rm_wawwriters.pas

胜天进销存源码,国产优秀的进销存

unit RM_wawWriters;

{$I rm.inc}

interface

uses
  Windows, Classes, SysUtils, Graphics, AxCtrls, ActiveX,
 {$IFDEF Delphi6} 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;
  j: Integer;