pdfdoc.pas

作者:Takeshi Kanno. PowerPdf是一款制作PDF文档的VCL控件。使用上和QuickReport类似。

  OldLastEntry := TPdfOutlineEntry(AParent.ValueByName('Last'));
  if OldLastEntry <> nil then
  begin
    AEntry.AddItem('Prev', OldLastEntry);
    OldLastEntry.AddItem('Next', AEntry);
  end
  else
    AParent.AddItem('First', AEntry);
  AParent.AddItem('Last', AEntry);

  IncCount(AParent);

  AEntry.AddItem('Parent', AParent);
  AEntry.AddInternalItem('Opened', TPdfNumber.CreateNumber(AOpened));
end;

function _OutlineEntry_Create(AParent: TPdfDictionary; ATitle: string;
  ADest: TPdfDictionary; AXPos, AYPos: Single; AOpened: integer): TPdfOutlineEntry;
var
  FEntry: TPdfOutlineEntry;
  FDest: TPdfArray;
begin
  FEntry := TPdfOutlineEntry.CreateDictionary(AParent.ObjectMgr);
  FEntry.ObjectMgr.AddObject(FEntry);
  With FEntry do
  begin
    AddItem('Title', TPdfText.CreateText(ATitle));
    FDest := TPdfArray.CreateArray(FEntry.ObjectMgr);
    with FDest do
    begin
      AddItem(ADest);
      AddItem(TPdfName.CreateName('XYZ'));
      AddItem(TPdfReal.CreateReal(AXPos));
      AddItem(TPdfReal.CreateReal(AYPos));
      AddItem(TPdfNumber.CreateNumber(0));
    end;
    AddItem('Dest', FDest);
    _OutlineEntry_AddChild(AParent, FEntry, AOpened);
  end;
  result := FEntry;
end;

function FloatToStrR(Value: Extended): string;
begin
  result := FloatToStr(Trunc(Value * 100 + 0.5) / 100);
end;

{ TPdfHeader }

procedure TPdfHeader.WriteToStream(const AStream: TStream);
begin
  _WriteString('%PDF-1.2 '#13#10, AStream);
end;

{ TPdfTrailer }

procedure TPdfTrailer.WriteToStream(const AStream: TStream);
begin
  _WriteString('trailer' + CRLF, AStream);
  FAttributes.WriteToStream(AStream);
  _WriteString(CRLF + 'startxref' + CRLF, AStream);
  _WriteString(IntToStr(FXrefAddress) + CRLF, AStream);
  _WriteString('%%EOF' + CRLF, AStream);
end;

constructor TPdfTrailer.Create(AObjectMgr: TPdfObjectMgr);
begin
  inherited Create;
  FAttributes := TPdfDictionary.CreateDictionary(AObjectMgr);
  FAttributes.AddItem('Size', TPdfNumber.CreateNumber(0));
end;

destructor TPdfTrailer.Destroy;
begin
  FAttributes.Free;
end;

{ TPdfXrefEntry }

constructor TPdfXrefEntry.Create(AValue: TPdfObject);
begin
  FByteOffset := -1;
  if AValue <> nil then
  begin
    FEntryType := PDF_IN_USE_ENTRY;
    FGenerationNumber := AValue.GenerationNumber;
    FValue := AValue;
  end
  else
  begin
    FEntryType := PDF_FREE_ENTRY;
    FGenerationNumber := 0;
  end;
end;

destructor TPdfXrefEntry.Destroy;
begin
  if FEntryType = PDF_IN_USE_ENTRY then
    FValue.Free;
end;

function TPdfXrefEntry.GetAsString: string;
  function FormatIntToString(Value: integer; Len: integer): string;
  var
    S: string;
    i, j: integer;
  begin
    result := '';
    if Value < 0 then
      S := '0'
    else
      S := IntToStr(Value);
    i := Len - Length(S);
    for j := 0 to i - 1 do
      result := result + '0';
    result := result + S;
  end;
begin
  result := FormatIntToString(FByteOffset, 10) +
            ' ' +
            FormatIntToString(FGenerationNumber, 5) +
            ' ' +
            FEntryType;
end;

{ TPdfXref }

constructor TPdfXref.Create;
var
  RootEntry: TPdfXrefEntry;
begin
  FXrefEntries := TList.Create;
  RootEntry := TPdfXrefEntry.Create(nil);
  RootEntry.GenerationNumber := PDF_MAX_GENERATION_NUM;
  FXrefEntries.Add(RootEntry);
end;

destructor TPdfXref.Destroy;
var
  i: integer;
begin
  for i := 1 to FXrefEntries.Count - 1 do
    GetItem(i).Free;
  FXrefEntries.Free;
  inherited;
end;

procedure TPdfXref.AddObject(AObject: TPdfObject);
var
  ObjectNumber: integer;
  XrefEntry: TPdfXrefEntry;
begin
  // register object to xref table, and set objectnumber.
  if AObject.ObjectType <> otDirectObject then
    raise EPdfInvalidOperation.Create('');
  XrefEntry := TPdfXrefEntry.Create(AObject);
  ObjectNumber := FXrefEntries.Add(XrefEntry);
  AObject.SetObjectNumber(ObjectNumber);
end;

function TPdfXref.GetItem(ObjectID: integer): TPdfXrefEntry;
begin
  result := TPdfXrefEntry(FXrefEntries.Items[ObjectID]);
end;

function TPdfXref.GetItemCount: integer;
begin
  Result := FXrefEntries.Count;
end;

function TPdfXref.GetObject(ObjectID: integer): TPdfObject;
begin
  result := GetItem(ObjectID).Value;
end;

procedure TPdfXref.WriteToStream(const AStream: TStream);
var
  i: integer;
  S: string;
  Count: integer;
begin
  Count := FXrefEntries.Count;
  S := 'xref' +
       CRLF +
       '0 ' +
       IntToStr(Count) +
       CRLF;
  for i := 0 to Count - 1 do
    S := S + Items[i].AsString + CRLF;
  _WriteString(S, AStream);
end;

{ TPdfDoc }
constructor TPdfDoc.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHasDoc := false;
  FCanvas := TPdfCanvas.Create(Self);
  FDefaultPageWidth := PDF_DEFAULT_PAGE_WIDTH;
  FDefaultPageHeight := PDF_DEFAULT_PAGE_HEIGHT;
  FInfo := nil;
  FRoot := nil;
end;

function TPdfDoc.GetCanvas: TPdfCanvas;
begin
  if not HasDoc then
    raise EPdfInvalidOperation.Create('Document is null');
  result := FCanvas;
end;

function TPdfDoc.GetInfo: TPdfInfo;
begin
  if not HasDoc then
    raise EPdfInvalidOperation.Create('this method can not use this state..');
  if FInfo = nil then
    CreateInfo;
  result := FInfo;
end;

function TPdfDoc.GetRoot: TPdfCatalog;
begin
  if not HasDoc then
    raise EPdfInvalidOperation.Create('this method can not use this state..');
  result := FRoot;
end;

destructor TPdfDoc.Destroy;
begin
  FreeDoc;
  FCanvas.Free;
  inherited;
end;

function TPdfDoc.CreateCatalog: TPdfDictionary;
begin
  // create catalog object and register to xref.
  result := TPdfDictionary.CreateDictionary(FXref);
  FXref.AddObject(result);
  result.AddItem('Type', TPdfName.CreateName('Catalog'));
  FTrailer.Attributes.AddItem('Root', result);
end;

function TPdfDoc.CreateFont(FontName: string): TPdfFont;
var
  PdfFont: TPdfFont;
begin
  // create new font (not regist to xref -- because font object registed by
  // TPdfFont).
  PdfFont := TPdfFont(FindClass(FontName).Create);
  if PdfFont = nil then
    raise Exception.Create('InvalidFontName:' + FontName);
  result := PdfFont.Create(FXref, FontName);
  result.Data.AddItem('Name',
    TPdfName.CreateName('F' + IntToStr(FFontList.Count)));
  FFontList.Add(Result);
end;

procedure TPdfDoc.RegisterXObject(AObject: TPdfXObject; AName: string);
begin
   // check object and register it.
   if AObject = nil then
     raise EPdfInvalidValue.Create('Error AObject is null');
   if _GetTypeOf(AObject.Attributes) <> 'XObject' then
     raise EPdfInvalidValue.Create('Error AObject is null');
   if AObject.ObjectType <> otIndirectObject then
     FXref.AddObject(AObject);
   if AObject.Attributes.ValueByName('Name') = nil then
   begin
     if GetXObject(AName) <> nil then
       raise EPdfInvalidValue.Createfmt('dupulicate name: %s', [AName]);
     FXObjectList.AddItem(AObject);
     AObject.Attributes.AddItem('Name', TPdfName.CreateName(AName));
   end;
end;

procedure TPdfDoc.CreateInfo;
var
  FInfoDictionary: TPdfDictionary;
begin
  FInfoDictionary := TPdfDictionary.CreateDictionary(FXref);
  FXref.AddObject(FInfoDictionary);
  FInfoDictionary.AddItem('Producer', TPdfText.CreateText(POWER_PDF_VERSION_TEXT));
  FTrailer.Attributes.AddItem('Info', FInfoDictionary);
  FInfo := TPdfInfo.Create;
  FInfo.SetData(FInfoDictionary);
end;

function TPdfDoc.CreatePages(Parent: TPdfDictionary): TPdfDictionary;
begin
  // create pages object and register to xref.
  result := TPdfDictionary.CreateDictionary(FXref);
  FXref.AddObject(result);
  with result do
  begin
    AddItem('Type', TPdfName.CreateName('Pages'));
    AddItem('Kids', TPdfArray.CreateArray(FXref));
    AddItem('Count', TPdfNumber.CreateNumber(0));
  end;

  if (Parent <> nil) and (_GetTypeOf(Parent) = 'Pages') then
    _Pages_AddKids(Parent, result)
  else
    FRoot.Pages := result;
end;

function TPdfDoc.GetFont(FontName: string): TPdfFont;
var
  FFont: TPdfFont;
  i :integer;
begin
  if not HasDoc then
    raise EPdfInvalidOperation.Create('document is null.');
    
  // if specified font exists in fontlist, return it. otherwise, create the font.
  result := nil;
  for i := 0 to FFontList.Count - 1 do
  begin
    FFont := TPdfFont(FFontList.Items[i]);
    if FFont.Name = FontName then
    begin
      result := FFont;
      Break;
    end;
  end;
  if result = nil then
    result := CreateFont(FontName);
end;

function TPdfDoc.GetXObject(AName: string): TPdfXObject;
var
  FXObject: TPdfXObject;
  i :integer;
begin
  // return the XObject which name is muched with specified name.
  result := nil;
  for i := 0 to FXObjectList.ItemCount - 1 do
  begin
    FXObject := TPdfXObject(FXObjectList.Items[i]);
    if TPdfName(FXObject.Attributes.ValueByName('Name')).Value = AName then
    begin
      result := FXObject;
      Break;
    end;
  end;
end;

function TPdfDoc.AddOutlineEntry(AParent: TPdfOutlineEntry; ATitle: string;
  AXPos, AYPos: Single; AOpened: boolean): TPdfOutlineEntry;
var
  FParent: TPdfDictionary;
  FOpened: integer;
begin
  if not HasDoc then
    raise EPdfInvalidOperation.Create('document is null.');
  FParent := AParent;
  if not Root.UseOutlines then
    Root.UseOutlines := true;
  if FParent = nil then
    FParent := Root.Outlines;
  if AOpened then
    FOpened := PDF_ENTRY_OPENED
  else
    FOpened := PDF_ENTRY_CLOSED;
  result := _OutlineEntry_Create(FParent, ATitle, FCanvas.Page, AXPos,
    AYPos, FOpened);
end;

procedure TPdfDoc.NewDoc;
begin
  {*
   * create new document.
   *}
  FreeDoc;
  FHeader := TPdfHeader.Create;
  FTrailer := TPdfTrailer.Create(FXref);
  FXref := TPdfXref.Create;
  FFontList := TList.Create;
  FXObjectList := TPdfArray.CreateArray(FXref);

  FRoot := TPdfCatalog.Create;
  FRoot.SetData(CreateCatalog);
  FRoot.UseOutlines := true;

  CreateInfo;
  FInfo.CreationDate := now;

  FCurrentPages := CreatePages(nil);
  FRoot.SetPages(FCurrentPages);

  FHasDoc := true;
end;

{$IFNDEF NOIMAGE}
procedure TPdfDoc.AddImage(AName: string; AImage: TGraphic; ImageClassName: string);
var
  FXObject: TPdfXObject;
  PdfImageCreator: TPdfImageCreator;
begin
  if GetXObject(AName) <> nil then
    raise Exception.CreateFmt('the image named %s is already exists..', [AName]);

  // create new image and regist to XObject table and Xref.
  PdfImageCreator := TPdfImageCreator(FindClass(ImageClassName).Create);
  try
    if PdfImageCreator = nil then
      raise Exception.Create('InvalidImageClassName:' + ImageClassName);
    FXObject := PdfImageCreator.CreateImage(FXref, AImage);
    FXref.AddObject(FXObject);
    RegisterXObject(FXObject, AName);
  finally
    PdfImageCreator.Free;
  end;
end;
{$ENDIF}

procedure TPdfDoc.AddPage;
var
  FPage: TPdfDictionary;
  FMediaBox: TPdfArray;
  FContents: TPdfStream;
  FResources: TPdfDictionary;
  FProcSet: TPdfArray;
  FFontArray: TPdfDictionary;
  FXObjectArray: TPdfDictionary;
  {$IFNDEF NOZLIB}
  FFilter: TPdfArray;
  {$ENDIF}
begin
  if FCurrentPages = nil then
    raise EPdfInvalidOperation.Create('internal error. current pages null.');

  // create new page object and add it to the current pages object.
  FPage := TPdfDictionary.CreateDictionary(FXref);
  FXref.AddObject(FPage);

  _Pages_AddKids(FCurrentPages, FPage);

  FPage.AddItem('Type', TPdfName.CreateName('Page'));
  FPage.AddItem('Parent', FCurrentPages);

  FMediaBox := TPdfArray.CreateArray(FXref);
  with FMediabox do
  begin
    AddItem(TPdfNumber.CreateNumber(0));
    AddItem(TPdfNumber.CreateNumber(0));
    AddItem(TPdfNumber.CreateNumber(DefaultPageWidth));
    AddItem(TPdfNumber.CreateNumber(DefaultPageHeight));
  end;
  FPage.AddItem('MediaBox', FMediaBox);

  FResources := TPdfDictionary.CreateDictionary(FXref);
  FPage.AddItem('Resources', FResources);

  FFontArray := TPdfDictionary.CreateDictionary(FXref);
  FResources.AddItem('Font', FFontArray);

  FXObjectArray := TPdfDictionary.CreateDictionary(FXref);
  FResources.AddItem('XObject', FXObjectArray);