pmfonts.pas

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

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

unit PMFonts;

interface

uses
  Windows, SysUtils, Classes;

const
  MAX_PDF_FONT_INDEX = 8;

type
  TPDFFontDescriptorDef = class;

  TPDFFontID = (fiCentury,
                fiCenturyBold,
                fiArial,
                fiArialBold,
                fiCourier,
                fiCourierBold,
                fiMincyo,
                fiGothic,
                fiSong);

  TPDFFontDef = class(TObject)
  private
    FSubtype: string;
    FBaseFont: string;
    FFontDescriptor: TPDFFontDescriptorDef;
    FDescendantFont: TPDFFontDef;
    FFontID: TPDFFontID;
    FWArray: array[0..255] of Integer;
  protected
    function GetDetailString: string; virtual;
    procedure CreateFontDef; virtual;
    procedure InitFontDef; virtual;
    property Subtype: string read FSubtype write FSubtype;
    property BaseFont: string read FBaseFont write FBaseFont;
  public
    constructor Create; virtual;
    function GetCharWidth(C: Char): integer;
    property DetailString: string read GetDetailString;
    property FontDescriptor: TPDFFontDescriptorDef read FFontDescriptor;
    property DescendantFont: TPDFFontDef read FDescendantFont;
    property FontID: TPDFFontID read FFontID;
  end;

  TPDFTrueTypeFontDef = class(TPDFFontDef)
  private
    FFirstChar: Byte;
    FLastChar: Byte;
    FWidths: string;
    FEncoding: string;
  protected
    function GetDetailString: string; override;
    procedure InitFontDef; override;
  public
    property FirstChar: Byte read FFirstChar write FFirstChar;
    property LastChar: Byte read FLastChar write FLastChar;
    property Encoding: string read FEncoding write FEncoding;
    property Widths: string read FWidths write FWidths;
  end;

  TPDFType0FontDef = class(TPDFFontDef)
  private
    FEncoding: string;
  protected
    function GetDetailString: string; override;
  public
    property Encoding: string read FEncoding write FEncoding;
  end;

  TPDFCID2FontDef = class(TPDFFontDef)
  private
    FWinCharSet: integer;
    FCIDSystemInfo: string;
    FDW: integer;
    FW: string;
  protected
    function GetDetailString: string; override;
    procedure InitFontDef; override;
  public
    property WinCharSet: integer read FWinCharSet write FWinCharSet;
    property CIDSystemInfo: string read FCIDSystemInfo write FCIDSystemInfo;
    property DW: integer read FDW write FDW;
    property W: string read FW write FW;
  end;

  TPDFFontDescriptorDef = class(TObject)
  private
    FAscent: integer;
    FCapHeight: integer;
    FDescent: integer;
    FFlags: integer;
    FFontBBox: TRect;
    FFontName: string;
    FItalicAngle: integer;
    FStemV: integer;
  public
    property Ascent: integer read FAscent write FAscent;
    property CapHeight: integer read FCapHeight write FCapHeight;
    property Descent: integer read FDescent write FDescent;
    property Flags: integer read FFlags write FFlags;
    property FontBBox: TRect read FFontBBox write FFontBBox;
    property FontName: string read FFontName write FFontName;
    property ItalicAngle: integer read FItalicAngle write FItalicAngle;
    property StemV: integer read FStemV write FStemV;
  end;

 
  TCenturyFontDef = class(TPDFTrueTypeFontDef)
  protected
    procedure CreateFontDef; override;
  public
  end;


  TCenturyBoldFontDef = class(TPDFTrueTypeFontDef)
  protected
    procedure CreateFontDef; override;
  public
  end;

  TArialFontDef = class(TPDFTrueTypeFontDef)
  protected
    procedure CreateFontDef; override;
  public
  end;

  TArialBoldFontDef = class(TPDFTrueTypeFontDef)
  protected
    procedure CreateFontDef; override;
  public
  end;

  TCourierFontDef = class(TPDFTrueTypeFontDef)
  protected
    procedure CreateFontDef; override;
  public
  end;

  TCourierBoldFontDef = class(TPDFTrueTypeFontDef)
  protected
    procedure CreateFontDef; override;
  public
  end;

  TMSMincyoFontDef = class(TPDFType0FontDef)
  protected
    procedure CreateFontDef; override;
  public
  end;

  TMSMincyoDFontDef = class(TPDFCID2FontDef)
  protected
    procedure CreateFontDef; override;
  public
  end;

  TMSGothicFontDef = class(TPDFType0FontDef)
  protected
    procedure CreateFontDef; override;
  public
  end;

  TMSGothicDFontDef = class(TPDFCID2FontDef)
  protected
    procedure CreateFontDef; override;
  public
  end;

//-----------------------------2004.02.21---------------------------------------

  TMSSongFontDef = class(TPDFType0FontDef)
  protected
    procedure CreateFontDef; override;
  public
  end;

  TMSSongDFontDef = class(TPDFCID2FontDef)
  protected
    procedure CreateFontDef; override;
  public
  end;

//-----------------------------2004.02.21---------------------------------------

  function CreateFont(FontID: TPDFFontID): TPDFFontDef;

implementation

const
  CRLF = #13#10;

function CreateFont(FontID: TPDFFontID): TPDFFontDef;
begin
  case FontID of
    fiCentury: result := TCenturyFontDef.Create;
    fiCenturyBold: Result := TCenturyBoldFontDef.Create;
    fiArial: Result := TArialFontDef.Create;
    fiArialBold: Result := TArialBoldFontDef.Create;
    fiCourier: Result := TCourierFontDef.Create;
    fiCourierBold: Result := TCourierBoldFontDef.Create;
    fiMincyo: Result := TMSMincyoFontDef.Create;
    fiGothic: Result := TMSGothicFontDef.Create;
    fiSong: Result := TMSSongFontDef.Create;    
  else
    raise Exception.CreateFmt('字体生成错误 (%d)', [ord(FontID)]);
  end;
end;

{ TPDFFontDef }

function TPDFFontDef.GetDetailString: string;
begin
  { virtual method }
  result := '';
end;

procedure TPDFFontDef.InitFontDef;
begin

end;

function TPDFFontDef.GetCharWidth(C: Char): integer;
begin
  if DescendantFont = nil then
    result := FWArray[ord(C)]
  else
    result := FDescendantFont.GetCharWidth(C);
end;

procedure TPDFFontDef.CreateFontDef;
begin

end;

constructor TPDFFontDef.Create;
begin
  FFontDescriptor := nil;
  FDescendantFont := nil;
  CreateFontDef;
  InitFontDef;
end;

{ TPDFTrueTypeFontDef }

procedure TPDFTrueTypeFontDef.InitFontDef;
var
  CurPos, MaxPos: integer;
  i: integer;
  tmpStr: string;
begin

  CurPos := 1;
  i := FirstChar;
  MaxPos := Length(FWidths);
  while CurPos <= MaxPos do
  begin
    if FWidths[CurPos] in ['0'..'9'] then
    begin
      tmpStr := '';
      while (CurPos <= MaxPos) and (FWidths[CurPos] in ['0'..'9']) do
      begin
        tmpStr := tmpStr + FWidths[CurPos];
        inc(CurPos);
      end;
      FWArray[i] := StrToInt(tmpStr);
      inc(i);
    end
    else
      inc(CurPos);
  end;
  FWArray[20] := FWArray[ord(i)];
end;

function TPDFTrueTypeFontDef.GetDetailString: string;
begin
  result := '/Subtype /' + Subtype + CRLF +
            '/BaseFont /' + BaseFont + CRLF +
            '/FirstChar ' + IntToStr(FirstChar) + CRLF +
            '/LastChar ' + IntToStr(LastChar) + CRLF +
            '/Widths ' + Widths + CRLF +
            '/Encoding /' + Encoding  + CRLF;
end;

{ TPDFType0FontDef }
function TPDFType0FontDef.GetDetailString: string;
begin
  result := '/Subtype /' + Subtype + CRLF +
            '/BaseFont /' + BaseFont + CRLF +
            '/Encoding /' + Encoding  + CRLF;
end;

{ TPDFCID2FontDef }
procedure TPDFCID2FontDef.InitFontDef;
var
  CurPos, MaxPos: integer;
  i: integer;
  tmpStr: string;
begin

  MaxPos := Length(FW);
  CurPos := Pos('1 [' , FW) + Length('1 [');
  i := 32;
  while (CurPos <= MaxPos) and (FW[CurPos] <> ']') do
  begin

    if FW[CurPos] in ['0'..'9'] then
    begin
      tmpStr := '';
      while (CurPos <= MaxPos) and (FW[CurPos] in ['0'..'9']) do
      begin
        tmpStr := tmpStr + FW[CurPos];
        inc(CurPos);
      end;
      FWArray[i] := StrToInt(tmpStr);
      inc(i);
    end
    else
      inc(CurPos);
  end;

  MaxPos := Length(FW);
  CurPos := Pos('326 [' , FW) + Length('326 [');
  i := 160;
  while (CurPos <= MaxPos) and (FW[CurPos] <> ']') do
  begin

    if FW[CurPos] in ['0'..'9'] then
    begin
      tmpStr := '';
      while (CurPos <= MaxPos) and (FW[CurPos] in ['0'..'9']) do
      begin
        tmpStr := tmpStr + FW[CurPos];
        inc(CurPos);
      end;
      FWArray[i] := StrToInt(tmpStr);
      inc(i);
    end
    else
      inc(CurPos);
  end;
  FWArray[20] := FWArray[ord(i)];
  FWArray[0] := DW;
end;

function TPDFCID2FontDef.GetDetailString: string;
begin
  result := '/Subtype /' + Subtype + CRLF +
            '/BaseFont /' + BaseFont + CRLF +
            '/WinCharSet /' + IntToStr(WinCharSet)  + CRLF +
            '/CIDSystemInfo <<' + CRLF + CIDSystemInfo + CRLF + '>>' + CRLF +
            '/DW ' + IntToStr(DW) + CRLF +
            '/W ' + W + CRLF;
end;

{ TCenturyFontDef }
procedure TCenturyFontDef.CreateFontDef;
begin
  FFontID := fiCentury;