Dynamiczne rejestrowanie własnych fontów – katorgi ciąg dalszy

Znów mam problem z rejestrowaniem fontów – tym razem nie chodzi o ich dodawanie z zewnętrznych plików (tamto śmiga), a z ładowaniem z zasobów aplikacji. Już sam nie pamiętam czy wsześniej działało czy nie, nieważne.

Mam plik fonts.lrs, w którym dodane są trzy fonty. Plik ten dodaję do projektu w sekcji initialization:

initialization
begin
  {$INCLUDE resources\fonts.lrs}
end;

Wszystko gra. Dodaję nagłówki funkcji AddFontMemResourceEx i RemoveFontMemResourceEx manualnie, bo ich brakuje:

function AddFontMemResourceEx(pbFont: PVOID; cbFont: DWORD; pdv: PVOID; pcFonts: LPDWORD): HANDLE; external 'gdi32.dll' name 'AddFontMemResourceEx';
function RemoveFontMemResourceEx(fh: HANDLE): LongBool; external 'gdi32.dll' name 'RemoveFontMemResourceEx';

Tu też wszystko gra. Dla testu ładuję jeden font. Inicjalizacja zmiennych:

var
  FontHandle: THandle = 0;
  FontCount: UInt32 = 0;

Teraz procedura ładująca font z zasobów – ona nie działa prawidłowo. Poniższy sposób znalazłem na forum Lazarusa (jeśli chodzi o wykorzystanie klasy TLazarusResourceStream i takie jak niżej przekazanie wartości z właściwości strumienia do parametrów funkcji), więc powinien działać:

procedure LoadFont(const AResourceName, AResourceType: String);
var
  LStream: TLazarusResourceStream;
begin
  LStream := TLazarusResourceStream.Create(AResourceName, PChar(AResourceType));
  try
    FontHandle := AddFontMemResourceEx(LStream.Memory, LStream.Size, nil, @FontCount);

    if (FontHandle = 0) or (FontCount = 0) then
      Exit;
  finally
    LStream.Free();
  end;

  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;

Funkcja AddFontMemResourceEx zwraca 0, więc nie udało się załadować fontu. Procedurę wołam tak:

LoadFont('font_ubuntu_regular', 'TTF');

Po stronie wywołania wszystko gra – nazwa zasobu zgadza się, typ zasobu też, dlatego też strumień tworzy się prawidłowo, ale pomimo tego font nie jest instalowany.

Jeśli ktoś jest w stanie wskazać błąd to byłbym bardzo wdzięczny. Do załączników dodaję testowy, malutki projekt, testowany pod Lazarusem 1.8.0 32-bit, czyli w najnowszej stabilnej wersji.

U mnie działa :>
Lazarus 1.8.0, Windows 10

Sprawdzałeś pod debuggerem? Choć jeśli dołączone exe włącza się to instaluje poprawnie. ;)

Kurde… pod WinXP nie śmiga, a na tym systemie też mi zależy. Nie wiem czy ma znaczenie to, że testowy font mam już zainstalowany w systemie. W każdym razie funkcja AddFontResource w takim przypadku nie protestuje i poprawnie instaluje.

Choć jeśli dołączone exe włącza się to instaluje poprawnie

exe sam kompilowałem (w zipie nie było).

Sprawdzałeś pod debuggerem?

Tak. Nawet dodałem label i ustawiłem mu tą czcionkę.

Racja, exe nie dołączałem, bo w wersji debug ważył za dużo.

Czyli wychodzi na to, że problem występuje w WinXP. Po południu sprawdzę czy działa pod Win7.

@furious programming Win32 API używa stdcall.
zmień

function AddFontMemResourceEx(pbFont: PVOID; cbFont: DWORD; pdv: PVOID; pcFonts: LPDWORD): HANDLE; external 'gdi32.dll' name 'AddFontMemResourceEx';
function RemoveFontMemResourceEx(fh: HANDLE): LongBool; external 'gdi32.dll' name 'RemoveFontMemResourceEx';

na

function AddFontMemResourceEx(pbFont: PVOID; cbFont: DWORD; pdv: PVOID; pcFonts: LPDWORD): HANDLE; stdcall external 'gdi32.dll' name 'AddFontMemResourceEx';
function RemoveFontMemResourceEx(fh: HANDLE): LongBool; stdcall external 'gdi32.dll' name 'RemoveFontMemResourceEx';

Chciałem dodać stdcall, nawet na siłę, uwierz mi… i dodałem:

function AddFontMemResourceEx(pbFont: PVOID; cbFont: DWORD; pdv: PVOID; pcFonts: LPDWORD): HANDLE; external 'gdi32.dll' name 'AddFontMemResourceEx'; stdcall;

Dostałem błąd kompilacji:

Error: Procedure directive "STDCALL" has conflicts with other directives

więc uznałem, że go nie dam rady dołożyć. Patrzę na Twój kod i zastanawiam się nad tym, gdzie ja miałem głowę pakując ten modyfikator na koniec deklaracji nagłówka funkcji… Chyba przedawkowałem komputer, bo to nie miało absolutnie żadnego sensu, już nie wspominając o błędnej składni…

Oczywiście Twoja propozycja rozwiązuje problem – fonty ładują się prawidłowo. Dziękuję za pomoc, pewnie siedziałbym nad tym z tydzień, zanim zauważyłbym ten bubel… ;)