frxpdffile.pas

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

  inherited SaveToStream(Stream);
  OutlineCount := 0;
  OutlineTree := nil;
  if FOutline then
    if not Assigned(FPreviewOutline) then
      FOutline := False
    else
      FPreviewOutline.LevelRoot;
  FCounter := 1;
  s := FormatDateTime('yyyy', Now) + FormatDateTime('mm', Now) +
    FormatDateTime('dd', Now) + FormatDateTime('hh', Now) +
    FormatDateTime('nn', Now) + FormatDateTime('ss', Now);
  WriteLn(Stream, '%PDF-' + PDF_VER);
  WriteLn(Stream, '%'#226#227#207#211);
  XRefAdd(Stream);
  WriteLn(Stream, IntToStr(FCounter) + ' 0 obj');
  Inc(FCounter);
  WriteLn(Stream, '<<');
  WriteLn(Stream, '/Type /Catalog');
  i := 0;

  if FOutline then
  begin
    OutlineTree := TfrxPDFOutlineNode.Create;
    NodeNumber := 0;
    DoPrepareOutline(OutlineTree);
    OutlineCount := OutlineTree.CountTree - OutlineTree.Last.CountTree;
    i := OutlineTree.CountTree + 1;
  end;

  FPagesRoot := 3 + i;
  WriteLn(Stream, '/Pages ' + IntToStr(FPagesRoot) + ' 0 R');
  if FOutline then s1 := '/UseOutlines'
  else s1 := '/UseNone';
  WriteLn(Stream, '/PageMode ' + s1);
  if FOutline then
    WriteLn(Stream, '/Outlines ' + IntToStr(FCounter + 1) + ' 0 R');
  if Length(Title) > 0 then
    WriteLn(Stream, '/ViewerPreferences << /DisplayDocTitle true >>');
  WriteLn(Stream, '>>');
  WriteLn(Stream, 'endobj');
  XRefAdd(Stream);
  WriteLn(Stream, IntToStr(FCounter) + ' 0 obj');
  Inc(FCounter);
  WriteLn(Stream, '<<');
  WriteLn(Stream, '/Producer (' + PTool.PrepareString(FCreator) + ')');
  WriteLn(Stream, '/Author (' + PTool.PrepareString(FAuthor) + ')');
  WriteLn(Stream, '/Subject (' + PTool.PrepareString(FSubject) + ')');
  WriteLn(Stream, '/Creator (' + PTool.PrepareString(Application.Name) + ')');
  WriteLn(Stream, '/Title (' + PTool.PrepareString(FTitle) + ')');
  WriteLn(Stream, '/CreationDate (D:' + s + ')');
  WriteLn(Stream, '/ModDate (D:' + s + ')');
  WriteLn(Stream, '>>');
  WriteLn(Stream, 'endobj');
  if FOutline then
  begin
    XRefAdd(Stream);
    WriteLn(Stream, IntToStr(FCounter) + ' 0 obj');
    Parent := FCounter;
    Inc(FCounter);
    FPreviewOutline.LevelRoot;
    WriteLn(Stream, '<<');
    WriteLn(Stream, '/Count ' + IntToStr(FPreviewOutline.Count));
    WriteLn(Stream, '/First ' + IntToStr(FCounter) + ' 0 R');
    WriteLn(Stream, '/Last ' + IntToStr(FCounter + OutlineCount - 1) + ' 0 R');
    WriteLn(Stream, '>>');
    WriteLn(Stream, 'endobj');
    DoWriteOutline(OutlineTree, Parent);
    OutlineTree.Free;
  end;
  XRefAdd(Stream);
  WriteLn(Stream, IntToStr(FCounter) + ' 0 obj');
  Inc(FCounter);
  WriteLn(Stream, '<<');
  WriteLn(Stream, '/Type /Pages');
  FStartFonts := FCounter - 1;
  FStartPages := FCounter + FFonts.Count * FFontDCnt - 1;
  Write(Stream, '/Kids [');
  for i := 0 to FPages.Count - 1 do
    Write(Stream, IntToStr(FStartPages + i * 2 + 1) + ' 0 R ');
  WriteLn(Stream, ']');
  WriteLn(Stream, '/Count ' + IntToStr(FPages.Count));
  WriteLn(Stream, '>>');
  WriteLn(Stream, 'endobj');
  for i := 0 to FFonts.Count - 1 do
    TfrxPDFFont(FFonts[i]).SaveToStream(Stream);
  for i := 0 to FPages.Count - 1 do
    TfrxPDFPage(FPages[i]).SaveToStream(Stream);
  FStartXRef := Stream.Position;
  WriteLn(Stream, 'xref');
  WriteLn(Stream, '0 ' + IntToStr(FXRef.Count + 1));
  WriteLn(Stream, '0000000000 65535 f');
  for i := 0 to FXRef.Count - 1 do
    WriteLn(Stream, FXRef[i] + ' 00000 n');
  WriteLn(Stream, 'trailer');
  WriteLn(Stream, '<<');
  WriteLn(Stream, '/Size ' + IntToStr(FXref.Count + 1));
  WriteLn(Stream, '/Root 1 0 R');
  WriteLn(Stream, '/Info 2 0 R');
  WriteLn(Stream, '>>');
  WriteLn(Stream, 'startxref');
  WriteLn(Stream, IntToStr(FStartXRef));
  WriteLn(Stream, '%%EOF');
end;

procedure TfrxPDFFile.XRefAdd(Stream: TStream);
begin
  FXRef.Add(StringOfChar('0',  10 - Length(IntToStr(Stream.Position))) + IntToStr(Stream.Position));
end;

function TfrxPDFFile.AddFont(Font: TFont): Integer;
var
  Font2: TfrxPDFFont;
  i, j: Integer;
begin
  j := -1;
  for i := 0 to FFonts.Count - 1 do
  begin
    Font2 := TfrxPDFFont(FFonts[i]);
    if (Font2.Font.Name = Font.Name) and
       (Font2.Font.Style = Font.Style) and
       (Font2.Font.Charset = Font.Charset) then
    begin
      j := i;
      break;
    end;
  end;
  if j = -1 then
  begin
    Font2 := TfrxPDFFont.Create;
    Font2.Parent := Self;
    Font2.Font.Assign(Font);
    FFonts.Add(Font2);
    j := FFonts.Count - 1;
    Font2.Index := j * FFontDCnt + 1
  end;
  Result := j;
end;

function TfrxPDFFile.AddPage(Page: TfrxReportPage): TfrxPDFPage;
var
  PDFPage: TfrxPDFPage;
begin
  PDFPage := TfrxPDFPage.Create;
  PDFPage.Width := Page.Width * PDF_DIVIDER;
  PDFPage.Height := Page.Height * PDF_DIVIDER;
  PDFPage.MarginLeft := Page.LeftMargin * PDF_MARG_DIVIDER;
  PDFPAge.MarginTop := Page.TopMargin * PDF_MARG_DIVIDER;
  PDFPage.Parent := Self;
  FPages.Add(PDFPage);
  PDFPage.Index := FPages.Count;
  Result := PDFPage;
  if FEmbedded then
    FFontDCnt := 3
  else FFontDCnt := 2;
end;

{ TfrxPDFPage }

constructor TfrxPDFPage.Create;
begin
  FStreamObjects := TMemoryStream.Create;
  FMarginLeft := 0;
  FMarginTop := 0;
end;

destructor TfrxPDFPage.Destroy;
begin
  FStreamObjects.Free;
  inherited;
end;

procedure TfrxPDFPage.Clear;
begin
  FStreamObjects.Clear;
end;

procedure TfrxPDFPage.SaveToStream(Stream: TStream);
var
  i: Integer;
  OldSep: Char;
  s: String;
  TmpPageStream: TMemoryStream;
begin
  inherited SaveToStream(Stream);
  Parent.XRefAdd(Stream);
  OldSep := DecimalSeparator;
  DecimalSeparator := '.';
  WriteLn(Stream, IntToStr((Index * 2) - 1 + Parent.FStartPages) + ' 0 obj');
  WriteLn(Stream, '<<');
  WriteLn(Stream, '/Type /Page');
  WriteLn(Stream, '/Parent ' + IntToStr(Parent.FPagesRoot) + ' 0 R');
  WriteLn(Stream, '/MediaBox [0 0 ' + Format('%.4f', [FWidth]) + ' ' + Format('%.4f', [FHeight]) + ' ]');
  WriteLn(Stream, '/Resources <<');
  WriteLn(Stream, '/Font <<');
  for i := 0 to Parent.FFonts.Count - 1 do
    WriteLn(Stream, '/F' + IntToStr(TfrxPDFFont(Parent.FFonts[i]).Index - 1) + ' ' + IntToStr(i * Parent.FFontDCnt + 1 + Parent.FStartFonts) + ' 0 R');
  WriteLn(Stream, '>>');
  WriteLn(Stream, '/XObject <<');
  WriteLn(Stream, '>>');
  WriteLn(Stream, '/ProcSet [/PDF /Text /ImageC ]');
  WriteLn(Stream, '>>');
  WriteLn(Stream, '/Contents ' + IntToStr((Index * 2) - 1 + Parent.FStartPages + 1) + ' 0 R');
  WriteLn(Stream, '>>');
  WriteLn(Stream, 'endobj');
  Parent.XRefAdd(Stream);
  WriteLn(Stream, IntToStr((Index * 2) - 1 + Parent.FStartPages + 1) + ' 0 obj');
  Write(Stream, '<< ');
  TmpPageStream := TMemoryStream.Create;
  try
    if Parent.FCompressed then
    begin
      frxDeflateStream(FStreamObjects, TmpPageStream, gzMax);
      s := '/Filter /FlateDecode /Length ' + IntToStr(TmpPageStream.Size) + ' /Length1 ' + IntToStr(FStreamObjects.Size)
    end
    else s := '/Length ' + IntToStr(FStreamObjects.Size);
    WriteLn(Stream, s + ' >>');
    WriteLn(Stream, 'stream');
    if Parent.FCompressed then
    begin
      Stream.CopyFrom(TmpPageStream, 0);
      WriteLn(Stream, '');
    end
    else
      Stream.CopyFrom(FStreamObjects, 0);
  finally
    TmpPageStream.Free;
  end;
  WriteLn(Stream, 'endstream');
  WriteLn(Stream, 'endobj');
  DecimalSeparator := OldSep;
end;

procedure TfrxPDFPage.AddObject(Obj: TfrxView);
var
  FontIndex: Integer;
  x, y: Extended;
  i: Integer;

  Jpg: TJPEGImage;

  s: String;
  Lines: TStrings;
  OldSep: Char;
  TempBitmap: TBitmap;
  OldFrameWidth: Extended;

  procedure MakeUpFrames;
  begin
    if (Obj.Frame.Typ <> []) and (Obj.Frame.Color <> clNone) then
    begin
      WriteLn(FStreamObjects, Parent.PTool.GetPDFColor(Obj.Frame.Color) + ' RG');
      WriteLn(FStreamObjects, Format('%.4f', [Obj.Frame.Width * PDF_DIVIDER]) + ' w');
      if ftTop in Obj.Frame.Typ then
      begin
        WriteLn(FStreamObjects, Format('%.4f', [GetLeft(Obj.AbsLeft)]) + ' ' + Format('%.4f', [GetTop(Obj.AbsTop)]) + ' m');
        WriteLn(FStreamObjects, Format('%.4f', [GetLeft(Obj.AbsLeft + Obj.Width)]) + ' ' + Format('%.4f', [GetTop(Obj.AbsTop)]) + ' l');
        WriteLn(FStreamObjects, 'S')
      end;
      if ftLeft in Obj.Frame.Typ then
      begin
        WriteLn(FStreamObjects, Format('%.4f', [GetLeft(Obj.AbsLeft)]) + ' ' + Format('%.4f', [GetTop(Obj.AbsTop)]) + ' m');
        WriteLn(FStreamObjects, Format('%.4f', [GetLeft(Obj.AbsLeft)]) + ' ' + Format('%.4f', [GetTop(Obj.AbsTop + Obj.Height)]) + ' l');
        WriteLn(FStreamObjects, 'S')
      end;
      if ftBottom in Obj.Frame.Typ then
      begin
        WriteLn(FStreamObjects, Format('%.4f', [GetLeft(Obj.AbsLeft)]) + ' ' + Format('%.4f', [GetTop(Obj.AbsTop + Obj.Height)]) + ' m');
        WriteLn(FStreamObjects, Format('%.4f', [GetLeft(Obj.AbsLeft + Obj.Width)]) + ' ' + Format('%.4f', [GetTop(Obj.AbsTop + Obj.Height)]) + ' l');
        WriteLn(FStreamObjects, 'S')
      end;
      if ftRight in Obj.Frame.Typ then
      begin
        WriteLn(FStreamObjects, Format('%.4f', [GetLeft(Obj.AbsLeft + Obj.Width)]) + ' ' + Format('%.4f', [GetTop(Obj.AbsTop)]) + ' m');
        WriteLn(FStreamObjects, Format('%.4f', [GetLeft(Obj.AbsLeft + Obj.Width)]) + ' ' + Format('%.4f', [GetTop(Obj.AbsTop + Obj.Height)]) + ' l');
        WriteLn(FStreamObjects, 'S')
      end;
    end;
  end;

  function HTMLTags(View: TfrxCustomMemoView): Boolean;
  var
    f: Boolean;
  begin
    f := View.AllowHTMLTags;
    View.AllowHTMLTags := True;
    Result := FParent.HTMLTags and
      (Pos('<' ,View.Memo.Text) > 0) and
      (Pos('>' ,View.Memo.Text) > 0);
    View.AllowHTMLTags := f;
  end;

begin
  OldSep := DecimalSeparator;
  OldFrameWidth := 0;
  DecimalSeparator := '.';
  // Text
  if (Obj is TfrxCustomMemoView) and (TfrxCustomMemoView(Obj).Rotation = 0) and
     (TfrxCustomMemoView(Obj).BrushStyle in [bsSolid, bsClear]) and
     (not HTMLTags(TfrxCustomMemoView(Obj))) then
  begin
    if Obj.Frame.DropShadow then
    begin
      Obj.Width := Obj.Width - Obj.Frame.ShadowWidth;
      Obj.Height := Obj.Height - Obj.Frame.ShadowWidth;
      WriteLn(FStreamObjects, Parent.PTool.GetPDFColor(Obj.Frame.ShadowColor) + ' rg');
      WriteLn(FStreamObjects, Parent.PTool.GetPDFColor(Obj.Frame.ShadowColor) + ' RG');
      Write(FStreamObjects, Format('%.4f', [GetLeft(Obj.AbsLeft + Obj.Width)]) + ' ' + Format('%.4f', [GetTop(Obj.AbsTop + Obj.Height + Obj.Frame.ShadowWidth)]) + ' ');
      WriteLn(FStreamObjects, Format('%.4f', [Obj.Frame.ShadowWidth * PDF_DIVIDER]) + ' ' + Format('%.4f', [Obj.Height * PDF_DIVIDER]) + ' re');
      WriteLn(FStreamObjects, 'B');
      Write(FStreamObjects, Format('%.4f', [GetLeft(Obj.AbsLeft + Obj.Frame.ShadowWidth)]) + ' ' + Format('%.4f', [GetTop(Obj.AbsTop + Obj.Height + Obj.Frame.ShadowWidth)]) + ' ');
      WriteLn(FStreamObjects, Format('%.4f', [Obj.Width * PDF_DIVIDER]) + ' ' + Format('%.4f', [Obj.Frame.ShadowWidth * PDF_DIVIDER]) + ' re');
      WriteLn(FStreamObjects, 'B');
    end;
    if TfrxCustomMemoView(Obj).Highlight.Active and
       Assigned(TfrxCustomMemoView(Obj).Highlight.Font) then
    begin
      Obj.Font.Assign(TfrxCustomMemoView(Obj).Highlight.Font);
      Obj.Color := TfrxCustomMemoView(Obj).Highlight.Color;
    end;
    if Obj.Color <> clNone then
    begin
      WriteLn(FStreamObjects, Parent.PTool.GetPDFColor(Obj.Color) + ' rg');
      Write(FStreamObjects, Format('%.4f', [GetLeft(Obj.AbsLeft)]) + ' ' + Format('%.4f', [GetTop(Obj.AbsTop + Obj.Height)]) + ' ');
      WriteLn(FStreamObjects, Format('%.4f', [Obj.Width * PDF_DIVIDER]) + ' ' + Format('%.4f', [Obj.Height * PDF_DIVIDER]) + ' re');
      WriteLn(FStreamObjects, 'f');
    end;
    MakeUpFrames;
    Lines := TStringList.Create;
    Lines.Text := TfrxCustomMemoView(Obj).WrapText(True);
    if Lines.Count > 0 then
    begin
      FontIndex := Parent.AddFont(Obj.Font);
      WriteLn(FStreamObjects, '/F' + IntToStr(TfrxPDFFont(Parent.FFonts[FontIndex]).Index - 1) + ' ' + IntToStr(Obj.Font.Size) + ' Tf');
      WriteLn(FStreamObjects, Parent.PTool.GetPDFColor(Obj.Font.Color) + ' rg');
      Parent.PTool.SetMemo(TfrxCustomMemoView(Obj));