xlsexporthtml2.pas

一个经典的读写Excel的控件

unit XLSExportHTML2;

{
********************************************************************************
******* XLSReadWriteII V2.00                                             *******
*******                                                                  *******
******* Copyright(C) 1999,2004 Lars Arvidsson, Axolot Data               *******
*******                                                                  *******
******* email: [e-mail]                                     *******
******* URL:   http://www.axolot.com                                     *******
********************************************************************************
** Users of the XLSReadWriteII component must accept the following            **
** disclaimer of warranty:                                                    **
**                                                                            **
** XLSReadWriteII is supplied as is. The author disclaims all warranties,     **
** expressedor implied, including, without limitation, the warranties of      **
** merchantability and of fitness for any purpose. The author assumes no      **
** liability for damages, direct or consequential, which may result from the  **
** use of XLSReadWriteII.                                                     **
********************************************************************************
}

{$B-}

interface

uses Classes, SysUtils, XLSExport2, Cell2, BIFFRecsII2, XLSUtils2;


type TTABLEProperties = class(TPersistent)
private
     FBordeWidth: integer;
     FCellPadding: integer;
     FCellSpacing: integer;
protected
public
published
     property BordeWidth: integer read FBordeWidth write FBordeWidth;
     property CellPadding: integer read FCellPadding write FCellPadding;
     property CellSpacing: integer read FCellSpacing write FCellSpacing;
     end;

type TXLSExportHTML2 = class(TXLSExport2)
private
protected
    FStream: TStream;
    FWriteOnlyTables: boolean;
    FTABLE: TTABLEProperties;

    procedure WString(S: string);
    procedure WStringCR(S: string);
public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
    procedure OpenFile;        override;
    procedure WriteFilePrefix; override;
    procedure WritePagePrefix; override;
    procedure WriteRowPrefix;  override;
    procedure WriteCell(SheetIndex,Col,Row: integer); override;
    procedure WriteRowSuffix;  override;
    procedure WritePageSuffix; override;
    procedure WriteFileSuffix; override;
    procedure CloseFile;       override;
published
    property WriteOnlyTables: boolean read FWriteOnlyTables write FWriteOnlyTables;
    property TABLE: TTABLEProperties read FTABLE write FTABLE;
    end;

implementation

{ TXLSExport }

procedure TXLSExportHTML2.CloseFile;
begin
  inherited;
  FStream.Free;
  FStream := Nil;
end;

constructor TXLSExportHTML2.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTABLE := TTABLEProperties.Create;
end;

destructor TXLSExportHTML2.Destroy;
begin
  FTABLE.Free;
  inherited;
end;

procedure TXLSExportHTML2.OpenFile;
begin
  FStream := TFileStream.Create(FFilename,fmCreate);
  inherited;
end;

procedure TXLSExportHTML2.SaveToStream(Stream: TStream);
begin
  FStream := Stream;
  inherited;
end;

procedure TXLSExportHTML2.WriteCell(SheetIndex, Col, Row: integer);
var
  i: integer;
  S,Link,sAlign,sColor: string;
  C: TCell;
begin
  inherited;
  C := FXLS.Sheets[SheetIndex].Cell[Col,Row];
  if C = Nil then
    WStringCR('<TD>' + '&nbsp;' + '</TD>')
  else begin
    if not (C.CellType in [ctString,ctBoolean,ctError,ctStringFormula]) then
      sAlign := ' ALIGN="right"'
    else
      sAlign := '';
    if C.FillPatternForeColor <> xcAutomatic then
      sColor := Format(' BGCOLOR="%.6x"',[ExcelColorPalette[Integer(C.FillPatternForeColor)]])
    else
      sColor := '';
    S := FXLS.Sheets[SheetIndex].AsHTML[Col,Row];
//    Link := FXLS.Sheets[SheetIndex].RawHyperlink(Col,Row);
    if Link <> '' then begin
      i := CPos(#9,Link);
      if i > 0 then
        Link := Copy(Link,i + 1,MAXINT);
      S := '<A href="' + Link + '">' + S + '</A>';
    end;
    if S = '' then
      S := '&nbsp;';
    WStringCR('<TD' + sAlign + sColor + '>' + S + '</TD>');
  end;
end;

procedure TXLSExportHTML2.WriteFilePrefix;
begin
  inherited;
  if not FWriteOnlyTables then begin
    WStringCR('<HTML><HEAD>');
    WStringCR('<meta http-equiv="Content-Type" content="text/html; charset=iso8859-1">');
    WStringCR('<TITLE>' + FXLS.Filename + '</TITLE>');
    WStringCR('</HEAD>');
    WStringCR('<BODY bgcolor="#FFFFFF">');
  end;
end;

procedure TXLSExportHTML2.WriteFileSuffix;
begin
  inherited;
  if not FWriteOnlyTables then begin
    WStringCR('</BODY>');
    WStringCR('</HTML>');
  end;
end;

procedure TXLSExportHTML2.WritePagePrefix;
begin
  inherited;
  WStringCR(Format('<TABLE COLS="%d" BORDER="%d" CELLPADDING="%d" CELLSPACING="%d"',
     [FXLS.Sheets[FCurrSheetIndex].LastCol - FXLS.Sheets[FCurrSheetIndex].FirstCol + 1,FTABLE.BordeWidth,FTABLE.CellPadding,FTABLE.CellSpacing]));
end;

procedure TXLSExportHTML2.WritePageSuffix;
begin
  inherited;
  WStringCR('</TABLE>');
end;

procedure TXLSExportHTML2.WriteRowPrefix;
begin
  inherited;
  WStringCR('<TR>');
end;

procedure TXLSExportHTML2.WriteRowSuffix;
begin
  inherited;
  WStringCR('</TR>');
end;

procedure TXLSExportHTML2.WString(S: string);
begin
  FStream.Write(Pointer(S)^,Length(S));
end;

procedure TXLSExportHTML2.WStringCR(S: string);
begin
  WString(S + #13#10);
end;

end.