frxexporthtml.pas

报表控件。FastReport 是非常强大的报表控件

end;

procedure TfrxHTMLExport.ExportObject(Obj: TfrxComponent);
begin
  if Obj is TfrxView then
  begin
    if (Obj is TfrxCustomMemoView) or
      (FExportPictures and (not (Obj is TfrxCustomMemoView))) then
      FMatrix.AddObject(TfrxView(Obj));
    if (TfrxView(Obj).Name = '_pagebackground') and FExportPictures and FBackground then
    begin
      FBackImageExist := True;
      FBackImage.Width := Round(TfrxView(Obj).Width);
      FBackImage.Height := Round(TfrxView(Obj).Height);
      TfrxView(Obj).Draw(FBackImage.Canvas ,1, 1, -TfrxView(Obj).AbsLeft, -TfrxView(Obj).AbsTop);
    end;
  end;
end;

procedure TfrxHTMLExport.FinishPage(Page: TfrxReportPage; Index: Integer);
begin
  if FMultipage then
  begin
    FMatrix.Prepare;
    try
      Exp := TFileStream.Create(GetPicsFolder + IntToStr(FCurrentPage) + '.html', 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, serv, print: String;
  Refresh: String;
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
          Exp := TFileStream.Create(GetPicsFolder + 'main.html', fmCreate)
        else
          Exp := TFileStream.Create(FileName, fmCreate);
      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
      Exp := TFileStream.Create(GetPicsFolder + 'nav.html', fmCreate);
      try
        if FMultipage then
          s := '1'
        else
          s := '0';
        st := '';
        if FPicsInSameFolder then
          st := ChangeFileExt(ExtractFileName(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'))]));

      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
      Exp := TFileStream.Create(FileName, fmCreate);
      try
        WriteExpLn('<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN" "http://www.w3.org/TR/html4/frameset.dtd">');
        WriteExpLn('<html><head>');
        if Length(Report.ReportOptions.Name) > 0 then
          s := Report.ReportOptions.Name
        else
          s := ChangeFileExt(ExtractFileName(Report.FileName), '');
        WriteExpLn('<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>');
      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(FileName), '.')
  else if FMultipage then
    Result := ''
  else if FAbsLinks then
    Result := ExtractFilePath(FileName) + ChangeFileExt(ExtractFileName(FileName),'.files') + '\'
  else if FNavigator then
    Result := ''
  else
    Result := ChangeFileExt(ExtractFileName(FileName),'.files') + '\'
end;

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

function TfrxHTMLExport.GetPicsFolder: String;
var
  SecAtrtrs: TSecurityAttributes;
begin
  if FPicsInSameFolder then
  begin
    if FAbsLinks then
      Result := ExtractFilePath(FileName) + ChangeFileExt(ExtractFileName(FileName), '.')
    else
      Result := ChangeFileExt(ExtractFileName(FileName), '.')
  end
  else
  begin
    if FAbsLinks then
      Result := ExtractFilePath(FileName) + ChangeFileExt(ExtractFileName(FileName), '.files')
    else
      Result := ChangeFileExt(ExtractFileName(FileName), '.files');
    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
  FBackImage.Free;
  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);
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.