|
- unit utsFontCreatorGDI;
-
- {$IFDEF FPC}
- {$mode objfpc}{$H+}
- {$ENDIF}
-
- interface
-
- uses
- Classes, SysUtils,
- utsFont, utsFontCreator, utsTypes, utsGDI, utsImage, utsContext;
-
- type
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsFontGDI = class(TtsFont)
- private
- fHandle: THandle;
- fMat2: TMat2;
-
- function GetGlyphIndex(const aCharCode: WideChar): Integer;
- procedure GetCharImageAANone(const aDC: HDC; const aCharCode: WideChar; const aImage: TtsImage; const aFormat: TtsFormat);
- procedure GetCharImageAANormal(const aDC: HDC; const aCharCode: WideChar; const aImage: TtsImage; const aFormat: TtsFormat);
- protected
- {%H-}constructor Create(const aHandle: THandle; const aCreator: TtsFontCreator; const aMetric: TtsFontMetric; const aNames: TtsFontNames);
- public
- procedure GetCharImage(const aCharCode: WideChar; const aCharImage: TtsImage; const aFormat: TtsFormat); override;
- function GetGlyphMetrics(const aCharCode: WideChar; out aGlyphOrigin, aGlyphSize: TtsPosition; out aAdvance: Integer): Boolean; override;
-
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsFontRegistration = class(TObject)
- protected
- fIsRegistered: Boolean;
- fFontname: String;
- procedure UnregisterFont; virtual; abstract;
- public
- property IsRegistered: Boolean read fIsRegistered;
- property Fontname: String read fFontname;
-
- destructor Destroy; override;
- end;
-
- TtsFontRegistrationFile = class(TtsFontRegistration)
- private
- fFilename: String;
- protected
- procedure UnregisterFont; override;
- public
- constructor Create(const aFilename: String);
- end;
-
- TtsFontRegistrationStream = class(TtsFontRegistration)
- private
- fHandle: THandle;
- protected
- procedure UnregisterFont; override;
- public
- constructor Create(const aStream: TStream);
- end;
-
- TtsRegistredFontGDI = class(TtsFontGDI)
- private
- fRegistration: TtsFontRegistration;
- protected
- {%H-}constructor Create(const aRegistration: TtsFontRegistration; const aHandle: THandle;
- const aCreator: TtsFontCreator; const aMetric: TtsFontMetric; const aNames: TtsFontNames);
- public
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsFontCreatorGDI = class(TtsFontCreator)
- private
- function CreateFont(const aFontname: String; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing; out aMetric: TtsFontMetric; out aNames: TtsFontNames): THandle;
- public
- function GetFontByName(const aFontname: String; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont; overload; override;
- function GetFontByFile(const aFilename: String; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont; overload; override;
- function GetFontByStream(const aStream: TStream; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont; overload; override;
-
- constructor Create(const aContext: TtsContext);
- destructor Destroy; override;
- end;
-
- implementation
-
- uses
- Math,
- utsUtils;
-
- type
- TT_OFFSET_TABLE = packed record
- uMajorVersion: Word;
- uMinorVersion: Word;
- uNumOfTables: Word;
- uSearchRange: Word;
- uEntrySelector: Word;
- uRangeShift: Word;
- end;
-
-
- TT_TABLE_DIRECTORY = packed record
- TableName: Cardinal; // table name
- uCheckSum: Cardinal; // Check sum
- uOffset: Cardinal; // Offset from beginning of file
- uLength: Cardinal; // length of the table in bytes
- end;
-
-
- TT_NAME_TABLE_HEADER = packed record
- uFSelector: Word; //format selector. Always 0
- uNRCount: Word; //Name Records count
- uStorageOffset: Word; //Offset for strings storage, from start of the table
- end;
-
- TT_NAME_RECORD = packed record
- uPlatformID: Word;
- uEncodingID: Word;
- uLanguageID: Word;
- uNameID: Word;
- uStringLength: Word;
- uStringOffset: Word; //from start of storage area
- end;
-
- const
- NAME_ID_COPYRIGHT = 0;
- NAME_ID_FACE_NAME = 1;
- NAME_ID_STYLE_NAME = 2;
- NAME_ID_FULL_NAME = 4;
-
- PLATFORM_ID_APPLE_UNICODE = 0;
- PLATFORM_ID_MACINTOSH = 1;
- PLATFORM_ID_MICROSOFT = 3;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TTF Utils/////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function SWAPWORD(x: Word): Word;
- begin
- Result := x and $FF;
- Result := Result shl 8;
- Result := Result or (x shr 8);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function SWAPLONG(x: Cardinal): Cardinal;
- begin
- Result := (x and $FF) shl 24;
- x := x shr 8;
-
- Result := Result or ((x and $FF) shl 16);
- x := x shr 8;
-
- Result := Result or ((x and $FF) shl 8);
- x := x shr 8;
-
- Result := Result or x;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function GetTTTableData(Stream: TStream; TableName: Cardinal; pBuff: Pointer; var Size: Integer): Boolean;
- var
- Pos: Int64;
- OffsetTable: TT_OFFSET_TABLE;
- TableDir: TT_TABLE_DIRECTORY;
- Idx: Integer;
- begin
- Result := False;
-
- Pos := Stream.Position;
-
- // Reading table header
- Stream.Read(OffsetTable{%H-}, sizeof(TT_OFFSET_TABLE));
- OffsetTable.uNumOfTables := SWAPWORD(OffsetTable.uNumOfTables);
- OffsetTable.uMajorVersion := SWAPWORD(OffsetTable.uMajorVersion);
- OffsetTable.uMinorVersion := SWAPWORD(OffsetTable.uMinorVersion);
-
- //check is this is a true type font and the version is 1.0
- if (OffsetTable.uMajorVersion <> 1) or (OffsetTable.uMinorVersion <> 0) then
- Exit;
-
- // seaching table with name
- for Idx := 0 to OffsetTable.uNumOfTables -1 do begin
- Stream.Read(TableDir{%H-}, sizeof(TT_TABLE_DIRECTORY));
-
- if (TableName = TableDir.TableName) then begin
- TableDir.uOffset := SWAPLONG(TableDir.uOffset);
- TableDir.uLength := SWAPLONG(TableDir.uLength);
-
- // copying tabledata
- if (pBuff <> nil) and (Size >= Integer(TableDir.uLength)) then begin
- Stream.Seek(TableDir.uOffset, soBeginning);
- Size := Stream.Read(pBuff^, TableDir.uLength);
-
- Result := (Size = Integer(TableDir.uLength));
- end else
-
- begin
- // restoring streamposition
- Stream.Position := Pos;
-
- Size := TableDir.uLength;
- Result := True;
- end;
-
- break;
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function MakeTTTableName(const ch1, ch2, ch3, ch4: Char): Cardinal;
- begin
- Result := ord(ch4) shl 24 or ord(ch3) shl 16 or ord(ch2) shl 8 or ord(ch1);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function GetTTString(pBuffer: Pointer; BufferSize: Integer; NameID, LanguageID: Cardinal; out Text: String): Boolean;
- var
- pActBuffer: pByte;
- ttNTHeader: TT_NAME_TABLE_HEADER;
- ttRecord: TT_NAME_RECORD;
- Idx: Integer;
- Prio: Integer;
-
- procedure ExtractName;
- var
- pTempBuffer: pByte;
- pTemp: pWideChar;
- uStringLengthH2: Word;
-
- procedure SwapText(pText: pWideChar; Length: Word);
- begin
- while Length > 0 do begin
- pWord(pText)^ := SWAPWORD(pWord(pText)^);
- Inc(pText);
- Dec(Length);
- end;
- end;
-
- begin
- Result := True;
-
- ttRecord.uStringLength := SWAPWORD(ttRecord.uStringLength);
- ttRecord.uStringOffset := SWAPWORD(ttRecord.uStringOffset);
-
- uStringLengthH2 := ttRecord.uStringLength shr 1;
-
- pTempBuffer := pBuffer;
- Inc(pTempBuffer, ttNTHeader.uStorageOffset + ttRecord.uStringOffset);
-
- // Unicode
- if ((ttRecord.uPlatformID = PLATFORM_ID_MICROSOFT) and (ttRecord.uEncodingID in [0, 1])) or
- ((ttRecord.uPlatformID = PLATFORM_ID_APPLE_UNICODE) and (ttRecord.uEncodingID > 0)) then begin
- pTemp := tsStrAlloc(uStringLengthH2);
- try
- // uStringLengthH2 * 2 because possible buffer overrun
- Move(pTempBuffer^, pTemp^, uStringLengthH2 * 2);
-
- SwapText(pTemp, uStringLengthH2);
-
- WideCharLenToStrVar(pTemp, uStringLengthH2, Text);
- finally
- tsStrDispose(pTemp);
- end;
- end else
-
- // none unicode
- begin
- SetLength(Text, ttRecord.uStringLength);
- Move(pTempBuffer^, Text[1], ttRecord.uStringLength);
- end;
- end;
-
- begin
- Result := False;
-
- pActBuffer := pBuffer;
-
- Move(pActBuffer^, ttNTHeader{%H-}, sizeof(TT_NAME_TABLE_HEADER));
- inc(pActBuffer, sizeof(TT_NAME_TABLE_HEADER));
-
- ttNTHeader.uNRCount := SWAPWORD(ttNTHeader.uNRCount);
- ttNTHeader.uStorageOffset := SWAPWORD(ttNTHeader.uStorageOffset);
-
- Prio := -1;
-
- for Idx := 0 to ttNTHeader.uNRCount -1 do begin
- Move(pActBuffer^, ttRecord, sizeof(TT_NAME_RECORD));
- Inc(pActBuffer, sizeof(TT_NAME_RECORD));
-
- ttRecord.uNameID := SWAPWORD(ttRecord.uNameID);
-
- if ttRecord.uNameID = NameID then begin
- ttRecord.uPlatformID := SWAPWORD(ttRecord.uPlatformID);
- ttRecord.uEncodingID := SWAPWORD(ttRecord.uEncodingID);
- ttRecord.uLanguageID := SWAPWORD(ttRecord.uLanguageID);
-
- // highest priority
- if (ttRecord.uPlatformID = PLATFORM_ID_MICROSOFT) then begin
- // system language
- if (ttRecord.uLanguageID = languageID) then begin
- if Prio <= 7 then begin
- ExtractName;
-
- Prio := 7;
- end;
- end else
-
- // english
- if (ttRecord.uLanguageID = 1033) then begin
- if Prio <= 6 then begin
- ExtractName;
-
- Prio := 6;
- end;
- end else
-
- // all else
- if Prio <= 5 then begin
- ExtractName;
-
- Prio := 5;
- end;
- end else
-
- // apple unicode
- if (ttRecord.uPlatformID = PLATFORM_ID_APPLE_UNICODE) then begin
- ExtractName;
-
- Prio := 4;
- end else
-
- // macintosh
- if (ttRecord.uPlatformID = PLATFORM_ID_MACINTOSH) then begin
- // english
- if (ttRecord.uLanguageID = 0) then begin
- if Prio <= 3 then begin
- ExtractName;
-
- Prio := 3;
- end;
- end else
-
- // all other
- begin
- ExtractName;
-
- Prio := 2;
- end;
- end else
-
- begin
- if Prio <= 1 then begin
- ExtractName;
-
- Prio := 1;
- end;
- end;
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function GetTTFontFullNameFromStream(Stream: TStream; LanguageID: Cardinal): String;
- var
- TableName: Cardinal;
- Buffer: Pointer;
- BufferSize: Integer;
- begin
- TableName := MakeTTTableName('n', 'a', 'm', 'e');
-
- BufferSize := 0;
- if GetTTTableData(Stream, TableName, nil, BufferSize) then begin
- GetMem(Buffer, BufferSize);
- try
- if GetTTTableData(Stream, TableName, Buffer, BufferSize) then begin
- if not GetTTString(Buffer, BufferSize, NAME_ID_FULL_NAME, LanguageID, Result) then
- if not GetTTString(Buffer, BufferSize, NAME_ID_FACE_NAME, LanguageID, Result) then
- Result := '';
- end;
- finally
- FreeMem(Buffer);
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function GetTTFontFullNameFromFile(const aFilename: String; const aLanguageID: Cardinal): String;
- var
- fs: TFileStream;
- begin
- fs := TFileStream.Create(aFilename, fmOpenRead or fmShareDenyWrite);
- try
- result := GetTTFontFullNameFromStream(fs, aLanguageID);
- finally
- fs.Free;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsFontGDI////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFontGDI.GetGlyphIndex(const aCharCode: WideChar): Integer;
- var
- DC: HDC;
- GCPRes: TGCPResultsW;
- begin
- result := -1;
- DC := CreateCompatibleDC(0);
- try
- SelectObject(DC, fHandle);
- if Assigned(GetCharacterPlacementW) then begin
- FillChar(GCPRes{%H-}, SizeOf(GCPRes), #0);
- GetMem(GCPRes.lpGlyphs, SizeOf(Cardinal));
- try
- GCPRes.lStructSize := SizeOf(GCPRes);
- GCPRes.lpGlyphs^ := 0;
- GCPRes.nGlyphs := 1;
- if (GetCharacterPlacementW(DC, @aCharCode, 1, GCP_MAXEXTENT, @GCPRes, 0) <> GDI_ERROR) and
- (GCPRes.nGlyphs = 1) and
- (GCPRes.lpGlyphs <> nil) then
- begin
- result := GCPRes.lpGlyphs^;
- end;
- finally
- FreeMem(GCPRes.lpGlyphs);
- end;
- end;
- finally
- DeleteDC(DC);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFontGDI.GetCharImageAANone(const aDC: HDC; const aCharCode: WideChar; const aImage: TtsImage; const aFormat: TtsFormat);
- var
- gm: TGlyphMetrics;
- GlyphIndex, srcW, srcX, w, h, x, y: Integer;
- Size, OutlineRes: Cardinal;
- Buffer, pSrc, pDst: PByte;
-
- procedure ExpandByte;
- var
- i, cnt, srcCnt: Integer;
- c: TtsColor4f;
- begin
- srcCnt := min(8, srcX);
- cnt := min(8, x);
- for i := 1 to cnt do begin
- c := tsColor4f(1, 1, 1, 1);
- if ((pSrc^ and $80) > 0) then
- c.a := 1.0
- else
- c.a := 0.0;
- pSrc^ := (pSrc^ and not $80) shl 1;
- tsFormatMap(aFormat, pDst, c);
- end;
- dec(srcX, srcCnt);
- dec(x, cnt);
- inc(pSrc);
- end;
-
- begin
- if (fMat2.eM11.value <> 1) then
- raise EtsException.Create('invalid value');
- FillChar(gm{%H-}, SizeOf(gm), #0);
-
- GlyphIndex := GetGlyphIndex(aCharCode);
- if (GlyphIndex < 0) then
- exit;
-
- Size := GetGlyphOutlineA(aDC, GlyphIndex, GGO_BITMAP or GGO_GLYPH_INDEX, @gm, 0, nil, @fMat2);
- if (Size = GDI_ERROR) or (Size = 0) then
- exit;
-
- GetMem(Buffer, Size);
- try
- OutlineRes := GetGlyphOutlineA(aDC, GlyphIndex, GGO_BITMAP or GGO_GLYPH_INDEX, @gm, Size, Buffer, @fMat2);
- if (OutlineRes = GDI_ERROR) then
- exit;
- w := gm.gmBlackBoxX;
- h := gm.gmBlackBoxY;
- srcW := (Integer(Size) div h) * 8;
- if (w <= 0) or (h <= 0) then
- exit;
- aImage.CreateEmpty(aFormat, w, h);
- pSrc := Buffer;
- for y := 0 to h-1 do begin
- pDst := aImage.Scanline[y];
- srcX := srcW;
- x := w;
- while (srcX > 0) do
- ExpandByte;
- end;
- finally
- Freemem(Buffer);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFontGDI.GetCharImageAANormal(const aDC: HDC; const aCharCode: WideChar; const aImage: TtsImage; const aFormat: TtsFormat);
- var
- gm: TGlyphMetrics;
- OutlineRes: DWORD;
- GlyphIndex, tmp, Spacer, x, y, w, h: Integer;
- Size: Cardinal;
- Buffer, pSrc, pDst: PByte;
-
- procedure CopyPixel;
- var
- i: Integer;
- tmp, cnt: Cardinal;
- c: TtsColor4f;
- begin
- cnt := min(x, fMat2.eM11.value);
- tmp := 0;
- for i := 0 to cnt-1 do begin
- tmp := tmp + pSrc^;
- inc(pSrc, 1);
- end;
- dec(x, cnt);
- c := tsColor4f(1, 1, 1, tmp / $40);
- tsFormatMap(aFormat, pDst, c);
- end;
-
- begin
- FillChar(gm{%H-}, SizeOf(gm), #0);
-
- GlyphIndex := GetGlyphIndex(aCharCode);
- if (GlyphIndex < 0) then
- exit;
-
- Size := GetGlyphOutlineA(aDC, GlyphIndex, GGO_GRAY8_BITMAP or GGO_GLYPH_INDEX, @gm, 0, nil, @fMat2);
- if (Size = GDI_ERROR) or (Size = 0) then
- exit;
-
- GetMem(Buffer, Size);
- try
- OutlineRes := GetGlyphOutlineA(aDC, GlyphIndex, GGO_GRAY8_BITMAP or GGO_GLYPH_INDEX, @gm, Size, Buffer, @fMat2);
- if (OutlineRes = GDI_ERROR) then
- exit;
- w := Integer(gm.gmBlackBoxX) div fMat2.eM11.value;
- h := gm.gmBlackBoxY;
- tmp := Integer(gm.gmBlackBoxX) mod fMat2.eM11.value;
- if (tmp <> 0) then
- w := w + fMat2.eM11.value - tmp;
- if (w <= 0) or (h <= 0) then
- exit;
-
- // spacer
- Spacer := gm.gmBlackBoxX mod 4;
- if (Spacer <> 0) then
- Spacer := 4 - Spacer;
-
- // copy image
- aImage.CreateEmpty(aFormat, w, h);
- pSrc := Buffer;
- for y := 0 to h-1 do begin
- pDst := aImage.Scanline[y];
- x := gm.gmBlackBoxX;
- while (x > 0) do
- CopyPixel;
- inc(pSrc, Spacer);
- end;
- finally
- FreeMem(Buffer);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsFontGDI.Create(const aHandle: THandle; const aCreator: TtsFontCreator; const aMetric: TtsFontMetric; const aNames: TtsFontNames);
- begin
- inherited Create(aCreator, aMetric, aNames);
- FillChar(fMat2, SizeOf(fMat2), #0);
- fMat2.eM11.value := 1;
- fMat2.eM22.value := 1;
- fHandle := aHandle;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFontGDI.GetCharImage(const aCharCode: WideChar; const aCharImage: TtsImage; const aFormat: TtsFormat);
- var
- DC: HDC;
- begin
- DC := CreateCompatibleDC(0);
- try
- SelectObject(DC, fHandle);
- case Metric.AntiAliasing of
- tsAANone:
- GetCharImageAANone(DC, aCharCode, aCharImage, aFormat);
- tsAANormal:
- GetCharImageAANormal(DC, aCharCode, aCharImage, aFormat);
- end;
- finally
- DeleteDC(DC);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFontGDI.GetGlyphMetrics(const aCharCode: WideChar; out aGlyphOrigin, aGlyphSize: TtsPosition; out aAdvance: Integer): Boolean;
- var
- GlyphIndex: Integer;
- DC: HDC;
- gm: TGlyphMetrics;
- Size: Cardinal;
- begin
- result := false;
-
- aGlyphOrigin.x := 0;
- aGlyphOrigin.x := 0;
- aGlyphSize.x := 0;
- aGlyphSize.y := 0;
- aAdvance := 0;
-
- GlyphIndex := GetGlyphIndex(aCharCode);
- if (GlyphIndex < 0) then
- exit;
-
- DC := CreateCompatibleDC(0);
- try
- SelectObject(DC, fHandle);
- case Metric.AntiAliasing of
- tsAANone: begin
- Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_BITMAP or GGO_GLYPH_INDEX, @gm, 0, nil, @fMat2);
- end;
- tsAANormal: begin
- Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_GRAY8_BITMAP or GGO_GLYPH_INDEX, @gm, 0, nil, @fMat2);
- end;
- else
- Size := GDI_ERROR;
- end;
-
- if (Size = GDI_ERROR) then
- Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_METRICS or GGO_GLYPH_INDEX, @gm, 0, nil, @fMat2);
-
- if (Size <> GDI_ERROR) then begin
- aGlyphOrigin.x := gm.gmptGlyphOrigin.x;
- aGlyphOrigin.y := gm.gmptGlyphOrigin.y;
- aGlyphSize.x := gm.gmBlackBoxX;
- aGlyphSize.y := gm.gmBlackBoxY;
- aAdvance := gm.gmCellIncX;
- result := true;
- end;
- finally
- DeleteDC(DC);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsFontGDI.Destroy;
- begin
- DeleteObject(fHandle);
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsFontRegistration///////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsFontRegistration.Destroy;
- begin
- if fIsRegistered then
- UnregisterFont;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsFontRegistrationFile///////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFontRegistrationFile.UnregisterFont;
- begin
- if Assigned(RemoveFontResourceExA) then
- RemoveFontResourceExA(PAnsiChar(AnsiString(fFilename)), 0, nil)
- else if Assigned(RemoveFontResourceA) then
- RemoveFontResourceA(PAnsiChar(AnsiString(fFilename)));
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsFontRegistrationFile.Create(const aFilename: String);
- var
- lang: AnsiString;
- begin
- inherited Create;
- fFilename := aFilename;
-
- // get Fontname
- SetLength(lang, 4);
- GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_ILANGUAGE, @lang[1], 4);
- fFontname := GetTTFontFullNameFromFile(aFilename, StrToInt('$' + String(lang)));
-
- // register font
- if Assigned(AddFontResourceExA) then
- fIsRegistered := (AddFontResourceExA(PAnsiChar(AnsiString(fFilename)), 0, nil) > 0)
- else if Assigned(AddFontResourceA) then
- fIsRegistered := (AddFontResourceA(PAnsiChar(AnsiString(fFilename))) > 0)
- else
- fIsRegistered := false;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsFontRegistrationStream/////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFontRegistrationStream.UnregisterFont;
- begin
- if Assigned(RemoveFontMemResourceEx) then
- RemoveFontMemResourceEx(fHandle);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsFontRegistrationStream.Create(const aStream: TStream);
- var
- lang: AnsiString;
- ms: TMemoryStream;
- cnt: DWORD;
- begin
- inherited Create;
- fHandle := 0;
- fIsRegistered := false;
-
- // get Fontname
- SetLength(Lang, 4);
- GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_ILANGUAGE, @lang[1], 4);
- fFontname := GetTTFontFullNameFromStream(aStream, StrToInt('$' + String(Lang)));
-
- // register font
- ms := TMemoryStream.Create;
- try
- ms.CopyFrom(aStream, 0);
- if Assigned(AddFontMemResourceEx) then
- fHandle := AddFontMemResourceEx(ms.Memory, ms.Size, nil, @cnt);
- fIsRegistered := (fHandle > 0);
- finally
- FreeAndNil(ms);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsRegistredFontGDI///////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsRegistredFontGDI.Create(const aRegistration: TtsFontRegistration; const aHandle: THandle;
- const aCreator: TtsFontCreator; const aMetric: TtsFontMetric; const aNames: TtsFontNames);
- begin
- inherited Create(aHandle, aCreator, aMetric, aNames);
- fRegistration := aRegistration;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsRegistredFontGDI.Destroy;
- begin
- FreeAndNil(fRegistration);
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsFontCreatorGDI/////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFontCreatorGDI.CreateFont(const aFontname: String; const aSize: Integer; const aStyle: TtsFontStyles;
- const aAntiAliasing: TtsAntiAliasing; out aMetric: TtsFontMetric; out aNames: TtsFontNames): THandle;
- var
- LogFont: TLogFontA;
- i: Integer;
- DC: HDC;
- TableName, BufSize: Cardinal;
- Buffer: PByte;
- Lang, tmpName: AnsiString;
- TextMetric: TTextMetricW;
- OutlineMetric: TOutlineTextmetricW;
-
- function _(e: Boolean; a, b: Integer): Integer;
- begin
- if e then
- result := a
- else
- result := b;
- end;
-
- begin
- FillChar(aMetric{%H-}, SizeOf(aMetric), #0);
- aMetric.Size := aSize;
- aMetric.Style := aStyle;
- aMetric.AntiAliasing := aAntiAliasing;
- aNames.Fontname := aFontname;
-
- // prepare font attribs
- FillChar(LogFont{%H-}, SizeOf(LogFont), #0);
- tmpName := AnsiString(aFontname);
- for i := 1 to min(Length(aFontname), Length(LogFont.lfFaceName)) do
- LogFont.lfFaceName[i-1] := tmpName[i];
- LogFont.lfCharSet := DEFAULT_CHARSET;
- LogFont.lfHeight := -aSize;
- LogFont.lfWeight := _(tsStyleBold in aStyle, FW_BOLD, FW_NORMAL);
- LogFont.lfItalic := _(tsStyleItalic in aStyle, 1, 0);
- LogFont.lfUnderline := _(tsStyleUnderline in aStyle, 1, 0);
- LogFont.lfQuality := _(aAntiAliasing = tsAANormal, ANTIALIASED_QUALITY, NONANTIALIASED_QUALITY);
-
- result := CreateFontIndirectA(LogFont);
- DC := CreateCompatibleDC(0);
- try try
- SelectObject(DC, result);
- TableName := MakeTTTableName('n', 'a', 'm', 'e');
- BufSize := GetFontData(DC, TableName, 0, nil, 0);
- if (BufSize <> GDI_ERROR) then begin
- GetMem(Buffer, BufSize);
- try
- if (GetFontData(DC, TableName, 0, Buffer, BufSize) <> GDI_ERROR) then begin
- SetLength(Lang, 4);
- GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_ILANGUAGE, @Lang[1], 4);
-
- GetTTString(Buffer, BufSize, NAME_ID_COPYRIGHT, StrToInt('$' + String(Lang)), aNames.Copyright);
- GetTTString(Buffer, BufSize, NAME_ID_FACE_NAME, StrToInt('$' + String(Lang)), aNames.FaceName);
- GetTTString(Buffer, BufSize, NAME_ID_STYLE_NAME, StrToInt('$' + String(Lang)), aNames.StyleName);
- GetTTString(Buffer, BufSize, NAME_ID_FULL_NAME, StrToInt('$' + String(Lang)), aNames.FullName);
- end;
- finally
- FreeMem(Buffer);
- end;
- end;
-
- if GetTextMetricsW(DC, TextMetric{%H-}) then begin
- aMetric.Ascent := TextMetric.tmAscent;
- aMetric.Descent := TextMetric.tmDescent;
- aMetric.ExternalLeading := TextMetric.tmExternalLeading;
- aMetric.DefaultChar := TextMetric.tmDefaultChar;
- end;
-
- if (GetOutlineTextMetricsW(DC, SizeOf(OutlineMetric), OutlineMetric{%H-}) > 0) then begin
- aMetric.UnderlinePos := OutlineMetric.otmsUnderscorePosition;
- aMetric.UnderlineSize := Min(1, OutlineMetric.otmsUnderscoreSize);
- aMetric.StrikeoutPos := OutlineMetric.otmsStrikeoutPosition;
- aMetric.StrikeoutSize := Min(1, OutlineMetric.otmsStrikeoutSize);
- end;
- except
- DeleteObject(result);
- result := 0;
- end;
- finally
- DeleteDC(DC);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFontCreatorGDI.GetFontByName(const aFontname: String; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont;
- var
- handle: THandle;
- metric: TtsFontMetric;
- names: TtsFontNames;
- begin
- handle := CreateFont(aFontname, aSize, aStyle, aAntiAliasing, metric, names);
- if (handle = 0) then
- raise EtsException.Create('unable to create font from name: ' + aFontname);
- result := TtsFontGDI.Create(handle, self, metric, names);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFontCreatorGDI.GetFontByFile(const aFilename: String; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont;
- var
- reg: TtsFontRegistrationFile;
- handle: THandle;
- metric: TtsFontMetric;
- names: TtsFontNames;
- begin
- reg := TtsFontRegistrationFile.Create(aFilename);
- try
- if not reg.IsRegistered then
- raise EtsException.Create('unable to register font file: ' + aFilename);
- handle := CreateFont(reg.Fontname, aSize, aStyle, aAntiAliasing, metric, names);
- if (handle = 0) then
- raise EtsException.Create('unable to create font from file: ' + aFilename);
- except
- FreeAndNil(reg);
- raise;
- end;
- result := TtsRegistredFontGDI.Create(reg, handle, self, metric, names);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFontCreatorGDI.GetFontByStream(const aStream: TStream; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont;
- var
- reg: TtsFontRegistrationStream;
- handle: THandle;
- metric: TtsFontMetric;
- names: TtsFontNames;
- begin
- reg := TtsFontRegistrationStream.Create(aStream);
- if not reg.IsRegistered then
- raise EtsException.Create('unable to register font from stream');
- handle := CreateFont(reg.Fontname, aSize, aStyle, aAntiAliasing, metric, names);
- if (handle = 0) then
- raise EtsException.Create('unable to create font from stream: ' + reg.Fontname);
- result := TtsRegistredFontGDI.Create(reg, handle, self, metric, names);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsFontCreatorGDI.Create(const aContext: TtsContext);
- begin
- inherited Create(aContext);
- InitGDI;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsFontCreatorGDI.Destroy;
- begin
- inherited Destroy; // first free all fonts (managed by parent class)
- QuitGDI;
- end;
-
- end.
|