pdfcreater.pas

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

{create by 季昌丰([e-mail]) 2004.02.21}

unit PDFCreater;

interface

uses
  Windows, SysUtils, Classes, PMFonts, Graphics;

const
  PDFCreater_VERSION_TEXT = 'PDFCreater0.9';

type
  TLineJoinStyle = (ljMiterJoin, ljRoundJoin, ljBevelJoin);

  TLineCapStyle = (lcButtEnd, lcRoundEnd, lcProjectingSquareEnd);

  TTextRenderingMode = (trFill,
                        trStroke,
                        trFillThenStroke,
                        trInvisible,
                        trFillClipping,
                        trStrokeClipping,
                        trFillStrokeClipping,
                        trClipping);

  TPDFRect = record
    Left, Top, Right, Bottom: Single;
  end;

  TPDFPoint = record
    X, Y: Single;
  end;

  TPDFCreater = class;

  TPDFObject = class(TObject)
  private
    FObjectID: integer;
    FOwner: TPDFCreater;
    function GetObjectHeader: string;
    function GetObjectDetail: string; virtual;
  public
    constructor Create(AOwner: TPDFCreater); virtual;
    function GetObjectString: string;
    property ObjectID: integer read FObjectID;
  end;

  TPDFObjectList = class(TObject)
  private
    FItems: TList;
    function GetItem(Index: integer): TPDFObject;
    function GetCount: integer;
  public
    constructor Create; virtual;
    procedure Clear;
    function AddItem(AItem: TPDFObject): integer; virtual;
    function GetArrayString: string;
    property Items[index: integer]: TPDFObject read GetItem; default;
    property Count: integer read GetCount;
    destructor Destroy; override;
  end;

  TPDFInfo = class(TPDFObject)
  private
    function GetObjectDetail: string; override;
  public
  end;

  TPDFPage = class;

  TPDFPages = class(TPDFObject)
  private
    FKids: TPDFObjectList;
    FHeight, FWidth: integer;
    procedure SetHeight(Value: integer);
    procedure SetWidth(Value: integer);
    function GetKids(Index: integer): TPDFObject;
    function GetObjectDetail: string; override;
  protected
    function AddPage: TPDFPage;
  public
    constructor Create(AOwner: TPDFCreater); override;
    property Kids[index: integer]: TPDFObject read GetKids; default;
    property Height: integer read FHeight write SetHeight;
    property Width: integer read FWidth write SetWidth;
  end;

  TPDFFontDescriptor = class(TPDFObject)
  private
    FFontDescriptorDef: TPDFFontDescriptorDef;
    function GetObjectDetail: string; override;
  public
    destructor Destroy; override;
    procedure SetFontDescriptorDef(AFontDescriptorDef: TPDFFontDescriptorDef);
  end;

  TPDFFont = class(TPDFObject)
  private
    FFontDef: TPDFFontDef;
    FFontDescriptor: TPDFFontDescriptor;
    FDescendantFont: TPDFFont;
    FFontName: integer;
    function GetFontID: TPDFFontID;
  protected
    function GetObjectDetail: string; override;
    function GetCharWidth(C: Char): integer;
  public
    constructor Create(AOwner: TPDFCreater); override;
    destructor Destroy; override;
    procedure SetFontDef(AFontDef: TPDFFontDef); virtual;
    property FontName: integer read FFontName;
    property FontID: TPDFFontID read GetFontID;
  end;

  TPDFContents = class(TPDFObject)
  private
    FBuf: string;
    FFont: TPDFFontID;
    FFontSize: Single;
    FLineWidth: Single;
    FLineJoinStyle: TLineJoinStyle;
    FLineCapStyle: TLineCapStyle;
    FFillColor: TColor;
    FStrokeColor: TColor;
    FLeading: Single;
    FCharSpace: Single;
    FWordSpace: Single;
    FStateSaved: boolean;

    procedure SaveDefaultGState;
    function GetObjectDetail: string; override;
    function GetColorStr(Color: TColor): string;
    function EscapeText(Value: string): string;
    function StrToHex(s: string): string;
  public
    constructor Create(AOwner: TPDFCreater); override;
                                                                {Operator}
    procedure pCFillStroke;                                     {  b     }
    procedure pFillStroke;                                      {  B     }
    procedure pCEofillStroke;                                   {  b*    }
    procedure pEofillStroke;                                    {  B*    }
    procedure pBeginText;                                       {  BT    }
    procedure pCurveTo(x1, y1, x2, y2, x3, y3: Single);         {  c     }
    procedure pSetDash(Length1, Length2, Phase: Byte);          {  d     }
    procedure pEndText;                                         {  ET    }
    procedure pFillPath;                                        {  f     }
    procedure pEofillPath;                                      {  f*    }
    procedure pClosePath;                                       {  h     }
    procedure pSetFlatness(Value: Single);                      {  i     }
    procedure pSetLineJoin(Value: TLineJoinStyle);              {  j     }
    procedure pSetLineCap(Value: TLineCapStyle);                {  J     }
    procedure pLineTo(x, y: Single);                            {  l     }
    procedure pMoveTo(x, y: Single);                            {  m     }
    procedure pSetMitterLimit(Value: Single);                   {  M     }
    procedure pEndPath;                                         {  n     }
    procedure pSetRGBFillColor(Value: TColor);                  {  rg    }
    procedure pSetRGBStrokeColor(Value: TColor);                {  RG    }
    procedure pClosePathStroke;                                 {  s     }
    procedure pStroke;                                          {  S     }
    procedure pSetCharSpace(Value: Single);                     {  Tc    }
    procedure pMoveTextPoint(x, y: Single);                     {  Td    }
    procedure pSetFontAndSize(AFont: TPDFFontID; ASize: Single);{  Tf    }
    procedure pShowText(Value: string);                         {  Tj    }
    procedure pShowJText(Value: string);                        {  Tj    }
    procedure pSetLeading(Value: Single);                       {  TL    }
    procedure pSetTextRendering(Value: TTextRenderingMode);     {  Tr    }
    procedure pSetWordSpace(Value: Single);                     {  Tw    }
    procedure pSetHolizontalScaling(Value: Byte);               {  Tz    }
    procedure pMoveToNextLine;                                  {  T*    }
    procedure pSetLineWidth(Value: Single);                     {  w     }
    procedure pClip;                                            {  W     }
    procedure pSaveGState;                                      {  q     }
    procedure pRestoreGState;                                   {  Q     }
    procedure pEoclip;                                          {  W*    }
    procedure pTextShowNextLine(Value: string);                 {  '     }
    procedure pJTextShowNextLine(Value: string);                {  '     }

    function TextWidth(S: string): Single;
    function MeasureText(S: string; AWidth: Single): integer;
    function ArrangeText(Src: string; var Dst: string; AWidth: Single): integer;
    procedure LineTo(x1, y1, x2, y2: Single);
    procedure DrawRect(x1, y1, x2, y2: Single; Clip: boolean);
    procedure FillRect(x1, y1, x2, y2: Single; Clip: boolean);
    procedure DrawAndFillRect(x1, y1, x2, y2: Single; Clip: boolean);
    procedure TextOut(X, Y: Single; Text: string);
    procedure CancelClip;

    property Font: TPDFFontID read FFont write FFont;
    property FontSize: Single read FFontSize write FFontSize;
    property LineWidth: Single read FLineWidth write FLineWidth;
    property LineJoinStyle: TLineJoinStyle read FLineJoinStyle write FLineJoinStyle;
    property LineCapStyle: TLineCapStyle read FLineCapStyle write FLineCapStyle;
    property FillColor: TColor read FFillColor write FFillColor;
    property StrokeColor: TColor read FStrokeColor write FStrokeColor;
    property Leading: Single read FLeading write FLeading;
    property CharSpace: Single read FCharSpace write FCharSpace;
    property WordSpace: Single read FWordSpace write FWordSpace;
  end;


  TPDFPage = class(TPDFObject)
  private
    FContents: TPDFContents;
    FParent: TPDFPages;
    function GetObjectDetail: string; override;
  public
    constructor Create(AOwner: TPDFCreater); override;
    procedure SetParent(AParent: TPDFPages);
    property Contents: TPDFContents read FContents;
  end;

  TPDFCatalog = class(TPDFObject)
  private
    FPagesObject: TPDFPages;
    function GetObjectDetail: string; override;
  public
    constructor Create(AOwner: TPDFCreater); override;
    property Pages: TPDFPages read FPagesObject;
  end;

  TPDFCreater = class(TObject)
  public
  private
    FStream: TStream;
    FRoot: TPDFCatalog;
    FObjectList: TPDFObjectList;
    FFonts: TPDFObjectList;
    FCanvas: TPDFContents;
    FInfo: TPDFInfo;
    FAuthor: string;
    FTitle: string;
    FCreator: string;
    FSubject: string;
    FFontsStatus: array[0..MAX_PDF_FONT_INDEX] of boolean;
    FPrinting: boolean;
    FPage: integer;
    FPageWidth: Integer;
    FPageHeight: Integer;

    function GetCanvas: TPDFContents;
    procedure SetPageHeight(Value: Integer);
    procedure SetPageWidth(Value: Integer);
  protected
    function RegisterObject(AObject: TPDFObject): integer;
    function RegisterFont(AFont: TPDFFont): integer;
    function GetFont(FontID: TPDFFontID): TPDFFont;
    function GetFontNameList: string;
    procedure WriteObject;
    procedure ClearObject;
    procedure CheckStatus;
  public
    constructor Create;
    destructor Destroy; override;
    procedure BeginDoc(AStream: TStream);
    procedure EndDoc(ACloseStream: boolean);
    procedure NewPage;
    property Canvas: TPDFContents read GetCanvas;
    property Author: string read FAuthor write FAuthor;
    property Title: string read FTitle write FTitle;
    property Creator: string read FCreator write FCreator;
    property Subject: string read FSubject write FSubject;
    property Page: integer read FPage;
    property PageHeight: integer read FPageHeight write SetPageHeight;
    property PageWidth: integer read FPageWidth write SetPageWidth;

  end;

  function PDFRect(Left, Top, Right, Bottom: Single): TPDFRect;
  function PDFPoint(x, y: Single): TPDFPoint;

implementation

const
  CRLF = #13#10;
  CR = #13;

function PDFRect(Left, Top, Right, Bottom: Single): TPDFRect;
begin
  Result.Left := Left;
  Result.Top := Top;
  Result.Right := Right;
  Result.Bottom := Bottom;
end;

function PDFPoint(x, y: Single): TPDFPoint;
begin
  Result.X := x;
  Result.Y := y;
end;

function PDFRectToString(ARect: TPDFRect): string;
begin
  result := '[ ' + FloatToStr(ARect.Left) +
            ' ' + FLoatToStr(ARect.Top) +
            ' ' + FLoatToStr(ARect.Right) +
            ' ' + FLoatToStr(ARect.Bottom) + ' ]';
end;

function RectToString(ARect: TRect): string;
begin
  result := '[ ' + IntToStr(ARect.Left) +
            ' ' + IntToStr(ARect.Top) +
            ' ' + IntToStr(ARect.Right) +
            ' ' + IntToStr(ARect.Bottom) + ' ]';
end;

function PDFPointToString(APoint: TPDFPoint): string;
begin
  result := '[ ' + FLoatToStr(APoint.X) +
            ' ' + FLoatToStr(APoint.Y) + ' ]';
end;

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

constructor TPDFObject.Create(AOwner: TPDFCreater);
begin
  FOwner := AOwner;
  FObjectID := AOwner.RegisterObject(Self);
end;

function TPDFObject.GetObjectHeader: string;
begin
  result := IntToStr(FObjectID) + ' 0 obj' + CRLF;
end;

function TPDFObject.GetObjectDetail: string;
begin
  result := '';
end;

function TPDFObject.GetObjectString: string;
begin
  result := GetObjectHeader +
            GetObjectDetail +
            'endobj' + CRLF;
end;

constructor TPDFObjectList.Create;
begin
  FItems := TList.Create;
  FItems.Clear;
end;

destructor TPDFObjectList.Destroy;
begin
  FItems.Free;
  inherited;
end;

function TPDFObjectList.AddItem(AItem: TPDFObject): integer;
begin
  if (AItem <> nil) and (AItem is TPDFObject) then
    result := FItems.Add(AItem)
  else
    result := -1;
end;

function TPDFObjectList.GetItem(Index: integer): TPDFObject;
begin
  if (Index < FItems.Count) and (Index >= 0) then
    result := TPDFObject(FItems[Index])
  else
    raise Exception.CreateFmt('Internel Error Invalid Index %d', [Index]);
end;

function TPDFObjectList.GetCount: integer;
begin
  result := FItems.Count;
end;

function TPDFObjectList.GetArrayString: string;
var
  i: integer;
begin
  result := '[';
  for i := 0 to FItems.Count - 1 do
    result := result + IntToStr(Items[i].ObjectID) + ' 0 R ';
  result := result + ']'
end;

procedure TPDFObjectList.Clear;
begin
  FItems.Clear;
end;

function TPDFCreater.GetCanvas: TPDFContents;
begin
  if FCanvas = nil then
    raise Exception.Create('BeginDoc出错。');
  result := FCanvas;
end;

procedure TPDFCreater.SetPageHeight(Value: Integer);
begin
  if FCanvas <> nil then
    raise Exception.Create('设置页面高度出错。');
  if Value > 0 then
    FPageHeight := Value;
end;

procedure TPDFCreater.SetPageWidth(Value: Integer);
begin
  if FCanvas <> nil then
    raise Exception.Create('设置页面宽度出错。');
  if Value > 0 then
    FPageWidth := Value;
end;

function TPDFCreater.RegisterObject(AObject: TPDFObject): integer;
begin
  result := FObjectList.AddItem(AObject) + 1;
end;

function TPDFCreater.RegisterFont(AFont: TPDFFont): integer;
begin
  result := FFonts.AddItem(AFont);
end;

function TPDFCreater.GetFontNameList: string;