vpdffonts.pas

生成PDF文档的控件

{*******************************************************}
{                                                       }
{       This unit is part of the VISPDF VCL library.    }
{       Written by R.Husske - ALL RIGHTS RESERVED.      }
{                                                       }
{       Copyright (C) 2000-2009, www.vispdf.com         }
{                                                       }
{       e-mail: [e-mail]                      }
{       http://www.vispdf.com                           }
{                                                       }
{*******************************************************}

unit VPDFFonts;

interface

uses
  Windows, SysUtils, Classes, Graphics, Math, VPDFFontRecords;

{$I VisPDFLib.inc }

type
  CDescript = record
    Index: Word;
    Width: LongWord;
  end;

  TCDescript = array of CDescript;

  PCDescript = ^TCDescript;

  TTrueTypeTables = class
  private
    MaxGlyf: Integer;
    Links: TLinkArray;
    FCharSet: Integer;
    CapsuleCount: VISPDFULONG;
    BreaksPresent: Boolean;
    GlyfRoot: PGlyfRecord;
    IsMonoSpaced: Boolean;
    FFontName: TFontname;
    FFontStyle: TFontStyles;
    CmapHeader: CMAPTableHeader;
    CmapTable: CmapTableType;
    CMAPTable4: CmapFormat4;
    CVTTable: LinearTable;
    FPGMTable: LinearTable;
    LocaTable: LinearTable;
    PrepTable: LinearTable;
    HmtxTable: WordLinearTable;
    HeadTable: HeadTableType;
    HheaTable: HheaTableType;
    MaxpTable: MaxpTableType;
    LongCmap: array of byte;
    HandleCharsKit: array of TGlyfCharsKit;
    GlyfStack: array[0..255] of Pointer;
    SymbolSelection: array of GlyphCodes;
  protected
    procedure CompressGlyfTable(FullEscort: boolean);
    procedure GetSourceTables(Extension: boolean);
    procedure LoadCMAPTable(HDescript: HDC; Extension: boolean);
    procedure LoadPostTable(HDescript: HDC);
    procedure LoadGlyphTable(HDescript: HDC);
    procedure CreateFontTable(Name: LongWord; var Table: TVPDFFontTable);
    procedure MoveRange(var SegmentMapping: array of DeltaValues; ItemIndex:
      Integer);
    procedure LoadStructTable(HDescript: HDC; TableName: Cardinal; EmbTable:
      Pointer);
    procedure LoadWordTable(HDescript: HDC; TableName: Cardinal; var
      EmbTable:
      WordLinearTable);
    procedure LoadLinearTable(HDescript: HDC; TableName: Cardinal; var
      EmbTable:
      LinearTable);
    procedure ExtractFontCodes(Buffer: PWord; BufferLength: Word);
    function MarkUsedGlyf(GlyfCode: VISPDFUSHORT): word;
    procedure GetGLYF(TempStream: TStream);
    procedure GetHMTX(TempStream: TStream);
    procedure GetLOCA(TempStream: TStream);
    procedure GetFullCMAP(TempStream: TStream);
    procedure MergeCompositLinks(GlyfLink: PGlyfRecord);
    procedure EditMonopictedLinks(GlyfLink: PGlyfRecord; SLinks:
      TLinkArray);
    function DoubleSwap(L: LongWord): LongWord;
    function GetGlyfCode(GyfNumber: Word): Word;
    function Checksum(TableBuffer: PVISPDFULONG; Length: VISPDFULONG): VISPDFULONG;
    function ConvertToUnicode(ID: Word): Word;
    function GetCodepage(Charset: Byte): Cardinal;
    procedure SaveWideCharFont(Stream: TStream);
    procedure FreeTempTables;
    procedure QSort(var Arr: array of GlyphCodes; BegIndex, EndIndex:
      Integer;
      FromFirstItem: boolean);
  public
    function ConvertFromUnicode(ID: Word): Word;
    procedure CharacterDescription(CDArray: PCDescript; FontName: TFontname;
      FontStyle: TFontStyles);
    procedure GetFontEnsemble(FontName: TFontname; FontStyle: TFontStyles;
      OutStream: Tstream; var CharsetBuffer: array of word; CharBufferLen:
      Word);
    procedure GetFontLongEnsemble(FontName: TFontname; FontStyle:
      TFontStyles;
      OutStream: Tstream; var CharsetBuffer: array of word; CharBufferLen:
      Word);
    property CharSet: Integer read FCharSet write FCharSet;
  end;

implementation

procedure TTrueTypeTables.LoadCMAPTable(HDescript: HDC; Extension: boolean);
var
  I: Integer;
  PCMap: Pointer;
  DoubleArrLen, ArrayLen, SegCount: Integer;
  CmapName: Cardinal;
  TableSize: Cardinal;
  TabOffset: Integer;
  sTablesCount: Integer;
  CmapStream: TMemoryStream;
  sPlatform, sEncoding: VISPDFUSHORT;
begin
  CmapName := DoubleSwap(1668112752);
  CmapStream := TMemoryStream.Create;
  try
    TabOffset := 0;
    TableSize := GetFontData(HDescript, CmapName, 0, nil, 0);
    CmapStream.SetSize(TableSize);
    if GetFontData(HDescript, CmapName, 0, CmapStream.Memory, TableSize) =
      GDI_ERROR then raise Exception.Create(CLCT);
    if Extension then
    begin
      SetLength(LongCmap, TableSize);
      PCMap := @LongCmap[0];
      CmapStream.Read(PCMap^, TableSize);
      CmapStream.Position := 0;
    end;
    CmapStream.Read(CmapHeader, SizeOf(CmapHeader));
    sTablesCount := Swap(CmapHeader.NumTables);
    for I := 1 to sTablesCount do
    begin
      CmapStream.Read(CmapTable, sizeof(CmapTable));
      sPlatform := Swap(CmapTable.PlatformID);
      sEncoding := Swap(CmapTable.EncodingID);
      if (sPlatform = 3) and (sEncoding = 0) then
        TabOffset := DoubleSwap(CmapTable.TableOffset);
      if (sPlatform = 3) and (sEncoding = 1) then
      begin
        TabOffset := DoubleSwap(CmapTable.TableOffset);
        Break;
      end;
    end;
    if CmapStream.Seek(TabOffset, soFromBeginning) <> (TabOffset) then
      raise exception.Create(CLCT);
    CmapStream.Read(CMAPTable4, 14);
    SegCount := Swap(CMAPTable4.segCountX2) shr 1;
    ArrayLen := SegCount;
    SetLength(CMAPTable4.EndCount, ArrayLen);
    SetLength(CMAPTable4.StartCount, ArrayLen);
    SetLength(CMAPTable4.IDDelta, ArrayLen);
    SetLength(CMAPTable4.IDRangeOffset, ArrayLen);
    DoubleArrLen := ArrayLen * 2;
    CmapStream.Read(CMAPTable4.EndCount[0], DoubleArrLen);
    for I := 0 to ArrayLen - 1 do
      CMAPTable4.EndCount[i] := Swap(CMAPTable4.EndCount[i]);
    CmapStream.Read(CMAPTable4.ReservedPad, 2);
    CmapStream.Read(CMAPTable4.StartCount[0], DoubleArrLen);
    for I := 0 to ArrayLen - 1 do
      CMAPTable4.StartCount[i] := Swap(CMAPTable4.StartCount[i]);
    CmapStream.Read(CMAPTable4.IDDelta[0], DoubleArrLen);
    for I := 0 to ArrayLen - 1 do
      CMAPTable4.IDDelta[i] := Swap(CMAPTable4.IDDelta[i]);
    CmapStream.Read(CMAPTable4.IDRangeOffset[0], DoubleArrLen);
    for I := 0 to ArrayLen - 1 do
      CMAPTable4.IDRangeOffset[i] := Swap(CMAPTable4.IDRangeOffset[i]);
    ArrayLen := ((Swap(CMAPTable4.length) shr 1) - 8 - 4 * ArrayLen);
    SetLength(CMAPTable4.GlyphIdArray, ArrayLen + 1);
    CmapStream.Read(CMAPTable4.GlyphIdArray[0], (ArrayLen + 1) * 2);
    for I := 0 to ArrayLen do
      CMAPTable4.GlyphIdArray[i] := Swap(CMAPTable4.GlyphIdArray[i]);
  finally
    CmapStream.Free;
  end;
end;

procedure TTrueTypeTables.LoadPostTable(HDescript: HDC);
var
  ConvName: Cardinal;
  TableSize: Cardinal;
  FixPitch: LongInt;
  TblStream: TMemoryStream;
begin
  ConvName := DoubleSwap(1886352244);
  TblStream := TMemoryStream.Create;
  try
    TableSize := GetFontData(HDescript, ConvName, 0, nil, 0);
    TblStream.SetSize(TableSize);
    if GetFontData(HDescript, ConvName, 0, TblStream.Memory, TableSize) =
      GDI_ERROR then raise Exception.Create(CLPT);
    TblStream.Position := TblStream.Position + 12;
    TblStream.Read(FixPitch, 4);
    IsMonoSpaced := (FixPitch <> 0);
  finally
    TblStream.Free;
  end;
end;

procedure TTrueTypeTables.LoadLinearTable(HDescript: HDC; TableName: Cardinal;
  var EmbTable: LinearTable);
var
  ConvName: Cardinal;
  TableSize: Cardinal;
  TblStream: TMemoryStream;
begin
  ConvName := DoubleSwap(TableName);
  TblStream := TMemoryStream.Create;
  try
    TableSize := GetFontData(HDescript, ConvName, 0, nil, 0);
    TblStream.SetSize(TableSize);
    if GetFontData(HDescript, ConvName, 0, TblStream.Memory, TableSize) =
      GDI_ERROR then EmbTable.IsPresent := false
    else
    begin
      EmbTable.IsPresent := true;
      EmbTable.TableLength := TableSize;
      SetLength(EmbTable.Item, TableSize);
      TblStream.Read(EmbTable.Item[0], TableSize);
    end;
  finally
    TblStream.Free;
  end;
end;

procedure TTrueTypeTables.LoadStructTable(HDescript: HDC; TableName: Cardinal;
  EmbTable: Pointer);
var
  ConvName: Cardinal;
  TableSize: Cardinal;
  TblStream: TMemoryStream;
begin
  ConvName := DoubleSwap(TableName);
  TblStream := TMemoryStream.Create;
  try
    TableSize := GetFontData(HDescript, ConvName, 0, nil, 0);
    TblStream.SetSize(TableSize);
    if GetFontData(HDescript, ConvName, 0, TblStream.Memory, TableSize) =
      GDI_ERROR then raise Exception.Create(CLRT);
    TblStream.Read(EmbTable^, TableSize);
  finally
    TblStream.Free;
  end;
end;

procedure TTrueTypeTables.LoadWordTable(HDescript: HDC; TableName: Cardinal; var
  EmbTable: WordLinearTable);
var
  ConvName: Cardinal;
  TableSize: Cardinal;
  TblStream: TMemoryStream;
begin
  ConvName := DoubleSwap(TableName);
  TblStream := TMemoryStream.Create;
  try
    TableSize := GetFontData(HDescript, ConvName, 0, nil, 0);
    TblStream.SetSize(TableSize);
    if GetFontData(HDescript, ConvName, 0, TblStream.Memory, TableSize) =
      GDI_ERROR then EmbTable.IsPresent := false
    else
    begin
      EmbTable.IsPresent := true;
      EmbTable.TableLength := TableSize;
      SetLength(EmbTable.Item, Trunc(TableSize / 2 + 0.5));
      TblStream.Read(EmbTable.Item[0], TableSize);
    end;
  finally
    TblStream.Free;
  end;
end;

procedure TTrueTypeTables.LoadGlyphTable(HDescript: HDC);
var
  I: Integer;
  LocaIndex: SmallInt;
  GlyphCount: Integer;
  ContoursSize: longint;
  XLongVector: VISPDFULONG;
  XShortVector: VISPDFUSHORT;
  ConvName: Cardinal;
  TableSize: Cardinal;
  TblStream: TMemoryStream;
  GlyfPointer, GlyfCapsule: PGlyfRecord;
begin
  ConvName := DoubleSwap(1735162214);
  TblStream := TMemoryStream.Create;
  try
    TableSize := GetFontData(HDescript, ConvName, 0, nil, 0);
    TblStream.SetSize(TableSize);
    if GetFontData(HDescript, ConvName, 0, TblStream.Memory, TableSize) =
      GDI_ERROR then
      raise Exception.Create(CLGT);
    New(GlyfRoot);
    TblStream.Position := 0;
    GlyfPointer := GlyfRoot;
    GlyphCount := MaxpTable.numGlyphs;
    for I := 1 to GlyphCount do
    begin
      with LocaTable do
      begin
        LocaIndex := Swap(HeadTable.IndexToLocFormat);
        if LocaIndex = 1 then
        begin
          XLongVector := Item[I * 4] shl 24 + Item[I * 4 + 1] shl 16 +
            Item[I * 4
            + 2] shl 8 + Item[I * 4 + 3];
          ContoursSize := XLongVector - Item[(I - 1) * 4] shl 24 -
            Item[(I - 1)
            * 4 + 1] shl 16 - Item[(I - 1) * 4 + 2] shl 8 - Item[(I
            - 1) * 4 +
            3];
        end
        else
          ContoursSize := 2 * (Item[I * 2] shl 8 + Item[I * 2 + 1] -
            Item[(I - 1)
            * 2] shl 8 - Item[(I - 1) * 2 + 1]);
        if ContoursSize <> 0 then
          GetMem(GlyfPointer.Curves, ContoursSize)
        else GlyfPointer.Curves := nil;
        GlyfPointer.NumberOfContours := I;
        GlyfPointer.RecordSize := ContoursSize;
        GlyfPointer.IsTagged := false;
        if LocaIndex = 1 then
        begin
          XLongVector := Item[(I - 1) * 4] shl 24 + Item[(I - 1) * 4 +
            1] shl 16
            + Item[(I - 1) * 4 + 2] shl 8 + Item[(I - 1) * 4 + 3];
          TblStream.Seek(XLongVector, soFromBeginning);
        end
        else
        begin
          XShortVector := Item[(I - 1) * 2] shl 8 + Item[(I - 1) * 2 +
            1];
          TblStream.Seek(2 * XShortVector, soFromBeginning);
        end;
        TblStream.Read(GlyfPointer.Curves^, ContoursSize);
        if I <> GlyphCount then
        begin
          New(GlyfCapsule);
          GlyfCapsule.NextGlyph := nil;
          GlyfCapsule.Curves := nil;
          GlyfPointer.Hidden := true;
          GlyfPointer.NextGlyph := GlyfCapsule;
          GlyfPointer := GlyfCapsule;
        end
        else GlyfPointer := nil;
      end;
    end;
  finally
    TblStream.Free;
  end;
end;

procedure TTrueTypeTables.GetSourceTables(Extension: boolean);
var
  HDescript: HDC;
  LFont: TLogFont;
  HandleObj: THandle;
  TxtMetrics: TTextMetric;
begin
  HDescript := CreateCompatibleDC(0);
  try
    FillChar(LFont, SizeOf(LFont), 0);
    LFont.lfWidth := 0;
    LFont.lfHeight := -10;
    LFont.lfEscapement := 0;
    LFont.lfOrientation := 0;
    if fsBold in FFontStyle then LFont.lfWeight := FW_BOLD
    else LFont.lfWeight := FW_NORMAL;
    LFont.lfCharSet := DEFAULT_CHARSET;
    LFont.lfItalic := Byte(fsItalic in FFontStyle);
    LFont.lfUnderline := Byte(fsUnderline in FFontStyle);
    LFont.lfStrikeOut := Byte(fsStrikeOut in FFontStyle);
    StrPCopy(LFont.lfFaceName, FFontName);
    LFont.lfQuality := DEFAULT_QUALITY;
    LFont.lfOutPrecision := OUT_DEFAULT_PRECIS;
    LFont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
    LFont.lfPitchAndFamily := DEFAULT_PITCH;
    HandleObj := CreateFontIndirect(LFont);
    try
      SelectObject(HDescript, HandleObj);
      GetTextMetrics(HDescript, TxtMetrics);
      LoadCMAPTable(HDescript, Extension);
      LoadPostTable(HDescript);
      LoadWordTable(HDescript, 1752003704, HmtxTable);
      LoadLinearTable(HDescript, 1668707360, CVTTable);
      LoadLinearTable(HDescript, 1718642541, FPGMTable);
      LoadLinearTable(HDescript, 1819239265, LocaTable);
      LoadStructTable(HDescript, 1751474532, @HeadTable);
      LoadStructTable(HDescript, 1751672161, @HheaTable);
      LoadStructTable(HDescript, 1835104368, @MaxpTable);
      MaxpTable.NumGlyphs := Swap(MaxpTable.NumGlyphs);
      LoadLinearTable(HDescript, 1886545264, PrepTable);
      LoadGlyphTable(HDescript);
    finally