pdfdoc.pas

给PDF文件加盖印章或背景

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

// GetColorStr
function TPDFCanvas.GetColorStr(Color: TPdfColor): string;
var
  X: array[0..3] of Byte;
  rgb: integer;
begin
  if Color > 0 then
    rgb := integer(Color)
  else
    rgb := 0;
  Move(rgb, x[0], 4);
  result := _FloatToStrR(X[0] / 255) + ' ' +
            _FloatToStrR(X[1] / 255) + ' ' +
            _FloatToStrR(X[2] / 255);
end;

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

// SetFont
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;

// TextOut
procedure TPdfCanvas.TextOut(X, Y: Single; Text: string);
begin
  BeginText;
  MoveTextPoint(X, Y);
  ShowText(Text);
  EndText;
end;

// TextRect
procedure TPdfCanvas.TextRect(ARect: TPdfRect; Text: string;
                            Alignment: TPdfAlignment; Clipping: boolean);
var
  tmpWidth: Single;
  XPos: Single;
begin
  // calculate text width.
  tmpWidth := TextWidth(Text);

  case Alignment of
    paCenter: XPos := Round((ARect.Right - ARect.Left - tmpWidth) / 2);
    paRightJustify: XPos := ARect.Right - ARect.Left - Round(tmpWidth);
  else
    XPos := 0;
  end;

  // clipping client rect if needed.
  if Clipping then
  begin
    GSave;
    with ARect do
      begin
        MoveTo(Left, Top);
        LineTo(Left, Bottom);
        LineTo(Right, Bottom);
        LineTo(Right, Top);
      end;
    ClosePath;
    Clip;
    NewPath;
  end;

  BeginText;
  MoveTextPoint(ARect.Left + XPos, ARect.Top - FAttr.FontSize * 0.85);
  ShowText(Text);
  EndText;

  if Clipping then
    GRestore;
end;

// MultilineTextRect
procedure TPdfCanvas.MultilineTextRect(ARect: TPdfRect;
            Text: string; WordWrap: boolean);
var
  i: integer;
  S1, S2: string;
  XPos, YPos: Single;
  tmpXPos: Single;
  tmpWidth: Single;
  ln: integer;
  FourceReturn: boolean;
  FText: string; 
  procedure InternalShowText(S: string; AWidth: Single);
  var
    i: Integer;
  begin
    i := MeasureText(S, AWidth);
    S := Copy(S, 1, i);
    ShowText(S);
  end;
begin
  YPos := ARect.Top - FAttr.FontSize*0.85;
  XPos := ARect.Left;
  FText := Text;

  BeginText;

  MoveTextPoint(XPos, YPos);
  i := 1;
  S2 := GetNextWord(FText, i);
  XPos := XPos +  TextWidth(S2);
  if (Length(S2) > 0) and (S2[Length(S2)] = ' ') then
    XPos := XPos + FAttr.WordSpace;

  while i <= Length(FText) do
  begin
    ln := Length(S2);
    if (ln >= 2) and (S2[ln] = #10) and (S2[ln-1] = #13) then
    begin
      S2 := Copy(S2, 1, ln - 2);
      FourceReturn := true;
    end
    else
      FourceReturn := false;

    S1 := GetNextWord(FText, i);
    tmpWidth := TextWidth(S1);
    TmpXPos := XPos + tmpWidth;

    if (WordWrap and (TmpXPos > ARect.Right)) or
      FourceReturn then
    begin
      if S2 <> '' then
        InternalShowText(S2, ARect.Right - ARect.Left);
      S2 := '';
      MoveToNextLine;
      ARect.Top := ARect.Top - FAttr.Leading;
      if ARect.Top < ARect.Bottom + FAttr.FontSize then
        Break;
      XPos := ARect.Left;
    end;
    XPos := XPos + tmpWidth;
    if (Length(S1) > 0) and (S1[Length(S1)] = ' ') then
      XPos := XPos + FAttr.WordSpace;
    S2 := S2 + S1;
  end;

  if S2 <> '' then
    InternalShowText(S2, ARect.Right - ARect.Left);
  EndText;
end;

// DrawXObject
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('DrawXObject --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;

// DrawXObjectEx
procedure TPdfCanvas.DrawXObjectEx(X, Y, AWidth, AHeight: Single;
      ClipX, ClipY, ClipWidth, ClipHeight: 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('DrawXObjectEx --XObject not found: %s', [AXObjectName]);

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

  GSave;
  Rectangle(ClipX, ClipY, ClipWidth, ClipHeight);
  Clip;
  NewPath;
  Concat(AWidth, 0, 0, AHeight, X, Y);
  ExecuteXObject(XObject.Attributes.PdfNameByName('Name').Value);
  GRestore;
end;

  {* Special Graphics State *}

// GSave
procedure TPdfCanvas.GSave;
begin
  WriteString('q'#10);
end;

// GRestore
procedure TPdfCanvas.GRestore;
begin
  WriteString('Q'#10);
end;

// Concat
procedure TPdfCanvas.Concat(a, b, c, d, e, f: Single);
var
  S: string;
begin
  S := _FloatToStrR(a) + ' ' +
       _FloatToStrR(b) + ' ' +
       _FloatToStrR(c) + ' ' +
       _FloatToStrR(d) + ' ' +
       _FloatToStrR(e) + ' ' +
       _FloatToStrR(f) + ' cm'#10;
  WriteString(S);
end;

  {* General Graphics State *}

// SetFlat
procedure TPdfCanvas.SetFlat(flatness: Byte);
var
  S: string;
begin
  S := IntToStr(flatness) + ' i'#10;
  WriteString(S);
end;

// SetLineCap
procedure TPdfCanvas.SetLineCap(linecap: TLineCapStyle);
var
  S: string;
begin
  S := IntToStr(ord(linecap)) + ' J'#10;
  WriteString(S);
end;

// SetDash
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
    for i := 0 to High(aarray) do
      S := S + IntToStr(aarray[i]) + ' ';
  S := S + '] ' + IntToStr(phase) + ' d'#10;
  WriteString(S);
end;

// SetLineJoin
procedure TPdfCanvas.SetLineJoin(linejoin: TLineJoinStyle);
var
  S: string;
begin
  S := IntToStr(ord(linejoin)) + ' j'#10;
  WriteString(S);
end;

// SetLineWidth
procedure TPdfCanvas.SetLineWidth(linewidth: Single);
var
  S: string;
begin
  S := _FloatToStrR(linewidth) + ' w'#10;
  WriteString(S);
end;

// SetMiterLimit
procedure TPdfCanvas.SetMiterLimit(miterlimit: Byte);
var
  S: string;
begin
  S := IntToStr(miterlimit) + ' M'#10;
  WriteString(S);
end;

  {* Paths *}

// MoveTo
procedure TPdfCanvas.MoveTo(x, y: Single);
var
  S: string;
begin
  S := _FloatToStrR(x) + ' ' + _FloatToStrR(y) + ' m'#10;
  WriteString(S);
end;

// LineTo
procedure TPdfCanvas.LineTo(x, y: Single);
var
  S: string;
begin
  S := _FloatToStrR(x) + ' ' + _FloatToStrR(y) + ' l'#10;
  WriteString(S);
end;

// CurveToC
procedure TPdfCanvas.CurveToC(x1, y1, x2, y2, x3, y3: Single);
var
  S: string;
begin
  S := _FloatToStrR(x1) + ' ' +
       _FloatToStrR(y1) + ' ' +
       _FloatToStrR(x2) + ' ' +
       _FloatToStrR(y2) + ' ' +
       _FloatToStrR(x3) + ' ' +
       _FloatToStrR(y3) + ' c'#10;
  WriteString(S);
end;

// CurveToV
procedure TPdfCanvas.CurveToV(x2, y2, x3, y3: Single);
var
  S: string;
begin
  S := _FloatToStrR(x2) + ' ' +
       _FloatToStrR(y2) + ' ' +
       _FloatToStrR(x3) + ' ' +
       _FloatToStrR(y3) + ' v'#10;
  WriteString(S);
end;

// CurveToY
procedure TPdfCanvas.CurveToY(x1, y1, x3, y3: Single);
var
  S: string;
begin
  S := _FloatToStrR(x1) + ' ' +
       _FloatToStrR(y1) + ' ' +
       _FloatToStrR(x3) + ' ' +
       _FloatToStrR(y3) + ' y'#10;
  WriteString(S);
end;

// Rectangle
procedure TPdfCanvas.Rectangle(x, y, width, height: Single);
var
  S: string;
begin
  S := _FloatToStrR(x) + ' ' +
       _FloatToStrR(y) + ' ' +
       _FloatToStrR(width) + ' ' +
       _FloatToStrR(height) + ' re'#10;
  WriteString(S);
end;

// Closepath
procedure TPdfCanvas.Closepath;
begin
  WriteString('h'#10);
end;

// NewPath
procedure TPdfCanvas.NewPath;
begin
  WriteString('n'#10);
end;

// Stroke
procedure TPdfCanvas.Stroke;
begin
  WriteString('S'#10);
end;

// ClosePathStroke
procedure TPdfCanvas.ClosePathStroke;
begin
  WriteString('s'#10);
end;

// Fill
procedure TPdfCanvas.Fill;
begin
  WriteString('f'#10);
end;

// Eofill
procedure TPdfCanvas.Eofill;
begin
  WriteString('f*'#10);
end;

// FillStroke
procedure TPdfCanvas.FillStroke;
begin
  WriteString('B'#10);
end;

// ClosepathFillStroke
procedure TPdfCanvas.ClosepathFillStroke;
begin
  WriteString('b'#10);
end;