pdfcreater.pas

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

var
  i: integer;
begin
  result := '';
  for i := 0 to FFonts.Count - 1 do
    result := Result + '/F' + IntToStr(TPDFFont(FFonts[i]).FontName) +
              ' ' + IntToStr(TPDFFont(FFonts[i]).ObjectID) + ' 0 R' + CRLF;
end;

function TPDFCreater.GetFont(FontID: TPDFFontID): TPDFFont;
var
  PDFFont: TPDFFont;
  i: integer;
begin
  result := nil;
  if not FFontsStatus[ord(FontID)] then
  begin
    PDFFont := TPDFFont.Create(Self);
    PDFFont.FFontName := RegisterFont(PDFFont);
    PDFFont.SetFontDef(CreateFont(FontID));
    FFontsStatus[ord(FontID)] := true;
    result := PDFFont;
  end
  else
    for i := 0 to FFonts.Count - 1 do
      if TPDFFont(FFonts[i]).FontID = FontID then
      begin
        result := TPDFFont(FFonts[i]);
        break;
      end
end;

constructor TPDFCreater.Create;
begin
  FObjectList := TPDFObjectList.Create;
  FFonts := TPDFObjectList.Create;
  FCanvas := nil;
  FPrinting := false;
  FPageHeight := 842;
  FPageWidth := 596;
end;

destructor TPDFCreater.Destroy;
begin
  ClearObject;
  FFonts.Free;
  FObjectList.Free;
  inherited;
end;

procedure TPDFCreater.CheckStatus;
begin
  if FPrinting then
    raise Exception.Create('正在生成文件。');
end;

procedure TPDFCreater.BeginDoc(AStream: TStream);
var
  i: integer;
begin
  if AStream = nil then
    raise Exception.Create('Invarid Stream');
  FStream := AStream;
  ClearObject;
  FRoot := TPDFCatalog.Create(Self);
  for i := 0 to MAX_PDF_FONT_INDEX do
    FFontsStatus[i] := false;
  FInfo := TPDFInfo.Create(Self);
  FPage := 0;
  NewPage;
  FPrinting := true;
end;

procedure TPDFCreater.EndDoc(ACloseStream: boolean);
begin
  FPrinting := false;
  WriteObject;
  FCanvas := nil;
  if ACloseStream then
    FStream.Free;
end;

procedure TPDFCreater.NewPage;
begin
  FCanvas := FRoot.Pages.AddPage.Contents;
  inc(FPage);
end;

procedure TPDFCreater.ClearObject;
var
  i: integer;
begin
  for i := FObjectList.Count - 1 downto 0 do
    if FObjectList.Items[i] <> nil then
      FObjectList.Items[i].Free;
  FObjectList.Clear;
  FFonts.Clear;
end;

procedure TPDFCreater.WriteObject;
var
  i: integer;
  s: string;
  xrefBuf: string;
  xrefPos: integer;

  procedure WriteHeader;
  var
    S: string;
  begin
    S := '%PDF-1.4 ' + CRLF;
    FStream.Write(PChar(S)^, Length(S));
  end;

  procedure WriteFooter;
  var
    S: string;
  begin
    S := 'trailer' + CRLF +
         '<<' + CRLF +
         '/Size ' + IntToStr(FObjectList.Count+1) + CRLF +
         '/Root ' + IntToStr(FRoot.ObjectID) + ' 0 R' + CRLF +
         '/Info ' + IntToStr(FInfo.ObjectID) + ' 0 R' + CRLF +
         '>>' + CRLF +
         'startxref' + CRLF +
         IntToStr(xrefPos) + CRLF +
         '%%EOF' + CRLF;
    FStream.Write(PChar(S)^, Length(S));
  end;

  function SetAddrLength(Value: integer): string;
  begin
    result := IntToStr(Value);
    while Length(Result) < 10 do
      Result := '0' + Result;
  end;

begin
  xrefbuf := 'xref' + CRLF + '0 ' + IntToStr(FObjectList.Count+1) + CRLF +
             '0000000000 65535 f' + CRLF;
  FStream.Position := 0;
  WriteHeader;
  for i := 0 to FObjectList.Count - 1 do
  begin
    xrefBuf := xrefBuf + SetAddrLength(FStream.Position) + ' 00000 n' + CRLF;
    s := FObjectList.Items[i].GetObjectString;
    FStream.Write(PChar(s)^, Length(S));
  end;
  xrefPos := FStream.Position;
  FStream.Write(PChar(xrefbuf)^, Length(xrefbuf));
  WriteFooter;
end;

constructor TPDFCatalog.Create(AOwner: TPDFCreater);
begin
  inherited Create(AOwner);
  FPagesObject := TPDFPages.Create(AOwner);
  FPagesObject.Width := AOwner.PageWidth;
  FPagesObject.Height := AOwner.PageHeight;
end;

function TPDFCatalog.GetObjectDetail: string;
begin
  result := '<<' + CRLF +
            '/Type /Catalog' + CRLF +
            '/Pages ' + IntToStr(FPagesObject.ObjectID) + ' 0 R' + CRLF +
            '>>' + CRLF;
end;

constructor TPDFPages.Create(AOwner: TPDFCreater);
begin
  inherited Create(AOwner);
  FKids := TPDFObjectList.Create;
end;

function TPDFPages.GetKids(Index: integer): TPDFObject;
begin
  result := FKids.Items[Index];
end;

function TPDFPages.GetObjectDetail: string;
begin
  result := '<<' + CRLF +
            '/Kids ' + FKids.GetArrayString + CRLF +
            '/Count ' + IntToStr(FKids.Count) + CRLF +
            '/Type /Pages' + CRLF +
            '/MediaBox [ 0 0 ' + IntToStr(FWidth) + ' ' + IntToStr(FHeight) + ' ]' + CRLF +
            '>>' + CRLF;
end;

function TPDFPages.AddPage: TPDFPage;
begin
  result := TPDFPage.Create(FOwner);
  FKids.AddItem(result);
  result.SetParent(Self);
end;

procedure TPDFPages.SetHeight(Value: integer);
begin
  if Value > 0 then
    FHeight := Value;
end;

procedure TPDFPages.SetWidth(Value: integer);
begin
  if Value > 0 then
    FWidth := Value;
end;

function TPDFPage.GetObjectDetail: string;
begin
  result := '<<' + CRLF +
            '/Type /Page' + CRLF +
            '/Parent ' + IntToStr(FParent.ObjectID) + ' 0 R' + CRLF +
            '/Resources <<' + CRLF +
            '/Font <<' + CRLF +
            FOwner.GetFontNameList +
            '>>' + CRLF +
            '/ProcSet [ /PDF /Text ]' + CRLF +
            '>>'  + CRLF +
            '/Contents ' + IntToStr(FContents.ObjectID) + ' 0 R' + CRLF +
            '>>' + CRLF;
end;

constructor TPDFPage.Create(AOwner: TPDFCreater);
begin
  inherited Create(AOwner);
  FContents := TPDFContents.Create(AOwner);
end;

procedure TPDFPage.SetParent(AParent: TPDFPages);
begin
  FParent := AParent;
end;

constructor TPDFContents.Create(AOwner: TPDFCreater);
begin
  inherited Create(AOwner);
  FBuf := '';
  FFont := fiCentury;
  FFontSize := 10;
  FLineWidth := 1;
  FLineJoinStyle := ljMiterJoin;
  FLineCapStyle := lcButtEnd;
  FFillColor := clBlack;
  FStrokeColor := clBlack;
  FLeading := 0;
  FStateSaved := false;
end;

function TPDFContents.GetObjectDetail: string;
const
  LF = #10;
begin
  result := '<<' + CRLF +
            '/Length ' + IntToStr(Length(FBuf)) + CRLF +
            '>>' + CRLF +
            'stream' + CRLF +
            FBuf + LF +
            'endstream' + CRLF;
end;

procedure TPDFContents.SaveDefaultGState;
begin
  if not FStateSaved then
  begin
    pSaveGState;
    FStateSaved := true;
  end;
end;

procedure TPDFContents.LineTo(x1, y1, x2, y2: Single);
begin
  pMoveTo(x1, y1);
  pSetLineCap(FLineCapStyle);
  pSetRGBStrokeColor(StrokeColor);
  pSetLineWidth(FLineWidth);
  pLineTo(x2, y2);
  pStroke;
  pEndPath;
end;

function TPDFContents.TextWidth(S: string): Single;
var
  i: integer;
  SW: Single;
  FPDFFont: TPDFFont;
begin
  FPDFFont := FOwner.GetFont(FFont);
  SW := 0;
  i := 1;
  while i <= Length(S) do
  begin
    if (ByteType(S, i) = mbSingleByte) then
    begin
      if i <> 1 then
        SW := SW + FCharSpace;
      SW := SW + FPDFFont.GetCharWidth(S[i]) * FFontSize / 1000;
      if S[i] = ' ' then
        SW := SW + FWordSpace;
    end
    else
    if (ByteType(S, i) = mbTrailByte) and (i > 2) then
      SW := SW + FPDFFont.GetCharWidth(Chr(0)) / 2 * FFontSize / 1000 + FCharSpace
    else
      SW := SW + FPDFFont.GetCharWidth(Chr(0)) / 2 * FFontSize / 1000;
    inc(i);
  end;
  result := SW;
end;

function TPDFContents.MeasureText(S: string; AWidth: Single): integer;
var
  i: integer;
  SW: Single;
  SL: integer;
  FPDFFont: TPDFFont;
begin
  FPDFFont := FOwner.GetFont(FFont);
  SW := 0;
  i := 1;
  result := 0;
  SL := Length(S);
  while i <= SL do
  begin
    if (ByteType(S, i) = mbSingleByte) then
    begin
      if i > 1 then
        SW := SW + FCharSpace;
      SW := SW + FPDFFont.GetCharWidth(S[i]) * FFontSize / 1000;
      if i = SL then
        result := i
      else
      if S[i] = ' ' then
      begin
        SW := SW + FWordSpace;
        result := i;
      end;
    end
    else
    begin
      SW := SW + FPDFFont.GetCharWidth(Chr(0)) / 2 * FFontSize / 1000;

      if (ByteType(S, i) = mbTrailByte) then
      begin
        if i > 2 then
          SW := SW + FCharSpace;
        result := i;
      end;
    end;
    inc(i);

    if (SW > AWidth) and (result > 0) then Exit;
  end;
end;

function TPDFContents.ArrangeText(Src: string; var Dst: string; AWidth: Single): integer;
var
  i, j: integer;
begin
  j := 1;
  result := 0;
  Dst := '';
  while j <= Length(Src) do
  begin
    i := MeasureText(Copy(Src, j, Length(Src) - (j - 1)), AWidth);
    Dst := Dst + Copy(Src, j, i) + #13#10;
    result := result + 1;
    j := j + i;
  end;
end;

procedure TPDFContents.DrawRect(x1, y1, x2, y2: Single; Clip: boolean);
begin
  pMoveTo(x1, y1);
  pSetLineWidth(FLineWidth);
  pSetLineJoin(FLineJoinStyle);
  pSetRGBStrokeColor(FStrokeColor);
  pLineTo(x1, y2);
  pLineTo(x2, y2);
  pLineTo(x2, y1);
  if Clip then
  begin
    SaveDefaultGState;
    pClip;
  end;
  pClosePathStroke;
end;

procedure TPDFContents.FillRect(x1, y1, x2, y2: Single; Clip: boolean);
begin
  pMoveTo(x1, y1);
  pSetLineWidth(FLineWidth);
  pSetLineJoin(FLineJoinStyle);
  pSetRGBFillColor(FFillColor);
  pLineTo(x1, y2);
  pLineTo(x2, y2);
  pLineTo(x2, y1);
  if Clip then
  begin
    SaveDefaultGState;
    pClip;
  end
  else
    pClosePath;
  pFillPath;
end;

procedure TPDFContents.DrawAndFillRect(x1, y1, x2, y2: Single; Clip: boolean);
begin
  pMoveTo(x1, y1);
  pSetLineWidth(FLineWidth);
  pSetLineJoin(FLineJoinStyle);
  pSetRGBFillColor(FFillColor);
  pSetRGBStrokeColor(FStrokeColor);
  pLineTo(x1, y2);
  pLineTo(x2, y2);
  pLineTo(x2, y1);
  if Clip then
  begin
    SaveDefaultGState;
    pClip;
  end