Font aus Resource laden ohne zwischenspeichern

[turboPASCAL]

Manchmal ist es nötig oder gewollt einen eigenen Font in sein Programm einzubauen.
Mit dieser Version ist es nicht nötig den Font der in der Resourcedatei eingebunden
wurde Temporär auszulagern.

Zur einfachen Verwendung habe ich eine kleine Klasse daraus gemacht die sowohl
in der VCL und nonVCL Programmierung verwendet werden kann.

Da es den Anschein hat das der Resourcencompieler (BRCC32.exe) Probleme hat,
jedenfalls bei meinem Delphi 6, im Resourcenscript (*.rc) mit dem Resourcentyp "FONT"
und eingebundenen Truetypefont ist nun ein neuer Resourcentyp an Bord mit dem Namen "RCFONT".

Delphi-Quellcode:

unit Unit1;

interface

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

const
  RT_RCFONT = 'RCFONT';

type
  TResourceFont = class
  private
    fntBuffer: Pointer;
    fntSize: Integer;
    fntHandle: DWORD;
    fFontLoaded: Boolean;
    function AddFontRes(Instance: DWORD; ResName: PChar): Boolean;
    function DeleteFontRes: Boolean;
  public
    constructor Create(Instance: THandle; ResName: PChar);
    destructor Destroy; override;
    property Loaded: Boolean read fFontLoaded;
  end;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private-Deklarationen }
    ResourceFont: TResourceFont;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

// --- TResourceFont - Class -------------------------------------------------
// Optimiert für nonVCL

constructor TResourceFont.Create(Instance: THandle; ResName: PChar);
begin
  fFontLoaded := AddFontRes(Instance, ResName);
end;

destructor TResourceFont.Destroy;
begin
  DeleteFontRes;
  inherited Destroy;
end;

function TResourceFont.AddFontRes(Instance: DWORD; ResName: PChar): Boolean;
var
  hResInfo: DWORD;
  hResData: DWORD;
  pResource: Pointer;
  ResFontCount: DWord;
begin
  // Font aus Resource laden
  hResInfo := FindResource(Instance, ResName, RT_RCFONT);
  hResData := LoadResource(Instance, hResInfo);
  if hResData <> 0 then
  begin
    // wenn Fnt.-Daten vorhanden weiter   
    fntSize := SizeOfResource(Instance, hResInfo);
    pResource := LockResource(hResData);

    // Fnt.-Daten (die komplette Datei) in den Speicher ("fntBuffer") laden
    GetMem(fntBuffer, fntSize);
    CopyMemory(fntBuffer, pResource, fntSize);
    
    // ein Font mit einem Font
    ResFontCount := 1;

    // Font "systemweit" hinzufügen
    fntHandle := AddFontMemResourceEx(fntBuffer, fntSize, nil, @ResFontCount);

    // Windows mitteilen das Änderungen an den Fonts vorgenommen wurde
    PostMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);

    // Resourcenspeicher freigeben
    UnlockResource(hResData);
  end else
    MessageBox(GetForegroundWindow, PCHAR('Font-Resourse not found.'), '!', MB_ICONWARNING);

  FreeResource(hResData);

  Result := fntHandle <> 0;
end;

function TResourceFont.DeleteFontRes: Boolean;
begin
  Result := False;
  
  if fntHandle <> 0 then
  begin
    FreeMem(fntBuffer, fntSize);
    Result := RemoveFontMemResourceEx(fntHandle);
    SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
  end;
end;

// --- TForm1 ----------------------------------------------------------------

procedure TForm1.FormCreate(Sender: TObject);
begin
  // ResourceFont := TResourceFont.Create(hInstance, 'MEIN_FONT'); //
  ResourceFont := TResourceFont.Create(hInstance, MAKEINTRESOURCE(100));

  if ResourceFont.Loaded then
  begin
    Label1.Font.Name := 'TR';
    Label1.Font.Size := 18;
    Label1.Caption := 'Font from Resource.';
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  ResourceFont.Destroy;
end;

end.