qexport4html.pas

Advanced.Export.Component.v4.01.rar,delphi 第三方控件

unit QExport4HTML;

{$I VerCtrl.inc}

interface

uses QExport4, Classes, QExport4IniFiles, QExport4Types
     {$IFDEF WIN32}
       {$IFNDEF NOGUI}, Graphics{$ELSE}, QExport4Graphics{$ENDIF}
     {$ENDIF}
     {$IFDEF LINUX}
       {$IFNDEF NOGUI}, QGraphics{$ELSE}, QExport4Graphics{$ENDIF}
     {$ENDIF};

type
  TQHTMLWriter = class(TQExportWriter)
  public
    procedure StartHTML;
    procedure EndHTML;
    procedure StartHEAD;
    procedure EndHEAD;
    procedure StartUI;
    procedure EndUI;
    {$IFDEF QE_UNICODE}
    procedure WriteUnicodeCharset(UniType: TQExportCharsetType);
    {$ENDIF}
    procedure LI;
    procedure StartBODY;
    procedure EndBODY;
    procedure StartSTYLE;
    procedure EndSTYLE;
    procedure WriteTITLE(const ATitle: string);
    function AlignToStr(Value: TQExportColAlign): QEString; override;
    procedure WriteLocationLinks(const Index, First, Prior, Next, Last,
      Template: string; PageCount, PageNumber: integer; IsTop, IsIndex: boolean;
      Strings: TStrings);
    procedure WriteCaptionRowTD(const Data: string);
    procedure WriteOddRowTD(const Data: QEString);
    procedure WriteEvenRowTD(const Data: QEString);
    procedure WriteTABLE(BorderWidth, CellPadding, CellSpacing: integer;
      const BackgroundFileName: string);
    procedure EndTABLE;  
    procedure StartFORM;
    procedure EndFORM;
    procedure WriteCSSLink(const FileName: string);
  end;

  TTableOptions = class(TPersistent)
  private
    FCellPadding: integer;
    FCellSpacing: integer;
    FBorder: integer;
    FAdvancedAttributes: TStrings;
    FOddRowBgColor: TColor;
    FHeadersRowFontColor: TColor;
    FTableFontColor: TColor;
    FTableBgColor: TColor;
    FHeadersRowBgColor: TColor;
    FBorderColor: TColor;
    FBackgroundFileName: string;
    procedure SetCellPadding(const Value: integer);
    procedure SetCellSpacing(const Value: integer);
    procedure SetBorder(const Value: integer);
    procedure SetAdvancedAttributes(const Value: TStrings);
    procedure SetHeadersRowBgColor(const Value: TColor);
    procedure SetHeadersRowFontColor(const Value: TColor);
    procedure SetOddRowBgColor(const Value: TColor);
    procedure SetTableBgColor(const Value: TColor);
    procedure SetTableFontColor(const Value: TColor);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;

    procedure SaveToIniFile(IniFile: TQIniFile; const Section: string);
    procedure LoadFromIniFile(IniFile: TQIniFile; const Section: string);
  published
    property Border: integer read FBorder write SetBorder default 1;
    property CellPadding: integer read FCellPadding
      write SetCellPadding default 4;
    property CellSpacing: integer read FCellSpacing
      write SetCellSpacing default 1;
    property AdvancedAttributes: TStrings read FAdvancedAttributes
      write SetAdvancedAttributes;
    property HeadersRowBgColor: TColor read FHeadersRowBgColor
      write SetHeadersRowBgColor;
    property HeadersRowFontColor: TColor read FHeadersRowFontColor
      write SetHeadersRowFontColor;
    property TableBgColor: TColor read FTableBgColor write SetTableBgColor;
    property TableFontColor: TColor read FTableFontColor write SetTableFontColor;
    property OddRowBgColor: TColor read FOddRowBgColor write SetOddRowBgColor;
    property BorderColor: TColor read FBorderColor
      write FBorderColor default clWhite;
    property BackgroundFileName: string read FBackgroundFileName
      write FBackgroundFileName;
  end;

  TDefaultOption = (doFontName, doFontSize);

  TDefaultOptions = set of TDefaultOption;

  THTMLOptions = class(TPersistent)
  private
    FBackgroundColor: TColor;
    FBackgroundFileName: string;
    FVLinkColor: TColor;
    FLinkColor: TColor;
    FALinkColor: TColor;
    FTextFont: TFont;
    FAdvancedAttributes: TStrings;
    FDefaultOptions: TDefaultOptions;
    procedure SetAdvancedAttributes(const Value: TStrings);
    procedure SetTextFont(const Value: TFont);
    procedure SetBackgroundFileName(const Value: string);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;

    procedure SaveToIniFile(IniFile: TQIniFile; const Section: string);
    procedure LoadFromIniFile(IniFile: TQIniFile; const Section: string);
  published
    property BackgroundColor: TColor read FBackgroundColor
      write FBackgroundColor;
    property BackgroundFileName: string read FBackgroundFileName
      write SetBackgroundFileName;
    property LinkColor: TColor read FLinkColor write FLinkColor;
    property VLinkColor: TColor read FVLinkColor write FVLinkColor;
    property ALinkColor: TColor read FALinkColor write FALinkColor;
    property TextFont: TFont read FTextFont write SetTextFont;
    property AdvancedAttributes: TStrings read FAdvancedAttributes
      write SetAdvancedAttributes;
    property DefaultOptions: TDefaultOptions read FDefaultOptions
      write FDefaultOptions;
  end;

  TUsingCSS = (usInternal, usExternal);
  THTMLTemplate = (htCustom, htBW, htClassic, htColorFul, htGray, htMS_Money,
    htMurky, htOlive, htPlain, htSimple);

  TQExportHTMLNavigation = class(TPersistent)
  private
    FIndexLinkTemplate: string;
    FOnBottom: boolean;
    FOnTop: boolean;
    FIndexLinkTitle: string;
    FFirstLinkTitle: string;
    FPriorLinkTitle: string;
    FNextLinkTitle: string;
    FLastLinkTitle: string;
  public
    constructor Create;
    procedure Assign(SOurce: TPersistent); override;
  published
    property IndexLinkTemplate: string read FIndexLinkTemplate
      write FIndexLinkTemplate;
    property OnTop: boolean read FOnTop write FOnTop default true;
    property OnBottom: boolean read FOnBottom write FOnBottom default true;
    property IndexLinkTitle: string read FIndexLinkTitle write FIndexLinkTitle;
    property FirstLinkTitle: string read FFirstLinkTitle write FFirstLinkTitle;
    property PriorLinkTitle: string read FPriorLinkTitle write FPriorLinkTitle;
    property NextLinkTitle: string read FNextLinkTitle write FNextLinkTitle;
    property LastLinkTitle: string read FLastLinkTitle write FLastLinkTitle;
  end;

  TQExport4HTML = class(TQExport4FormatText)
  private
    FBoolAsCheckBox: boolean;
    FGenerateIndex: boolean;
    FMaxRecords: integer;
    FNavigation: TQExportHTMLNavigation;
    FCSSFileName: string;
    FHTMLOptions: THTMLOptions;
    FHTMLTemplate: THTMLTemplate;
    FTableOptions: TTableOptions;
    FUsingCSS: TUsingCSS;
    SStyle: TStringList;
    FCurrPass: integer;
    FUseBorderColor: boolean;
    FOverwriteCSSFile: boolean;

    FStr: TFileStream;
    FPages: TList;
    FInterpretTags: Boolean;

    procedure SetHTMLOptions(const Value: THTMLOptions);
    procedure SetHTMLTemplate(const Value: THTMLTemplate);
    procedure SetMaxRecords(const Value: integer);
    procedure SetTableOptions(const Value: TTableOptions);
    procedure SetNavigation(const Value: TQExportHTMLNavigation);

    procedure DoGenerateIndex;
    procedure ClearPages;
    function IsTableBGDefined: boolean;
    procedure WritePageHeader(const CurrFileName: string);
  protected
    procedure WriteDataRow; override;

    function GetColData(ColValue: QEString;
      Column: TQExportColumn): QEString; override;
    procedure WriteCaptionRow; override;

    function GetSpecialCharacters: TSpecialCharacters; override;

    function GetWriter: TQHTMLWriter;
    function GetWriterClass: TQExportWriterClass; override;

    procedure BeginExport; override;
    procedure BeforeExport; override;
    procedure AfterExport; override;
    procedure EndExport; override;

    function GetShowedFileName: string; override;
    function GetPrintedFileName: string; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Abort; override;
    function NormalString(const S: QEString): QEString; override;
    procedure Execute; override;

    procedure SaveTemplateToFile(const FileName: string);
    procedure LoadTemplateFromFile(const FileName: string);
  published
    property UsingCSS: TUsingCSS read FUsingCSS
      write FUsingCSS default usInternal;
    property CSSFileName: string read FCSSFileName
      write FCSSFileName;
    property OverwriteCSSFile: boolean read FOverwriteCSSFile
      write FOverwriteCSSFile  default true;
    property TableOptions: TTableOptions
      read FTableOptions write SetTableOptions;
    property HTMLOptions: THTMLOptions read FHTMLOptions
      write SetHTMLOptions;
    property HTMLTemplate: THTMLTemplate read FHTMLTemplate
      write SetHTMLTemplate default htClassic;
    property MaxRecords: integer read FMaxRecords
      write SetMaxRecords default 0;
    property GenerateIndex: boolean read FGenerateIndex
      write FGenerateIndex default false;
    property Navigation: TQExportHTMLNavigation read FNavigation
      write SetNavigation;
    property BoolAsCheckBox: boolean read FBoolAsCheckBox
      write FBoolAsCheckBox default false;
    property InterpretTags: Boolean read FInterpretTags
      write FInterpretTags default True;

    property Title;
    property ColumnsAlign;
    property OnGetCellParams;
  end;

  function TemplateToStr(ATemplate: THTMLTemplate): string;

implementation

uses
  SysUtils, QExport4HTMLTemplates, QExport4Common, QExport4EmsWideStrUtils
  {$IFDEF WIN32}
  {$IFDEF VCL9}
  , Windows
  {$ENDIF}
  {$ENDIF};

const // do not localize
  SColor = 'color: %s;';
  SBackgroundColor = 'background-color: %s;';
  SNormal = 'normal';
  SBold = 'bold';
  SItalic = 'italic';
  SFontWeight = 'font-weight: %s;';
  SFontStyle = 'font-style: %s;';
  SNone = 'none';
  SUnderline = 'underline';
  STextDecoration = 'text-decoration: %s;';
  SFontSize = 'font-size: %dpt;';
  SFontFamily = 'font-family: %s;';
  SAlign = 'align=%s';

  SCheckedBox: QEString = '<input type="checkbox" checked disabled>';
  SUncheckedBox: QEString = '<input type="checkbox" disabled>';

type
  THTMLPageOption = class
  private
    FTopLocationLinkPos: integer;
    FBottomLocationLinkPos: integer;
  public
    constructor Create;

    property TopLocationLinkPos: integer read FTopLocationLinkPos
      write FTopLocationLinkPos;
    property BottomLocationLinkPos: integer read FBottomLocationLinkPos
      write FBottomLocationLinkPos;
  end;

  constructor THTMLPageOption.Create;
  begin
    inherited;
    FTopLocationLinkPos := -1;
    FBottomLocationLinkPos := -1;
  end;

function IntToHexStr(const Value: integer): string;
begin
  Result := Format('#%.6x', [Value]);
end;

function D2HTMLColor(DColor: TColor): TColor;
begin
  Result := (DColor and $0000FF00) or ((DColor mod $100) * $10000)
    or ((DColor div $10000) mod $100);
end;

function ExtractFName(const FileName: string): string;
begin
  Result := ChangeFileExt(FileName, '');
end;

function TemplateToStr(ATemplate: THTMLTemplate): string;
const
  TemplateStr: array[THTMLTemplate] of string = ('Custom', 'Black&White',
    'Classic', 'ColorFul', 'Gray', 'MS_Money', 'Murky', 'Olive', 'Plain',
    'Simple');
begin
  Result := TemplateStr[ATemplate];
end;

{ TQHTMLWriter }

function TQHTMLWriter.AlignToStr(Value: TQExportColAlign): QEString;
begin
  case Value of
    ecaLeft: Result := 'Left';
    ecaCenter: Result := 'Center';
    ecaRight: Result := 'Right';
    else Result := EmptyStr;
  end
end;

procedure TQHTMLWriter.EndBODY;
begin
  WriteLn('</BODY>');
end;

procedure TQHTMLWriter.EndHEAD;
begin
  WriteLn('</HEAD>');
end;

procedure TQHTMLWriter.EndHTML;
begin
  WriteLn('</HTML>');
end;

procedure TQHTMLWriter.EndSTYLE;
begin
  WriteLn('</STYLE>');
end;

procedure TQHTMLWriter.EndUI;
begin
  WriteLn('</UI>');
end;

{$IFDEF QE_UNICODE}
procedure TQHTMLWriter.WriteUnicodeCharset(UniType: TQExportCharsetType);
begin
  case UniType of
    ectUTF8:
      WriteLn('<META http-equiv="content-type" content="text/html; charset=UTF-8">');
    ectUTF16:
      WriteLn('<META http-equiv="content-type" content="text/html; charset=UTF-16">');
    ectUTF32:
      WriteLn('<META http-equiv="content-type" content="text/html; charset=UTF-32">');
  end;
end;
{$ENDIF}

procedure TQHTMLWriter.LI;