Resultado devuelto de la devolución de llamada de Windows en XE6 de 64 bits

delphi callback

Question

Tengo un código que usa EnumFontFamiliesEX para determinar si una fuente en particular (usando su "nombre de rostro") está instalada. El código funcionaba bien en 32 bits. Cuando compilo y lo ejecuto como de 64 bits, siguió arrojando una excepción en la rutina de devolución de llamada.

Ahora he conseguido que funcione en ambos pero PERO solo si en lugar de pasar el resultado de la función FindFontbyFaceName como el 4º parámetro a EnumFontFamiliesEX, paso una variable local (o global) - MYresult en este caso. (Y luego establecer el resultado). No entiendo lo que está pasando? ¿Alguien puede explicarme o señalarme una mejor manera? (No estoy tan interesado en la mecánica de las fuentes, como la mecánica básica de devolución de llamada).

// single font find callback
function FindFontFace(  {$IFDEF CPUX86}  lpelf: PLogFont;       {$ENDIF}
                        {$IFDEF CPUX64}  lpelf: PEnumLogFontEx; {$ENDIF}
                        lpntm: PNewTextMetricEx;
                        AFontType: DWORD; var Aresult: lparam): integer ; stdcall;
begin
  result := 0;       // 1 shot only please  - not interested in any variations in style etc
  if (lpelf <> nil) then
    Aresult := -1         // TRUE
  else
    Aresult := 0;
end;


function FindFontbyFaceName(ACanvas: TCanvas; const AFacename: string): boolean;
var
  lf: TLogFont;
  Myresult: boolean;
begin
  MYresult := false;

  FillChar(lf, SizeOf(lf), 0);
  StrLCopy(lf.lfFaceName, PChar(AFacename), 32);
  lf.lfCharSet := DEFAULT_CHARSET;

  // this works in both 32 and 64 bit
  EnumFontFamiliesEX(ACanvas.Handle, lf, @FindFontFace, lparam(@MYresult), 0);
  result := MYresult;

  // this works in 32 bit but throws exception in callback in 64 bit
//  EnumFontFamiliesEX(ACanvas.Handle, lf, @FindFontFace, lparam(@result), 0);
end;


function FindFont(const AFacename: string): boolean;
var
  AImage: TImage;
begin
  AImage := Timage.Create(nil);
  try
    result := FindFontbyFaceName(AImage.Canvas, Afacename);
  finally
    Aimage.Free;
  end;
end;

Answer 1

Su función de devolución de llamada no está declarada correctamente. Estás declarando el último parámetro como var LPARAM , que es incorrecto. El parámetro lParam se pasa por valor, no por referencia. Al llamar a EnumFontFamiliesEx() está pasando un puntero a un Boolean como el valor de lParam .

Su devolución de llamada está intentando escribir el número de bytes sizeof(LPARAM) en una dirección de memoria que solo tiene SizeOf(Boolean) disponibles (¿y por qué está intentando escribir un -1 en un Boolean ?). Entonces estás sobreescribiendo la memoria. Al usar un puntero a una variable local como lParam , es probable que sobrescriba la memoria en la pila de llamadas de la función de llamada que realmente no importa, por lo que no verá un bloqueo.

Necesitas:

1. elimine la var y escriba el parámetro lParam en PBoolean :

   function FindFontFace(  lpelf: PLogFont;
                           lpntm: PTextMetric;
                           FontType: DWORD;
                           lParam: LPARAM): Integer ; stdcall;
   begin
     PBoolean(lParam)^ := True;
     Result := 0;       // 1 shot only please  - not interested in any variations in style etc
   end;

   O:

   function FindFontFace(  lpelf: PLogFont;
                           lpntm: PTextMetric;
                           FontType: DWORD;
                           lParam: PBoolean): Integer ; stdcall;
   begin
     lParam^ := True;
     Result := 0;       // 1 shot only please  - not interested in any variations in style etc
   end;

2. deje la var pero cambie el tipo de parámetro a Boolean lugar de a LPARAM :

   function FindFontFace(  var lpelf: TLogFont;
                           var lpntm: TTextMetric;
                           FontType: DWORD;
                           var lParam: Boolean): Integer ; stdcall;
   begin
     lParam := True;
     Result := 0;       // 1 shot only please  - not interested in any variations in style etc
   end;

Cualquiera de los enfoques le permitirá pasar @Result como lParam a EnumFontFamiliesEx() tanto en 32 bits como en 64 bits:

function FindFontbyFaceName(ACanvas: TCanvas; const AFacename: string): Boolean;
var
  lf: TLogFont;
begin
  Result := False;

  FillChar(lf, SizeOf(lf), 0);
  StrLCopy(lf.lfFaceName, PChar(AFacename), 32);
  lf.lfCharSet := DEFAULT_CHARSET;

  EnumFontFamiliesEX(ACanvas.Handle, lf, @FindFontFace, LPARAM(@Result), 0);
end;

En una nota al margen, crear un TImage solo para tener un lienzo para enumerar es un desperdicio. No lo necesitas para nada:

function FindFontFace(  lpelf: PLogFont;
                        lpntm: PTextMetric;
                        FontType: DWORD;
                        lParam: LPARAM): integer ; stdcall;
begin
  PBoolean(lParam)^ := True;
  Result := 0;       // 1 shot only please  - not interested in any variations in style etc
end;

function FindFont(const AFacename: string): Boolean;
var
  lf: TLogFont;
  DC: HDC;
begin
  Result := False;

  FillChar(lf, SizeOf(lf), 0);
  StrLCopy(lf.lfFaceName, PChar(AFacename), 32);
  lf.lfCharSet := DEFAULT_CHARSET;

  DC := GetDC(0);
  EnumFontFamiliesEx(DC, lf, @FindFontFace, LPARAM(@Result), 0);
  ReleaseDC(0, DC);
end;

Dicho esto, puede simplificar el código si usa la propiedad TScreen.Fonts lugar de llamar a EnumFontFamiliesEx() directamente:

function FindFont(const AFacename: string): Boolean;
begin
  Result := (Screen.Fonts.IndexOf(AFacename) <> -1);
end;