pdfcreater.pas

源码级制作含有中文的PDF文件,不需要ACTIVE OCX,就可以自己创建PDF 文档.

  else
    pClosePath;
  pFillStroke;
end;

procedure TPDFContents.TextOut(X, Y: Single; Text: string);
var
  StrPos, CurPos: integer;
  StrLen: integer;
  procedure InternalTextOut(s: string);
  var
    HasDoubleByteChar: boolean;
    i: integer;
  begin
    HasDoubleByteChar := false;
    for i := 1 to Length(s) do
      if ByteType(s, i) <> mbSingleByte then
      begin
        HasDoubleByteChar := true;
        Break;
      end;
    if HasDoubleByteChar then
      pShowJText(s)
    else
      pShowText(s);
  end;
begin
  pBeginText;
  pSetFontAndSize(FFont, FFontSize);
  pSetRGBFillColor(FFillColor);
  pSetLeading(FLeading);
  pSetCharSpace(FCharSpace);
  pSetWordSpace(FWordSpace);
  pMoveTextPoint(X, Y);
  StrPos := 1;
  CurPos := 1;
  StrLen := Length(Text);
  while CurPos <= StrLen do
  begin

    if Text[CurPos] = #13 then
    begin
      InternalTextOut(Copy(Text, StrPos, (CurPos-StrPos)));
      if CurPos >= StrLen then
        Break
      else
      if Text[(CurPos+1)] = #10 then
        inc(CurPos);
      StrPos := CurPos + 1;
      pMoveToNextLine;
    end;
    inc(CurPos);
  end;
  if StrPos < CurPos then
    InternalTextOut(Copy(Text, StrPos, CurPos-1));
  pEndText;
end;

procedure TPDFContents.CancelClip;
begin
  if FStateSaved then
  begin
    pRestoreGState;
    FStateSaved := false;
  end;
end;

function TPDFContents.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;

function TPDFContents.EscapeText(Value: string): string;
const
  EscapeChars = ['(',')','\'];
var
  i: integer;
begin
  result := '';
  for i := 1 to Length(Value) do
  begin
    if (Value[i] in EscapeChars) and (ByteType(Value, i - 1) = mbSingleByte) then
       result := result + '\' + Value[i]
    else
       result := result + Value[i];
  end;
end;

function TPDFContents.StrToHex(s: string): string;
var
  i: integer;
begin
  result := '';
  for i := 1 to Length(s) do
    result := result + IntToHex(ord(s[i]), 2);
end;

procedure TPDFContents.pCFillStroke;
begin
  FBuf := FBuf + 'b' + CR;
end;

procedure TPDFContents.pFillStroke;
begin
  FBuf := FBuf + 'B' + CR;
end;

procedure TPDFContents.pCEofillStroke;
begin
  FBuf := FBuf + 'b*' + CR;
end;

procedure TPDFContents.pEofillStroke;
begin
  FBuf := FBuf + 'B*' + CR;
end;

procedure TPDFContents.pBeginText;
begin
  FBuf := FBuf + 'BT' + CR;
end;

procedure TPDFContents.pSetDash(Length1, Length2, Phase: Byte);
var
  s: string;
begin
  s := '[';
  if Length1 > 0 then
    s := s + IntToStr(Length1) + ' ';
  if Length2 > 0 then
    s := s + IntToStr(Length2);
  s := s + ']' + IntToStr(Phase) + ' d' + CR;
  FBuf := FBuf + s;
end;

procedure TPDFContents.pCurveTo(x1, y1, x2, y2, x3, y3: Single);
begin
  FBuf := FBuf + FloatToStrR(x1) +
          ' ' + FloatToStrR(y1) +
          ' ' + FloatToStrR(x2) +
          ' ' + FloatToStrR(y2) +
          ' ' + FloatToStrR(x3) +
          ' ' + FloatToStrR(y3) +
          ' c' + CR;
end;

procedure TPDFContents.pFillPath;
begin
  FBuf := FBuf + 'f' + CR;
end;

procedure TPDFContents.pEofillPath;
begin
  FBuf := FBuf + 'f*' + CR;
end;

procedure TPDFContents.pClosePath;
begin
  FBuf := FBuf + 'h' + CR;
end;

procedure TPDFContents.pEndPath;
begin
  FBuf := FBuf + 'n' + CR;
end;

procedure TPDFContents.pEndText;
begin
  FBuf := FBuf + 'ET' + CR;
end;

procedure TPDFContents.pSetFlatness(Value: Single);
begin
  FBuf := FBuf + FloatToStrR(Value) + ' i' + CR;
end;

procedure TPDFContents.pSetLineJoin(Value: TLineJoinStyle);
begin
  FBuf := FBuf + IntToStr(ord(Value)) + ' j' + CR;
end;

procedure TPDFContents.pSetLineCap(Value: TLineCapStyle);
begin
  FBuf := FBuf + IntToStr(ord(Value)) + ' J' + CR;
end;

procedure TPDFContents.pLineTo(x, y: Single);
begin
  FBuf := FBuf + FloatToStrR(x) + ' ' + FloatToStrR(y) + ' l' + CR;
end;

procedure TPDFContents.pMoveTo(x, y: Single);
begin
  FBuf := FBuf + FloatToStrR(x) + ' ' + FloatToStrR(y) + ' m' + CR;
end;

procedure TPDFContents.pSetMitterLimit(Value: Single);
begin
  FBuf := FBuf + FloatToStrR(Value) + ' M' + CR;
end;

procedure TPDFContents.pSetRGBFillColor(Value: TColor);
begin
  FBuf := FBuf + GetColorStr(Value) + ' rg ' + CR;
end;

procedure TPDFContents.pSetRGBStrokeColor(Value: TColor);
begin
  FBuf := FBuf + GetColorStr(Value) + ' RG ' + CR;
end;

procedure TPDFContents.pClosePathStroke;
begin
  FBuf := FBuf + 's' + CR;
end;

procedure TPDFContents.pStroke;
begin
  FBuf := FBuf + 'S' + CR;
end;

procedure TPDFContents.pSetCharSpace(Value: Single);
begin
  FBuf := FBuf + FloatToStrR(Value) + ' Tc' + CR;
end;

procedure TPDFContents.pMoveTextPoint(x, y: Single);
begin
  FBuf := FBuf + FloatToStrR(x) + ' ' + FloatToStrR(y) + ' Td' + CR;
end;

procedure TPDFContents.pSetFontAndSize(AFont: TPDFFontID; ASize: Single);
begin
  FBuf := FBuf + '/F' + IntToStr(FOwner.GetFont(AFont).FontName) +
                                 ' ' + FloatToStrR(ASize) + ' Tf' + CR;
end;

procedure TPDFContents.pShowText(Value: string);
begin
  FBuf := FBuf + '(' + EscapeText(Value) + ') Tj' + CR;
end;

procedure TPDFContents.pShowJText(Value: string);
begin
  FBuf := FBuf + '<' + StrToHex(Value) + '> Tj' + CR;
end;

procedure TPDFContents.pSetLeading(Value: Single);
begin
  FBuf := FBuf + FloatToStrR(Value) + ' TL' + CR;
end;

procedure TPDFContents.pSetTextRendering(Value: TTextRenderingMode);
begin
  FBuf := FBuf + IntToStr(ord(Value)) + ' Tr' + CR;
end;

procedure TPDFContents.pSetWordSpace(Value: Single);
begin
  FBuf := FBuf + FloatToStrR(Value) + ' Tw' + CR;
end;

procedure TPDFContents.pSetHolizontalScaling(Value: Byte);
begin
  FBuf := FBuf + FloatToStrR(Value) + ' Tz' + CR;
end;

procedure TPDFContents.pMoveToNextLine;
begin
  FBuf := FBuf + 'T*' + CR;
end;

procedure TPDFContents.pSetLineWidth(Value: Single);
begin
  FBuf := FBuf + FloatToStrR(Value) + ' w' + CR;
end;

procedure TPDFContents.pClip;
begin
  FBuf := FBuf + 'W' + CR;
end;

procedure TPDFContents.pSaveGState;
begin
  FBuf := FBuf + 'q' + CR;
end;

procedure TPDFContents.pRestoreGState;
begin
  FBuf := FBuf + 'Q' + CR;
end;

procedure TPDFContents.pEoclip;
begin
  FBuf := FBuf + 'W*' + CR;
end;

procedure TPDFContents.pTextShowNextLine(Value: string);
begin
  FBuf := FBuf + '(' + Value + ') ''' + CR;
end;

procedure TPDFContents.pJTextShowNextLine(Value: string);
begin
  FBuf := FBuf + '<' + StrToHex(Value) + '> ''' + CR;
end;

constructor TPDFFont.Create(AOwner: TPDFCreater);
begin
  inherited Create(AOwner);
  FFontDescriptor := nil;
  FDescendantFont := nil;
end;

destructor TPDFFont.Destroy;
begin
  if FFontDef <> nil then
    FFontDef.Free;
  inherited;
end;

function TPDFFont.GetFontID: TPDFFontID;
begin
  result := FFontDef.FontID;
end;

procedure TPDFFont.SetFontDef(AFontDef: TPDFFontDef);
begin
  FFontDef := AFontDef;
  if FFontDef.FontDescriptor <> nil then
  begin
    FFontDescriptor := TPDFFontDescriptor.Create(FOwner);
    FFontDescriptor.FFontDescriptorDef := FFontDef.FontDescriptor;
  end;
  if FFontDef.DescendantFont <> nil then
  begin
    FDescendantFont := TPDFFont.Create(FOwner);
    FDescendantFont.SetFontDef(FFontDef.DescendantFont);
  end;
end;

function TPDFFont.GetCharWidth(C: Char): integer;
begin
  result := FFontDef.GetCharWidth(C);
end;

function TPDFFont.GetObjectDetail: string;
begin
  result := '<<' + CRLF +
            '/Type /Font' + CRLF +
            '/Name /F' + IntToStr(FontName) + CRLF +
            FFontDef.DetailString;
  if FFontDescriptor <> nil then
    result := result + '/FontDescriptor ' + IntToStr(FFontDescriptor.ObjectID) + ' 0 R' + CRLF;
  if FDescendantFont <> nil then
    result := result + '/DescendantFonts [' + IntToStr(FDescendantFont.ObjectID) + ' 0 R]' + CRLF;

  result := result + '>>' + CRLF;

end;

function TPDFFontDescriptor.GetObjectDetail: string;
begin
  result := '<<' + CRLF +
  '/Type /FontDescriptor' + CRLF +
  '/FontName /' + FFontDescriptorDef.FontName + CRLF +
  '/Flags ' + IntToStr(FFontDescriptorDef.Flags) + CRLF +
  '/FontBBox ' + RectToString(FFontDescriptorDef.FontBBox) + CRLF +
  '/StemV ' + IntToStr(FFontDescriptorDef.StemV) + CRLF +
  '/Ascent ' + IntToStr(FFontDescriptorDef.Ascent) + CRLF +
  '/CapHeight ' + IntToStr(FFontDescriptorDef.CapHeight) + CRLF +
  '/Descent ' + IntToStr(FFontDescriptorDef.Descent) + CRLF +
  '/ItalicAngle ' + IntToStr(FFontDescriptorDef.ItalicAngle) + CRLF +
  '>>' + CRLF;
end;

procedure TPDFFontDescriptor.SetFontDescriptorDef(AFontDescriptorDef: TPDFFontDescriptorDef);
begin
  FFontDescriptorDef := AFontDescriptorDef;
end;

destructor TPDFFontDescriptor.Destroy;
begin
  FFontDescriptorDef.Free;
  inherited;
end;

function TPDFInfo.GetObjectDetail: string;
  function StrToUnicodeHex(Value: string): string;
  var
    Buf: array[0..1024] of char;
    Len: integer;
    i: integer;
  begin
    result := 'FEFF001B6A61001B';
    Len := MultiByteToWideChar(0, 0, PChar(Value), Length(Value), @Buf, 1024);
    i := 0;
    while i < Len * 2 do
    begin
      result := result + IntToHex(Ord(Buf[i+1]), 2) + IntToHex(Ord(Buf[i]), 2);
      inc(i, 2);
    end;
  end;
begin
  result := '<<' + CRLF +
            '/CreationDate (D:' + FormatDateTime('yyyymmddhhnnss', now) + ')' + CRLF +
            '/Creator <' + StrToUnicodeHex(FOwner.Creator) + '>' + CRLF +
            '/Producer (' + PDFCreater_VERSION_TEXT + ')' + CRLF +
            '/Author <' + StrToUnicodeHex('季昌丰([e-mail])') + '>' + CRLF +
            '/Title <' + StrToUnicodeHex('中文PDF') + '>' + CRLF +
            '/Subject <' + StrToUnicodeHex('欢迎讨论') + '>' + CRLF +
            '>>' + CRLF;
end;

end.