pdfdoc.pas

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

  FProcSet := TPdfArray.CreateArray(FXref);
  with FProcSet do
  begin
    AddItem(TPdfName.CreateName('PDF'));
    AddItem(TPdfName.CreateName('Text'));
    AddItem(TPdfName.CreateName('ImageC'));
  end;
  FResources.AddItem('ProcSet', FProcSet);

  FContents := TPdfStream.CreateStream(FXref);
  FXref.AddObject(FContents);
  {$IFNDEF NOZLIB}
  FFilter := FContents.Attributes.PdfArrayByName('Filter');
  if FCompressionMethod = cmFlateDecode then
    FFilter.AddItem(TPdfName.CreateName('FlateDecode'));
  {$ENDIF}
  FPage.AddItem('Contents', FContents);

  FCanvas.SetPage(FPage);
end;

procedure TPdfDoc.FreeDoc;
var
  i: integer;
begin
  if FHasDoc then
  begin
    FXObjectList.Free;
    for i := FFontList.Count - 1 downto 0 do
      TObject(FFontList.Items[i]).Free;
    FFontList.Free;
    FXref.Free;
    FHeader.Free;
    FTrailer.Free;
    FHasDoc := false;
    if FInfo <> nil then
      FInfo.Free;
    FInfo := nil;
    FRoot.Free;
  end;
end;

procedure TPdfDoc.SaveToStream(AStream: TStream);
var
  i: integer;
  Pos: integer;
  PdfNumber: TPdfNumber;
begin
  if not HasDoc then
    raise EPdfInvalidOperation.Create('there is no document to save.');
  // write all objects to specified stream.
  FInfo.ModDate := Now;

  AStream.Position := 0;
  FHeader.WriteToStream(AStream);
  for i := 1 to FXref.ItemCount - 1 do
  begin
    Pos := AStream.Position;
    FXref.Items[i].Value.WriteValueToStream(AStream);
    FXref.Items[i].ByteOffset := Pos;
  end;
  FTrailer.XrefAddress := AStream.Position;
  FXref.WriteToStream(AStream);
  PdfNumber := FTrailer.Attributes.PdfNumberByName('Size');
  PdfNumber.Value := FXref.ItemCount;
  FTrailer.WriteToStream(AStream);
end;

{ TPdfCanvasAttribute }
procedure TPdfCanvasAttribute.SetFont(Value: TPdfFont);
begin
  if FFont <> Value then
    FFont := Value;
end;

procedure TPdfCanvasAttribute.SetWordSpace(Value: Single);
begin
  if Value < 0 then
    raise EPdfInvalidValue.Create('invalid word space');
  if Value <> FWordSpace then
    FWordSpace := Value;
end;

procedure TPdfCanvasAttribute.SetCharSpace(Value: Single);
begin
  if Value <> FCharSpace then
    FCharSpace := Value;
end;

procedure TPdfCanvasAttribute.SetFontSize(Value: Single);
begin
  if Value < 0 then
    raise EPdfInvalidValue.Create('invalid font size');
  if Value <> FFontSize then
    FFontSize := Value;
end;

procedure TPdfCanvasAttribute.SetHorizontalScaling(Value: Word);
begin
  if Value > PDF_MAX_HORIZONTALSCALING then
    raise EPdfInvalidValue.Create('invalid font size');
  if Value <> FHorizontalScaling then
    FHorizontalScaling := Value;
end;

function TPdfCanvasAttribute.TextWidth(Text: string): Single;
var
  i: integer;
  ch: char;
  tmpWidth: Single;
begin
  result := 0;

  // calculate width of specified text from current attributes
  for i := 1 to Length(Text) do
  begin
    ch := Text[i];
    tmpWidth := FFont.GetCharWidth(Text, i) * FFontSize / 1000;
    if FHorizontalScaling <> 100 then
      tmpWidth := tmpWidth * FHorizontalScaling / 100;
    if tmpWidth > 0 then
      tmpWidth := tmpWidth + FCharSpace
    else
      tmpWidth := 0;
    if (ch = ' ') and (FWordSpace > 0) and (i <> Length(Text)) then
      tmpWidth := tmpWidth + FWordSpace;

    result := result + tmpWidth;
  end;
  result := result - FCharSpace;
end;

function TPdfCanvasAttribute.MesureText(Text: string; Width: Single): integer;
var
  i: integer;
  ch: char;
  tmpWidth: Single;
  tmpTotalWidth: Single;
begin
  result := 0;
  tmpTotalWidth := 0;

  // calculate number of charactor contain in thw specified width.
  for i := 1 to Length(Text) do
  begin
    ch := Text[i];
    tmpWidth := FFont.GetCharWidth(Text, i) * FFontSize / 1000;
    if FHorizontalScaling <> 100 then
      tmpWidth := tmpWidth * FHorizontalScaling / 100;
    if tmpWidth > 0 then
      tmpWidth := tmpWidth + FCharSpace
    else
      tmpWidth := 0;
    if (ch = ' ') and (FWordSpace > 0) and (i <> Length(Text)) then
      tmpWidth := tmpWidth + FWordSpace;

    tmpTotalWidth := tmpTotalWidth + tmpWidth;
    if tmpTotalWidth > Width then
      Break;
    inc(result);
  end;
end;

{ TPdfCanvas }

constructor TPdfCanvas.Create(APdfDoc: TPdfDoc);
begin
  FPdfDoc := APdfDoc;
  FPage := nil;
  FContents := nil;
  FAttr := TPdfCanvasAttribute.Create;
end;

destructor TPdfCanvas.Destroy;
begin
  FAttr.Free;
  inherited;
end;

procedure TPdfCanvas.SetPageWidth(AValue: integer);
var
  FMediaBox: TPdfArray;
begin
  FMediaBox := TPdfArray(FPage.ValueByName('MediaBox'));
  if FMediaBox <> nil then
    TPdfNumber(FMediaBox.Items[2]).Value := AValue
  else
    EPdfInvalidOperation.Create('Can not chenge width of this page..');
end;

procedure TPdfCanvas.SetPageHeight(AValue: integer);
var
  FMediaBox: TPdfArray;
begin
  FMediaBox := TPdfArray(FPage.ValueByName('MediaBox'));
  if FMediaBox <> nil then
    TPdfNumber(FMediaBox.Items[3]).Value := AValue
  else
    EPdfInvalidOperation.Create('Can not chenge width of this page..');
end;

function TPdfCanvas.GetPageWidth: Integer;
var
  FMediaBox: TPdfArray;
begin
  FMediaBox := TPdfArray(FPage.ValueByName('MediaBox'));
  if FMediaBox <> nil then
    result := TPdfNumber(FMediaBox.Items[2]).Value
  else
    result := FPdfDoc.DefaultPageWidth;
end;

function TPdfCanvas.GetPageHeight: Integer;
var
  FMediaBox: TPdfArray;
begin
  FMediaBox := TPdfArray(FPage.ValueByName('MediaBox'));
  if FMediaBox <> nil then
    result := TPdfNumber(FMediaBox.Items[3]).Value
  else
    result := FPdfDoc.DefaultPageHeight;
end;

function TPDFCanvas.GetColorStr(Color: TColor): string;
var
  X: array[0..3] of Byte;
  i: integer;
begin
  i := ColorToRGB(Color);
  Move(i, x[0], 4);
  result := FloatToStrR(X[0] / 255) + ' ' +
            FloatToStrR(X[1] / 255) + ' ' +
            FloatToStrR(X[2] / 255);
end;

procedure TPdfCanvas.SetPage(APage: TPdfDictionary);
  procedure GetCurrentFont;
  var
    AFont: TPdfName;
  begin
    AFont := FPage.PdfNameByName('_Font');
    if AFont <> nil then
    begin
      FAttr.Font := FPdfDoc.GetFont(AFont.Value);
      FAttr.FontSize := FPage.PdfNumberByName('_Font_Size').Value;
      FAttr.WordSpace := FPage.PdfRealByName('_Word_Space').Value;
      FAttr.CharSpace := FPage.PdfRealByName('_Char_Space').Value;
      FAttr.HorizontalScaling := FPage.PdfNumberByName('_HScalling').Value;
    end
    else
    begin
      SetFont(PDF_DEFAULT_FONT, PDF_DEFAULT_FONT_SIZE);
      FAttr.CharSpace := 0;
      FAttr.WordSpace := 0;
      FAttr.HorizontalScaling := 100;
    end;
  end;
begin
  // save current canvas attributes to internal objects.
  if FPage <> nil then
  begin
    FPage.AddInternalItem('_Font', TPdfName.CreateName(FAttr.Font.Name));
    FPage.AddInternalItem('_Font_Size', TPdfReal.CreateReal(FAttr.FontSize));
    FPage.AddInternalItem('_Word_Space', TPdfReal.CreateReal(FAttr.WordSpace));
    FPage.AddInternalItem('_Char_Space', TPdfReal.CreateReal(FAttr.CharSpace));
    FPage.AddInternalItem('_HScalling', TPdfNumber.CreateNumber(FAttr.HorizontalScaling));
  end;
  FPage := APage;
  FContents := TPdfStream(FPage.ValueByName('Contents'));
  GetCurrentFont;
end;

procedure TPdfCanvas.SetFont(AName: string; ASize: Single);
var
  FFont: TPdfFont;
  FFontList: TPdfDictionary;
  FFontName: string;
begin
  // get font object from pdfdoc object, then find fontlist from page object
  // by internal name. if font is not registered, register it to page object.
  FFont := FPdfDoc.GetFont(AName);
  if (FAttr.Font = FFont) and (FAttr.FontSize = ASize) then Exit;
  FFontList := _Page_GetResources(FPage, 'Font');
  FFontName := FFont.Data.PdfNameByName('Name').Value;
  if FFontList.ValueByName(FFontName) = nil then
    FFontList.AddItem(FFontName, FFont.Data);
  if FContents <> nil then
    SetFontAndSize('/' + FFontName, ASize);
  FAttr.Font := FFont;
  FAttr.FontSize := ASize;
end;

procedure TPdfCanvas.DrawXObject(X, Y, AWidth, AHeight: Single;
   AXObjectName: string);
var
  XObject: TPdfXObject;
  FXObjectList: TPdfDictionary;
begin
  // drawing object must be registered. check object name.
  XObject := FPdfDoc.GetXObject(AXObjectName);
  if XObject = nil then
    raise EPdfInvalidValue.CreateFmt('XObject not found: %s', [AXObjectName]);

  FXObjectList := _Page_GetResources(FPage, 'XObject');
  if FXObjectList.ValueByName(AXObjectName) = nil then
    FXObjectList.AddItem(AXObjectName, XObject);

  GSave;
  Concat(AWidth, 0, 0, AHeight, X, Y);
  ExecuteXObject(XObject.Attributes.PdfNameByName('Name').Value);
  GRestore;
end;

  {* Special Graphics State *}

procedure TPdfCanvas.GSave;
begin
  _WriteString('q'#10, FContents.Stream);
end;

procedure TPdfCanvas.GRestore;
begin
  _WriteString('Q'#10, FContents.Stream);
end;

procedure TPdfCanvas.Concat(a, b, c, d, e, f: Single);
var
  S: string;
begin
  S := FloatToStr(a) + ' ' +
       FloatToStr(b) + ' ' +
       FloatToStr(c) + ' ' +
       FloatToStr(d) + ' ' +
       FloatToStr(e) + ' ' +
       FloatToStr(f) + ' cm'#10;
  _WriteString(S, FContents.Stream);
end;

  {* General Graphics State *}
procedure TPdfCanvas.SetFlat(flatness: Byte);
var
  S: string;
begin
  S := IntToStr(flatness) + ' i'#10;
  _WriteString(S, FContents.Stream);
end;

procedure TPdfCanvas.SetLineCap(linecap: TLineCapStyle);
var
  S: string;
begin
  S := IntToStr(ord(linecap)) + ' J'#10;
  _WriteString(S, FContents.Stream);
end;

procedure TPdfCanvas.SetDash(aarray: array of Byte; phase: Byte);
var
  S: string;
  i: integer;
begin
  S := '[';
  if (High(aarray) >= 0) and (aarray[0] <> 0) then   // compatibility fo delphi 3
    for i := 0 to High(aarray) do
      S := S + IntToStr(aarray[i]) + ' ';
  S := S + '] ' + IntToStr(phase) + ' d'#10;
  _WriteString(S, FContents.Stream);
end;

procedure TPdfCanvas.SetLineJoin(linejoin: TLineJoinStyle);
var
  S: string;
begin
  S := IntToStr(ord(linejoin)) + ' j'#10;
  _WriteString(S, FContents.Stream);
end;

procedure TPdfCanvas.SetLineWidth(linewidth: Single);
var
  S: string;
begin
  S := FloatToStrR(linewidth) + ' w'#10;
  _WriteString(S, FContents.Stream);
end;

procedure TPdfCanvas.SetMiterLimit(miterlimit: Byte);
var
  S: string;
begin
  S := IntToStr(miterlimit) + ' M'#10;
  _WriteString(S, FContents.Stream);
end;

  {* Paths *}
procedure TPdfCanvas.MoveTo(x, y: Word);
var
  S: string;
begin
  S := IntToStr(x) + ' ' + IntToStr(y) + ' m'#10;
  _WriteString(S, FContents.Stream);
end;

procedure TPdfCanvas.LineTo(x, y: Word);
var
  S: string;
begin
  S := IntToStr(x) + ' ' + IntToStr(y) + ' l'#10;
  _WriteString(S, FContents.Stream);
end;

procedure TPdfCanvas.CurveToC(x1, y1, x2, y2, x3, y3: Word);
var
  S: string;
begin
  S := IntToStr(x1) + ' ' +
       IntToStr(y1) + ' ' +
       IntToStr(x2) + ' ' +
       IntToStr(y2) + ' ' +
       IntToStr(x3) + ' ' +
       IntToStr(y3) + ' c'#10;
  _WriteString(S, FContents.Stream);
end;

procedure TPdfCanvas.CurveToV(x2, y2, x3, y3: Word);
var
  S: string;
begin
  S := IntToStr(x2) + ' ' +
       IntToStr(y2) + ' ' +
       IntToStr(x3) + ' ' +
       IntToStr(y3) + ' v'#10;
  _WriteString(S, FContents.Stream);
end;

procedure TPdfCanvas.CurveToY(x1, y1, x3, y3: Word);
var
  S: string;
begin
  S := IntToStr(x1) + ' ' +
       IntToStr(y1) + ' ' +
       IntToStr(x3) + ' ' +
       IntToStr(y3) + ' y'#10;
  _WriteString(S, FContents.Stream);
end;

procedure TPdfCanvas.Rectangle(x, y, width, height: Word);
var
  S: string;
begin
  S := IntToStr(x) + ' ' +
       IntToStr(y) + ' ' +
       IntToStr(width) + ' ' +
       IntToStr(height) + ' re'#10;
  _WriteString(S, FContents.Stream);
end;

procedure TPdfCanvas.Closepath;
begin
  _WriteString('h'#10, FContents.Stream);
end;