frxexporthtml.pas

这个是功能强大的报表软件

{******************************************}
{                                          }
{             FastReport v4.0              }
{         HTML table export filter         }
{                                          }
{         Copyright (c) 1998-2008          }
{          by Alexander Fediachov,         }
{             Fast Reports Inc.            }
{                                          }
{******************************************}

unit frxExportHTML;

interface

{$I frx.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, frxClass, JPEG, ShellAPI, frxExportMatrix, frxProgress
{$IFDEF Delphi6}, Variants {$ENDIF}, frxExportImage;

type
  TfrxHTMLExportDialog = class(TForm)
    SaveDialog1: TSaveDialog;
    GroupQuality: TGroupBox;
    StylesCB: TCheckBox;
    PicsSameCB: TCheckBox;
    FixWidthCB: TCheckBox;
    NavigatorCB: TCheckBox;
    MultipageCB: TCheckBox;
    GroupPageRange: TGroupBox;
    DescrL: TLabel;
    AllRB: TRadioButton;
    CurPageRB: TRadioButton;
    PageNumbersRB: TRadioButton;
    PageNumbersE: TEdit;
    OpenAfterCB: TCheckBox;
    OkB: TButton;
    CancelB: TButton;
    BackgrCB: TCheckBox;
    PicturesL: TLabel;
    PFormatCB: TComboBox;
    procedure FormCreate(Sender: TObject);
    procedure PageNumbersEChange(Sender: TObject);
    procedure PageNumbersEKeyPress(Sender: TObject; var Key: Char);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  end;

  TfrxHTMLExportGetNavTemplate = procedure(const ReportName: String;
    Multipage: Boolean; PicsInSameFolder: Boolean; Prefix: String;
    TotalPages: Integer; var Template: String) of object;

  TfrxHTMLExportGetMainTemplate = procedure(const Title: String;
    const FrameFolder: String;
    Multipage: Boolean; var Template: String) of object;

  TfrxHTMLExport = class(TfrxCustomExportFilter)
  private
    Exp: TStream;
    FAbsLinks: Boolean;
    FCurrentPage: Integer;
    FExportPictures: Boolean;
    FExportStyles: Boolean;
    FFixedWidth: Boolean;
    FMatrix: TfrxIEMatrix;
    FMozillaBrowser: Boolean;
    FMultipage: Boolean;
    FNavigator: Boolean;
    FOpenAfterExport: Boolean;
    FPicsInSameFolder: Boolean;
    FPicturesCount: Integer;
    FProgress: TfrxProgress;
    FUseJpeg: Boolean;
    FServer: Boolean;
    FPrintLink: String;
    FRefreshLink: String;
    FBackground: Boolean;
    FBackImage: TBitmap;
    FBackImageExist: Boolean;
    FReportPath: String;
    FUseGif: Boolean;
    FCentered: Boolean;
    FEmptyLines: Boolean;

//    FAvExports: String;
//    FSession: String;
//    FAllowPrint: Boolean;

    FUseTemplates: Boolean;
    FGetNavTemplate: TfrxHTMLExportGetNavTemplate;
    FGetMainTemplate: TfrxHTMLExportGetMainTemplate;

    FHTMLDocumentBegin: TStrings;
    FHTMLDocumentBody: TStrings;
    FHTMLDocumentEnd: TStrings;

    procedure WriteExpLn(const str: String);
    procedure WriteExpLnA(const str: AnsiString);
    procedure ExportPage;
    function ChangeReturns(const Str: String): String;
    function TruncReturns(const Str: WideString): WideString;
    function GetPicsFolder: String;
    function GetPicsFolderRel: String;
    function GetFrameFolder: String;
    function ReverseSlash(const S: String): String;
    function HTMLCodeStr(const Str: String): String;
    procedure SetUseGif(const Value: Boolean);
    procedure SetUseJpeg(const Value: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ShowModal: TModalResult; override;
    function Start: Boolean; override;
    procedure Finish; override;
    procedure FinishPage(Page: TfrxReportPage; Index: Integer); override;
    procedure StartPage(Page: TfrxReportPage; Index: Integer); override;
    procedure ExportObject(Obj: TfrxComponent); override;
    class function GetDescription: String; override;
    property Server: Boolean read FServer write FServer;
    property PrintLink: String read FPrintLink write FPrintLink;
    property RefreshLink: String read FRefreshLink write FRefreshLink;
    property ReportPath: String read FReportPath write FReportPath;

    property UseTemplates: Boolean read FUseTemplates write FUseTemplates;
    property OnGetMainTemplate: TfrxHTMLExportGetMainTemplate read FGetMainTemplate
      write FGetMainTemplate;
    property OnGetNavTemplate: TfrxHTMLExportGetNavTemplate read FGetNavTemplate
      write FGetNavTemplate;
  published
    property OpenAfterExport: Boolean read FOpenAfterExport write FOpenAfterExport default False;
    property FixedWidth: Boolean read FFixedWidth write FFixedWidth default False;
    property ExportPictures: Boolean read FExportPictures write FExportPictures default True;
    property PicsInSameFolder: Boolean read FPicsInSameFolder write FPicsInSameFolder default False;
    property ExportStyles: Boolean read FExportStyles write FExportStyles default True;
    property Navigator: Boolean read FNavigator write FNavigator default False;
    property Multipage: Boolean read FMultipage write FMultipage default False;
    property MozillaFrames: Boolean read FMozillaBrowser write FMozillaBrowser default False;
    property UseJpeg: Boolean read FUseJpeg write SetUseJpeg default True;
    property UseGif: Boolean read FUseGif write SetUseGif default False;
    property AbsLinks: Boolean read FAbsLinks write FAbsLinks default False;
    property Background: Boolean read FBackground write FBackground;
    property Centered: Boolean read FCentered write FCentered;
    property EmptyLines: Boolean read FEmptyLines write FEmptyLines;
    property OverwritePrompt;
    property HTMLDocumentBegin: TStrings read FHTMLDocumentBegin;
    property HTMLDocumentBody: TStrings read FHTMLDocumentBody;
    property HTMLDocumentEnd: TStrings read FHTMLDocumentEnd;
  end;


implementation

uses frxUtils, frxFileUtils, frxUnicodeUtils, frxRes, frxrcExports, Math;

{$R *.dfm}

const
  Xdivider = 1;
  Ydivider = 1.03;
  Navigator_src =
    '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">'#13#10 +
    '<html><head>' +
    '<meta http-equiv="Content-Type" content="text/html; charset=utf-8">' +
    '<meta name=Generator content="FastReport 4.0 http://www.fast-report.com">' +
    '<title></title><style type="text/css"><!--'#13#10 +
    'body { font-family: Tahoma; font-size: 8px; font-weight: bold; font-style: normal; text-align: center; vertical-align: middle; }'#13#10 +
    'input {text-align: center}'#13#10 +
    '.nav { font : 9pt Tahoma; color : #283e66; font-weight : bold; text-decoration : none;}'#13#10 +
    '--></style><script language="javascript" type="text/javascript"><!--'#13#10 +
    '  var frPgCnt = %s; var frRepName = "%s"; var frMultipage = %s; var frPrefix="%s";'#13#10 +
    '  function DoPage(PgN) {'#13#10 +
    '    if ((PgN > 0) && (PgN <= frPgCnt) && (PgN != parent.frCurPage)) {'#13#10 +
    '      if (frMultipage > 0)  parent.mainFrame.location = frPrefix + PgN + ".html";'#13#10 +
    '      else parent.mainFrame.location = frPrefix + "main.html#PageN" + PgN;'#13#10 +
    '      UpdateNav(PgN); } else document.PgForm.PgEdit.value = parent.frCurPage; }'#13#10 +
    '  function UpdateNav(PgN) {'#13#10 +
    '    parent.frCurPage = PgN; document.PgForm.PgEdit.value = PgN;'#13#10 +
    '    if (PgN == 1) { document.PgForm.bFirst.disabled = 1; document.PgForm.bPrev.disabled = 1; }'#13#10 +
    '    else { document.PgForm.bFirst.disabled = 0; document.PgForm.bPrev.disabled = 0; }'#13#10 +
    '    if (PgN == frPgCnt) { document.PgForm.bNext.disabled = 1; document.PgForm.bLast.disabled = 1; }'#13#10 +
    '    else { document.PgForm.bNext.disabled = 0; document.PgForm.bLast.disabled = 0; } }'#13#10 +
    '  function RefreshRep() { %s }'#13#10 +
    '  function PrintRep() { %s }'#13#10 +
    '--></script></head>'#13#10 +
    '<body bgcolor="#DDDDDD" text="#000000" leftmargin="0" topmargin="4" onload="UpdateNav(parent.frCurPage)">'#13#10 +
    '<form name="PgForm" onsubmit="DoPage(document.forms[0].PgEdit.value); return false;" action="">'#13#10 +
    '<table cellspacing="0" align="left" cellpadding="0" border="0" width="100%%">'#13#10 +
    '<tr valign="middle">'#13#10 +
    '<td width="60" align="center"><button name="bFirst" class="nav" type="button" onclick="DoPage(1); return false;">%s</button></td>'#13#10 +
    '<td width="60" align="center"><button name="bPrev" class="nav" type="button" onclick="DoPage(Math.max(parent.frCurPage - 1, 1)); return false;">%s</button></td>'#13#10 +
    '<td width="100" align="center"><input type="text" class="nav" name="PgEdit" value="parent.frCurPage" size="4"></td>'#13#10 +
    '<td width="60" align="center"><button name="bNext" class="nav" type="button" onclick="DoPage(parent.frCurPage + 1); return false;">%s</button></td>'#13#10 +
    '<td width="60" align="center"><button name="bLast" class="nav" type="button" onclick="DoPage(frPgCnt); return false;">%s</button></td>'#13#10 +
    '<td width="20">&nbsp;</td>'#13#10'%s' +
    '<td align="right">%s: <script language="javascript" type="text/javascript"> document.write(frPgCnt);</script></td>'#13#10 +
    '<td width="10">&nbsp;</td>'#13#10 +
    '</tr></table></form></body></html>';
  Server_sect =
    '<td width="60" align="center"><button name="bRefresh" class="nav" type="button" onclick="RefreshRep(); return false;">%s</button></td>'#13#10 +
    '<td width="60" align="center"><button name="bPrint" class="nav" type="button" onclick="PrintRep(); return false;">%s</button></td>'#13#10;
  DefPrint = 'parent.mainFrame.focus(); parent.mainFrame.print();';
  LinkPrint = 'parent.location = "%s";';
  DefRefresh = 'parent.location = "result?report=" + frRepName + "&multipage=" + frMultipage;';
  LinkRefresh = 'parent.location = "%s";';

{ TfrxHTMLExport }

constructor TfrxHTMLExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FExportPictures := True;
  FExportStyles := True;
  FFixedWidth := True;
  FUseJpeg := True;
  FUseGif := False;
  FServer := False;
  FPrintLink := '';
  FBackground := False;
  FCentered := False;
  FBackImage := TBitmap.Create;
  FilterDesc := frxGet(8210);
  DefaultExt := frxGet(8211);
  FEmptyLines := True;
  Files := TStringList.Create;
  FUseTemplates := False;
  FHTMLDocumentBegin := TStringList.Create;
  FHTMLDocumentBegin.Add('<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">');
  FHTMLDocumentBegin.Add('<html><head>');
  FHTMLDocumentBegin.Add('<meta http-equiv="Content-Type" content="text/html; charset=utf-8">');
  FHTMLDocumentBegin.Add('<meta name=Generator content="FastReport 4.0 http://www.fast-report.com">');
  FHTMLDocumentBody := TStringList.Create;
  FHTMLDocumentEnd := TStringList.Create;
  FHTMLDocumentEnd.Add('</body></html>');
end;

class function TfrxHTMLExport.GetDescription: String;
begin
  Result := frxResources.Get('HTMLexport');
end;

function TfrxHTMLExport.TruncReturns(const Str: WideString): WideString;
var
  l: Integer;
begin
  l := Length(Str);
  if (l > 1) and (Str[l - 1] = #13) and (Str[l] = #10) then
    Result := Copy(Str, 1, l - 2)
  else
    Result := Str;
end;

function TfrxHTMLExport.ChangeReturns(const Str: String): String;
var
  i: Integer;
begin
  Result := '';
  for i := 1 to Length(Str) do
  begin
    if Str[i] = '&' then
      Result := Result + '&amp;'
    else if (i < Length(Str)) and (Str[i] = #13) and (Str[i + 1] = #10) then
      Result := Result + '<br>'
    else if Str[i] = '"' then
      Result := Result + '&quot;'
    else if (Str[i] <> #10) then
      Result := Result + Str[i]
  end;
end;

procedure TfrxHTMLExport.WriteExpLn(const str: String);
{$IFDEF Delphi12}
var
  TempStr: AnsiString;
{$ENDIF}
begin
{$IFDEF Delphi12}
  TempStr := UTF8Encode(str);
  Exp.Write(TempStr[1], Length(TempStr));
{$ELSE}
  Exp.Write(str[1], Length(str));
{$ENDIF}
  Exp.Write(AnsiChar(#13)+AnsiChar(#10), 2);
end;

procedure TfrxHTMLExport.WriteExpLnA(const str: AnsiString);
begin
  Exp.Write(str[1], Length(str));
  Exp.Write(AnsiChar(#13)+AnsiChar(#10), 2);
end;

procedure TfrxHTMLExport.ExportPage;
var
  i, x, y, dx, dy, fx, fy, pbk: Integer;
  dcol, drow: Integer;
  text, buff: String;
  s, s1, sb, si, su: String;
  Vert, Horiz: String;
  obj: TfrxIEMObject;
  EStyle: TfrxIEMStyle;
  St: String;
  hlink, newpage: Boolean;
  jpg : TJPEGImage;
  tableheader, columnWidths: String;

  procedure AlignFR2AlignExcel(HAlign: TfrxHAlign; VAlign: TfrxVAlign;
    var AlignH, AlignV: String);
  begin
    if HAlign = haLeft then
      AlignH := 'Left'
    else if HAlign = haRight then
      AlignH := 'Right'
    else if HAlign = haCenter then
      AlignH := 'Center'
    else if HAlign = haBlock then
      AlignH := 'Justify'
    else
      AlignH := '';
    if VAlign = vaTop then
      AlignV := 'Top'
    else if VAlign = vaBottom then
      AlignV := 'Bottom'
    else if VAlign = vaCenter then
      AlignV := 'Middle'
    else
      AlignV := '';
  end;

begin
  WriteExpLn(FHTMLDocumentBegin.Text);
  if Length(Report.ReportOptions.Name) > 0 then
    s := Report.ReportOptions.Name
  else
    s := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(Report.FileName)), '');
  WriteExpLnA('<title>' + UTF8Encode(s) + '</title>');

  if FExportStyles then
  begin
    WriteExpLn('<style type="text/css"><!-- ');
    WriteExpLn('.page_break {page-break-before: always;}');
    for x := 0 to FMatrix.StylesCount - 1 do
    begin
      EStyle := FMatrix.GetStyleById(x);
      s := 's' + IntToStr(x);
      WriteExpLn('.' + s + ' {');
      if Assigned(EStyle.Font) then
      begin
        su := '';
        sb := '';
        si := '';
        if fsBold in EStyle.Font.Style then
          sb := ' font-weight: bold;'
        else
          sb := '';
        if fsItalic in EStyle.Font.Style then
          si := ' font-style: italic;'
        else
          si := ' font-style: normal;';

        if fsUnderline in EStyle.Font.Style then
          su := ' text-decoration: underline';
        if fsStrikeout in EStyle.Font.Style then
        begin
          if su = '' then
            su := ' text-decoration: line-through'
          else
            su := su + ' | line-through';
        end;
        if su <> '' then
          su := su + ';';
        WriteExpLn(' font-family: ' + EStyle.Font.Name + ';'#13#10 +
          ' font-size: ' + IntToStr(Round(EStyle.Font.Size * 96 / 72)) + 'px;'#13#10 +
          ' color: ' + HTMLRGBColor(EStyle.Font.Color) + ';' + sb + si + su);
      end;
      if EStyle.Color = clNone then
        WriteExpLn(' background-color: transparent;')
      else
        WriteExpLn(' background-color: ' + HTMLRGBColor(EStyle.Color) + ';');
      AlignFR2AlignExcel(EStyle.HAlign, EStyle.VAlign, Horiz, Vert);
      if EStyle.FrameTyp <> [] then
      begin
        su := IntToStr(Round(EStyle.FrameWidth));
        s := HTMLRGBColor(EStyle.FrameColor);
        si := ' border-color:' + s + ';';
        WriteExpLn(si + ' border-style: solid;');
        if (ftLeft in EStyle.FrameTyp) then
          WriteExpLn(' border-left-width: ' + su + ';')
        else
          WriteExpLn(' border-left-width: 0px;');
        if (ftRight in EStyle.FrameTyp) then
          WriteExpLn(' border-right-width: ' + su + ';')