frxexporthtml.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

          end
          else
            hlink := False;
          if Obj.IsText then
          begin
            text := Trim(ChangeReturns(TruncReturns(Obj.Memo.Text)));
            if Length(text) > 0 then
              buff := buff + UTF8Encode(text)
            else
              buff := buff + ' ';
          end else
          begin
            if FUseJpeg then
            begin
              s := ReverseSlash(GetPicsFolder + 'img' + IntToStr(FPicturesCount) + '.jpg');
              jpg := TJPEGImage.Create;
              jpg.Assign(Obj.Image);
              jpg.SaveToFile(s);
              jpg.Free;
              s := ReverseSlash(GetPicsFolderRel + 'img' + IntToStr(FPicturesCount) + '.jpg');
            end else
            begin
              s := ReverseSlash(GetPicsFolder + 'img' + IntToStr(FPicturesCount) + '.bmp');
              Obj.Image.SaveToFile(s);
              s := ReverseSlash(GetPicsFolderRel + 'img' + IntToStr(FPicturesCount) + '.bmp');
            end;
            buff := buff + '<img src="' + s + '" width="' + IntToStr(Obj.Image.Width) +
                           '" height="' + IntToStr(Obj.Image.Height) + '" alt="">';
            Inc(FPicturesCount);
          end;
          if hlink then
            buff := buff + '</a>';
          buff := buff + '</td>';
        end;
      end
      else
        buff := buff + '<td></td>';
    end;
    WriteExpLn(buff);
    WriteExpLn('</tr>');
    if newpage then
    begin
      WriteExpLn('</table>');
      newpage := False;
      if y < FMatrix.Height - 2 then
      begin
        WriteExpLn('<a name="PageN' + IntToStr(pbk + 1) + '"></a>');
        WriteExpLn(tableheader + ' class="page_break">');
        WriteExpLn(columnWidths);
      end;
    end;
  end;
  if FMultipage then WriteExpLn('</table>');
  WriteExpLn('</body></html>');
end;

function TfrxHTMLExport.ShowModal: TModalResult;
begin
  if not Assigned(Stream) then
  begin
    with TfrxHTMLExportDialog.Create(nil) do
    begin
      StylesCB.Checked := FExportStyles;
      PicsSameCB.Checked := FPicsInSameFolder;
      PicturesCB.Checked := FExportPictures;
      OpenAfterCB.Checked := FOpenAfterExport;
      FixWidthCB.Checked := FFixedWidth;
      NavigatorCB.Checked := FNavigator;
      MultipageCB.Checked := FMultipage;
      MozillaCB.Checked := FMozillaBrowser;
      BackgrCB.Checked := FBackground;

      Result := ShowModal;
      if Result = mrOk then
      begin
        PageNumbers := '';
        CurPage := False;
        if CurPageRB.Checked then
          CurPage := True
        else if PageNumbersRB.Checked then
          PageNumbers := PageNumbersE.Text;

        FMozillaBrowser := MozillaCB.Checked;
        FExportStyles := StylesCB.Checked;
        FPicsInSameFolder := PicsSameCB.Checked;
        FExportPictures := PicturesCB.Checked;
        FOpenAfterExport := OpenAfterCB.Checked;
        FFixedWidth := FixWidthCB.Checked;
        FMultipage := MultipageCB.Checked;
        FNavigator := NavigatorCB.Checked;
        FBackground := BackgrCB.Checked;

        if SaveDialog1.Execute then
          FileName := SaveDialog1.FileName
        else
          Result := mrCancel;
      end;
      Free;
    end
  end else
    Result := mrOk;
end;

function TfrxHTMLExport.Start: Boolean;
begin
  if (FileName <> '') or Assigned(Stream) then
  begin
    FCurrentPage := 0;
    FPicturesCount := 0;
    FMatrix := TfrxIEMatrix.Create;
    FMatrix.Report := Report;
    if not FMultipage then
      FMatrix.ShowProgress := ShowProgress
    else
      FMatrix.ShowProgress := False;
    FMatrix.Inaccuracy := 0.5;
    FMatrix.RotatedAsImage := True;
    FMatrix.FramesOptimization := True;
    FMatrix.Background := FBackground;
    FMatrix.BackgroundImage := False;
    FMatrix.Printable := ExportNotPrintable;
    if Assigned(Stream) then
    begin
      FMultipage := False;
      FExportPictures := False;
      FNavigator := False;
    end;
    Result := True
  end
  else
    Result := False;
end;

procedure TfrxHTMLExport.StartPage(Page: TfrxReportPage; Index: Integer);
begin
  Inc(FCurrentPage);
  FBackImageExist := False;
  FBackImage.Width := 0;
  FBackImage.Height := 0;
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
        if Report.EngineOptions.SilentMode then
          Report.Errors.Add(e.Message)
        else frxErrorMsg(e.Message);
    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;
begin
  if not FMultipage then
  begin
    if FShowProgress then
    begin
      FProgress := TfrxProgress.Create(Self);
      FProgress.Execute(FCurrentPage - 1, frxResources.Get('ProgressWait'), true, true);
    end;
    FMatrix.Prepare;
    try
      if FShowProgress 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
        if Report.EngineOptions.SilentMode then
          Report.Errors.Add(e.Message)
        else frxErrorMsg(e.Message);
    end;
    if FShowProgress 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';
        if FMozillaBrowser then
          st := GetPicsFolder
        else
          st := '';
        if FPicsInSameFolder then
          st := ChangeFileExt(ExtractFileName(FileName), '.');
        if FServer then
          serv := Format(Server_sect, [frxResources.Get('HTMLNavRefresh'), frxResources.Get('HTMLNavPrint')])
        else
          serv := '';
        if Length(FPrintLink) > 0 then
          print := Format(LinkPrint, [FPrintLink])
        else
          print := DefPrint;

        WriteExpLn(Format(Navigator_src, [IntToStr(FCurrentPage),
          HTMLCodeStr(StringReplace(Report.FileName, FReportPath, '', [])),
          s, st, print,
          frxResources.Get('HTMLNavFirst'),
          frxResources.Get('HTMLNavPrev'),
          frxResources.Get('HTMLNavNext'),
          frxResources.Get('HTMLNavLast'),
          serv, frxResources.Get('HTMLNavTotal')]));
      finally
        Exp.Free;
      end;
    except
      on e: Exception do
        if Report.EngineOptions.SilentMode then
          Report.Errors.Add(e.Message)
        else frxErrorMsg(e.Message);
    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
        if Report.EngineOptions.SilentMode then
          Report.Errors.Add(e.Message)
        else frxErrorMsg(e.Message);
    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(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;


{ TfrxHTMLExportDialog }

procedure TfrxHTMLExportDialog.FormCreate(Sender: TObject);
begin
  frxResources.LocalizeForm(Self);
end;


end.