frxexporthtml.pas

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

  s: String;
begin
  if FMultipage then
  begin
    FMatrix.Prepare;
    try
      s := GetPicsFolder + IntToStr(FCurrentPage) + '.html';
      Files.Add(s);
      Exp := TFileStream.Create(s, fmCreate);
      try
        ExportPage;
      finally
        FMatrix.Clear;
        Exp.Free;
      end;
    except
      on e: Exception do
        case Report.EngineOptions.NewSilentMode of
          simSilent:        Report.Errors.Add(e.Message);
          simMessageBoxes:  frxErrorMsg(e.Message);
          simReThrow:       raise;
        end;
    end;
  end
  else FMatrix.AddPage(Page.Orientation, Page.Width, Page.Height, Page.LeftMargin,
                    Page.TopMargin, Page.RightMargin, Page.BottomMargin);
end;

procedure TfrxHTMLExport.Finish;
var
  s, st, print: String;
  serv, Refresh: String;
{$IFDEF Delphi12}
  TempString: AnsiString;
{$ENDIF}
begin
  if not FMultipage then
  begin
    if ShowProgress then
    begin
      FProgress := TfrxProgress.Create(Self);
      FProgress.Execute(FCurrentPage - 1, frxResources.Get('ProgressWait'), true, true);
    end;
    FMatrix.Prepare;
    try
      if ShowProgress then
        if FProgress.Terminated then
          Exit;
      if not Assigned(Stream) then
      begin
        if FNavigator then
        begin
          s := GetPicsFolder + 'main.html';
          Files.Add(s);
          Exp := TFileStream.Create(s, fmCreate);
        end
        else
        begin
          Exp := TFileStream.Create(FileName, fmCreate);
          Files.Add(FileName);
        end;
      end
      else
        Exp := Stream;
      try
        ExportPage;
      finally
        FMatrix.Clear;
        if not Assigned(Stream) then
          Exp.Free;
      end;
    except
      on e: Exception do
        case Report.EngineOptions.NewSilentMode of
          simSilent:        Report.Errors.Add(e.Message);
          simMessageBoxes:  frxErrorMsg(e.Message);
          simReThrow:       raise;
        end;
    end;
    if ShowProgress then
      FProgress.Free;
  end;
  if FNavigator then
  begin
    try
      s := GetPicsFolder + 'nav.html';
      Files.Add(s);
      Exp := TFileStream.Create(s, fmCreate);
      try
        if not FUseTemplates then
        begin
          if FMultipage then
            s := '1'
          else
            s := '0';
          st := '';
          if FPicsInSameFolder then
            st := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)), '.');
          if FServer then
            serv := Format(Server_sect, [UTF8Encode(frxResources.Get('HTMLNavRefresh')), UTF8Encode(frxResources.Get('HTMLNavPrint'))])
          else
            serv := '';
          if Length(FPrintLink) > 0 then
            print := Format(LinkPrint, [FPrintLink])
          else
            print := DefPrint;

          if Length(FRefreshLink) > 0 then
            refresh := Format(LinkRefresh, [FRefreshLink])
          else
            refresh := DefRefresh;

          WriteExpLn(Format(Navigator_src, [
            IntToStr(FCurrentPage),
            HTMLCodeStr(StringReplace(Report.FileName, FReportPath, '', [])),
            s, st, Refresh, print,
            UTF8Encode(frxResources.Get('HTMLNavFirst')),
            UTF8Encode(frxResources.Get('HTMLNavPrev')),
            UTF8Encode(frxResources.Get('HTMLNavNext')),
            UTF8Encode(frxResources.Get('HTMLNavLast')),
            serv, UTF8Encode(frxResources.Get('HTMLNavTotal'))]));
        end
        else
        begin
          if Assigned(FGetNavTemplate) then
          begin
            s := '';
            FGetNavTemplate(HTMLCodeStr(StringReplace(Report.FileName, FReportPath, '', [])),
              FMultipage, FPicsInSameFolder,
              ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)), '.'),
              FCurrentPage,
              s
            );
            {$IFDEF Delphi12}
            TempString := UTF8Encode(s);
            Exp.Write(TempString[1], Length(TempString));
            {$ELSE}
            Exp.Write(s[1], Length(s));
            {$ENDIF}
          end;
        end;
      finally
        Exp.Free;
      end;
    except
      on e: Exception do
        case Report.EngineOptions.NewSilentMode of
          simSilent:        Report.Errors.Add(e.Message);
          simMessageBoxes:  frxErrorMsg(e.Message);
          simReThrow:       raise;
        end;
    end;
    try
      Files.Add(FileName);
      Exp := TFileStream.Create(FileName, fmCreate);
      try
        if Length(Report.ReportOptions.Name) > 0 then
          s := Report.ReportOptions.Name
        else
          s := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(Report.FileName)), '');
        if not FUseTemplates then
        begin
          WriteExpLn('<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN" "http://www.w3.org/TR/html4/frameset.dtd">');
          WriteExpLn('<html><head>');
          WriteExpLnA('<title>' + UTF8Encode(s) + '</title>');
          WriteExpLn('<meta http-equiv="Content-Type" content="text/html; charset=utf-8">');
          WriteExpLn('<script language="javascript" type="text/javascript"> var frCurPage = 1;</script></head>');
          WriteExpLn('<frameset rows="32,*" cols="*">');
          WriteExpLn('<frame name="topFrame" src="' + ReverseSlash(GetFrameFolder) + 'nav.html" noresize scrolling="no">');
          if FMultipage then
            WriteExpLn('<frame name="mainFrame" src="' + ReverseSlash(GetFrameFolder) + '1.html">')
          else
            WriteExpLn('<frame name="mainFrame" src="' + ReverseSlash(GetFrameFolder) + 'main.html">');
          WriteExpLn('</frameset>');
          WriteExpLn('</html>');
        end
        else
        begin
          if Assigned(FGetMainTemplate) then
          begin
            st := '';
            FGetMainTemplate(
              String(UTF8Encode(s)), // title
              ReverseSlash(GetFrameFolder), // frame folder
              FMultipage,  // multipage
              st
            );
            {$IFDEF Delphi12}
            TempString := UTF8Encode(st);
            Exp.Write(TempString[1], Length(TempString));
            {$ELSE}
            Exp.Write(st[1], Length(st));
            {$ENDIF}
          end;
        end;
      finally
        Exp.Free;
      end;
    except
      on e: Exception do
        case Report.EngineOptions.NewSilentMode of
          simSilent:        Report.Errors.Add(e.Message);
          simMessageBoxes:  frxErrorMsg(e.Message);
          simReThrow:       raise;
        end;
    end;
  end;

  FMatrix.Free;
  if FOpenAfterExport and (not Assigned(Stream)) then
    if FMultipage and (not FNavigator) then
      ShellExecute(GetDesktopWindow, 'open', PChar(GetPicsFolder + '1.html'), nil, nil, SW_SHOW)
    else
      ShellExecute(GetDesktopWindow, 'open', PChar(FileName), nil, nil, SW_SHOW);
end;

function TfrxHTMLExport.GetPicsFolderRel: String;
begin
  if FPicsInSameFolder then
    Result := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)), '.')
  else if FMultipage then
    Result := ''
  else if FAbsLinks then
    Result := ExtractFilePath(FileName) + ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)),'.files') + '\'
  else if FNavigator then
    Result := ''
  else
    Result := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)),'.files') + '\'
end;

function TfrxHTMLExport.GetFrameFolder: String;
begin
  if not FPicsInSameFolder then
    Result := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)),'.files') + '\'
  else
    Result := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)), '.');
end;

function TfrxHTMLExport.GetPicsFolder: String;
var
  SecAtrtrs: TSecurityAttributes;
begin
  if FPicsInSameFolder then
  begin
    if FAbsLinks then
      Result := ExtractFilePath(FileName) + ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)), '.')
    else
      Result := ChangeFileExt(frxUnixPath2WinPath(FileName), '.') //ExtractFileName
  end
  else
  begin
    if FAbsLinks then
      Result := ExtractFilePath(FileName) + ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(FileName)), '.files')
    else
      Result := ChangeFileExt(frxUnixPath2WinPath(FileName), '.files'); //ExtractFileName
    SecAtrtrs.nLength := SizeOf(TSecurityAttributes);
    SecAtrtrs.lpSecurityDescriptor := nil;
    SecAtrtrs.bInheritHandle := True;
    CreateDirectory(PChar(Result), @SecAtrtrs);
    Result := Result + '\';
  end;
end;

function TfrxHTMLExport.ReverseSlash(const S: String): String;
begin
  Result := StringReplace(S, '\', '/', [rfReplaceAll]);
end;

destructor TfrxHTMLExport.Destroy;
begin
  FHTMLDocumentBegin.Free;
  FHTMLDocumentBody.Free;
  FHTMLDocumentEnd.Free;
  FBackImage.Free;
  Files.Free;
  Files := nil;
  inherited;
end;

function TfrxHTMLExport.HTMLCodeStr(const Str: String): String;
var
  i: Integer;
  c: Char;
  s: String;

  function StrToHex(const s: String): String;
  var
    Len, i: Integer;
    C, H, L: Byte;

    function HexChar(N : Byte) : Char;
    begin
      if (N < 10) then Result := Chr(Ord('0') + N)
      else Result := Chr(Ord('A') + (N - 10));
    end;

  begin
    Len := Length(s);
    SetLength(Result, Len shl 1);
    for i := 1 to Len do begin
      C := Ord(s[i]);
      H := (C shr 4) and $f;
      L := C and $f;
      Result[i shl 1 - 1] := HexChar(H);
      Result[i shl 1]:= HexChar(L);
    end;
  end;

begin
  Result := '';
  for i := 1 to Length(Str) do
  begin
    c := Str[i];
    case c of
     '0'..'9', 'A'..'Z', 'a'..'z': Result := Result + c;
      else begin
        s := c;
        Result := Result + '%' + StrToHex(s);
      end
   end;
  end;
end;

procedure TfrxHTMLExport.SetUseGif(const Value: Boolean);
begin
  FUseGif := Value;
  if FUseJpeg and FUseGif then
    FUseJpeg := False;
end;

procedure TfrxHTMLExport.SetUseJpeg(const Value: Boolean);
begin
  FUseJpeg := Value;
  if FUseJpeg and FUseGif then
    FUseGif := False;
end;

{ TfrxHTMLExportDialog }

procedure TfrxHTMLExportDialog.FormCreate(Sender: TObject);
begin
  Caption := frxGet(8200);
  OkB.Caption := frxGet(1);
  CancelB.Caption := frxGet(2);
  GroupPageRange.Caption := frxGet(7);
  AllRB.Caption := frxGet(3);
  CurPageRB.Caption := frxGet(4);
  PageNumbersRB.Caption := frxGet(5);
  DescrL.Caption := frxGet(9);
  GroupQuality.Caption := frxGet(8);
  OpenAfterCB.Caption := frxGet(8201);
  StylesCB.Caption := frxGet(8202);
  PicturesL.Caption := frxGet(8203);
  PicsSameCB.Caption := frxGet(8204);
  FixWidthCB.Caption := frxGet(8205);
  NavigatorCB.Caption := frxGet(8206);
  MultipageCB.Caption := frxGet(8207);
  BackgrCB.Caption := frxGet(8209);
  SaveDialog1.Filter := frxGet(8210);
  SaveDialog1.DefaultExt := frxGet(8211);
  PFormatCB.Items[0] := frxGet(8313);

  if UseRightToLeftAlignment then
    FlipChildren(True);
end;


procedure TfrxHTMLExportDialog.PageNumbersEChange(Sender: TObject);
begin
  PageNumbersRB.Checked := True;
end;

procedure TfrxHTMLExportDialog.PageNumbersEKeyPress(Sender: TObject;
  var Key: Char);
begin
  case key of
    '0'..'9':;
    #8, '-', ',':;
  else
    key := #0;
  end;
end;

procedure TfrxHTMLExportDialog.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_F1 then
    frxResources.Help(Self);
end;

end.