rm_wawwriters.pas

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

              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;
while Result<XLSMaxColorsInPalette do
  begin
    if(DefaultColorIndex(FColorPalette[Result])=-1) and