كيف يتم اضافة فونت Font خارجي ؟ - نسخة قابلة للطباعة

كود :

[list=1]
[*]
procedure TForm1.FormCreate(Sender: TObject) ;[*]begin
[*] 
[*]  AddFontResource('c:\FONTS\MyFont.TTF') ;
[*]  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;
[*]end;
[*] 
[*]{Before application terminates we must remove our font:}
[*]procedure TForm1.FormDestroy(Sender: TObject; var Action: TCloseAction) ;
[*]begin
[*]  RemoveFontResource('C:\FONTS\MyFont.TTF') ;
[*]  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;
[*]end;
[/list]

PHP كود :

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}


function GetFontNameFromFile(FontFile: WideString): string;
//https://stackoverflow.com/questions/13381537/how-do-i-get-the-font-name-from-a-font-file
type
  TGetFontResourceInfoW = function(Name: PWideChar; var BufSize: Cardinal;
    Buffer: Pointer; InfoType: Cardinal): LongBool; stdcall;
var
  GFRI: TGetFontResourceInfoW;
  AddFontRes, I: Integer;
  LogFont: array of TLogFontW;
  lfsz: Cardinal;
  hFnt: HFONT;
begin
  GFRI := GetProcAddress(GetModuleHandle('gdi32.dll'), 'GetFontResourceInfoW');
  if @GFRI = nil then
    raise Exception.Create('GetFontResourceInfoW in gdi32.dll not found.');

  if LowerCase(ExtractFileExt(FontFile)) = '.pfm' then
    FontFile := FontFile + '|' + ChangeFileExt(FontFile, '.pfb');

  AddFontRes := AddFontResourceW(PWideChar(FontFile));
  try
    if AddFontRes > 0 then
      begin
        SetLength(LogFont, AddFontRes);
        lfsz := AddFontRes * SizeOf(TLogFontW);
        if not GFRI(PWideChar(FontFile), lfsz, @LogFont[0], 2) then
          raise Exception.Create('GetFontResourceInfoW failed.');

        AddFontRes := lfsz div SizeOf(TLogFont);
        for I := 0 to AddFontRes - 1 do
          begin
            hFnt := CreateFontIndirectW(LogFont[I]);
            try
              Result := LogFont[I].lfFaceName;
            finally
              DeleteObject(hFnt);
            end;
          end; // for I := 0 to AddFontRes - 1
      end; // if AddFontRes > 0
  finally
    RemoveFontResourceW(PWideChar(FontFile));
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  FontName: string;
  FontHandle: HFONT;
begin
  AddFontResource('Test.TTF');
  FontName := GetFontNameFromFile('Test.TTF');
  FontHandle := CreateFont(-11, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,
    PROOF_QUALITY, DEFAULT_PITCH or FF_DONTCARE, PChar(FontName));
  SendMessage(Button1.Handle, WM_SETFONT, FontHandle, 0);
  InvalidateRect(Button1.Handle, 0 , True);
end;

end.