importhtmltable2.pas

一个经典的读写Excel的控件

unit ImportHTMLTable2;

{
********************************************************************************
******* 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.                                                     **
********************************************************************************
}

{$I XLSRWII2.inc}

{$B-}

interface

uses
  Windows, Messages, SysUtils, Classes, XLSReadWriteII2, HTMLParse2, HTMLTypes2;

type TTableEvent = procedure(Sender: TObject; TableNumber: integer; var ReadIt: boolean) of object;

type TXLSImportHTMLTable2 = class(TComponent)
private
    FXLS: TXLSReadWriteII2;
    FFilename: string;
    FConvertNumValues: boolean;
    FSkipBlankStrings: boolean;
    FCurrTable,FCurrRow,FCurrCol: integer;
    FTableEvent: TTableEvent;
    FInsCol,FInsRow: word;
protected
    procedure ScanForTables (E: THTMLElementArray);
    procedure DoTable       (E: THTMLElementArray; var i: integer);
    procedure DoRow         (E: THTMLElementArray; var i: integer);
    procedure DoCell        (E: THTMLElementArray; var i: integer);
public
    constructor Create(AOwner: TComponent); override;
    procedure Read;
published
    property XLS: TXLSReadWriteII2 read FXLS write FXLS;
    property Filename: string read FFilename write FFilename;
    property ConvertNumValues: boolean read FConvertNumValues write FConvertNumValues;
    property InsertCol: word read FInsCol write FInsCol;
    property InsertRow: word read FInsRow write FInsRow;

    property OnTable: TTableEvent read FTableEvent write FTableEvent;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('XLS', [TXLSImportHTMLTable2]);
end;

{ TXLSImportHTMLTable }

procedure TXLSImportHTMLTable2.Read;
var
  Parser: THTMLParser;
  Elements: THTMLElementArray;
begin
  if FFilename = '' then
    raise Exception.Create('Filename is missing');
  if FXLS = Nil then
    raise Exception.Create('TXLSReadWriteII is missing');
  FCurrTable := -1;
  FCurrRow := -1;
  Parser := THTMLParser.Create(Elements);
  try
    Parser.LoadFromFile(FFilename);
    ScanForTables(Elements);
  finally
    Parser.Free;
  end;
end;

procedure TXLSImportHTMLTable2.DoCell(E: THTMLElementArray; var i: integer);
var
  j: integer;

procedure AddCell(S: string);
var
  TempDS: char;
begin
  if FSkipBlankStrings and (Trim(S) = '') then
    Exit;
  if not FConvertNumValues then
    FXLS.Sheets[0].AsString[FCurrCol,FCurrRow] := S
  else begin
    try
      FXLS.Sheets[0].AsFloat[FCurrCol,FCurrRow] := StrToFloat(S);
    except
      TempDS := DecimalSeparator;
      try
        try
          FXLS.Sheets[0].AsFloat[FCurrCol,FCurrRow] := StrToFloat(S);
        except
          FXLS.Sheets[0].AsString[FCurrCol,FCurrRow] := S;
        end;
      finally
        DecimalSeparator := TempDS;
      end;
    end;
  end;
end;

begin
  Inc(FCurrCol);
  while i <= High(E) do begin
    case E[i].ID of
      heEndTABLE,heEndTR,heEndTD:
        Break;
      else begin
        for j := 0 to High(E[i].Attributes) do begin
          if E[i].Attributes[j].ID = eaText then begin
            if E[i].Attributes[j].AttType = atString then
              AddCell(E[i].Attributes[j].StrVal);
          end;
        end;
      end;
    end;
    Inc(i);
  end;
end;

procedure TXLSImportHTMLTable2.DoRow(E: THTMLElementArray; var i: integer);
begin
  Inc(FCurrRow);
  FCurrCol := -1;
  Inc(i);
  while i <= High(E) do begin
    case E[i].ID of
      heEndTABLE,heEndTR:
        Break;
      heTABLE:
        DoTable(E,i);
      heTR:
        DoRow(E,i);
      heTD:
        DoCell(E,i);
    end;
    Inc(i);
  end;
end;

procedure TXLSImportHTMLTable2.DoTable(E: THTMLElementArray; var i: integer);
var
  Ok: boolean;
begin
  Inc(FCurrTable);
  Ok := true;
  if Assigned(FTableEvent) then
    FTableEvent(Self,FCurrTable,Ok);
  Inc(FCurrRow);
  Inc(i);
  while i <= High(E) do begin
    case E[i].ID of
      heEndTABLE:
        Break;
      heTABLE:
        if Ok then DoTable(E,i);
      heTR:
        if Ok then DoRow(E,i);
    end;
    Inc(i);
  end;
end;

procedure TXLSImportHTMLTable2.ScanForTables(E: THTMLElementArray);
var
  i: integer;
begin
  i := 0;
  while i <= High(E) do begin
    if E[i].ID = heTABLE then
      DoTable(E,i);
    Inc(i);
  end;
end;

constructor TXLSImportHTMLTable2.Create(AOwner: TComponent);
begin
  inherited;
  FConvertNumValues := True;
  FSkipBlankStrings := True;
end;

end.