Возврат результата из обратного вызова Windows в 64-разрядном XE6

Question

У меня есть код, который использует EnumFontFamiliesEX для определения того, установлен ли конкретный шрифт (с использованием его «имя-имя»). Код работал отлично в 32-битном режиме. Когда я компилирую и запускаю его как 64-битный, он все время бросает исключение в процедуру обратного вызова.

Теперь я получил его для работы как у , но только если вместо передачи функции FindFontbyFaceName в качестве 4-го параметра в EnumFontFamiliesEX, я передаю локальную (или глобальную) переменную - MYresult в этом случае. (И затем установите результат из него). Я не понимаю, что происходит? Может кто-нибудь объяснить или указать мне на лучший способ. (Меня не так интересуют механики шрифтов, как основная механика обратного вызова).

// 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

Функция обратного вызова не объявлена ​​правильно. Вы объявляете последний параметр как var LPARAM, что неверно. Параметр lParam передается по значению, а не по ссылке. При вызове EnumFontFamiliesEx() вы передаете указатель на Boolean в качестве значения lParam.

Ваш обратный вызов пытается записать sizeof(LPARAM) число байтов в адрес памяти, который имеет только SizeOf(Boolean) байт доступные (и почему вы пытаетесь написать -1 к Boolean?). Таким образом, вы переписываете память. При использовании указателя на локальную переменную как lParam вы скорее всего перезаписываете память в стеке вызовов вызывающей функции, что не имеет особого значения, поэтому вы не видите сбоя.

Вам нужно либо:

1. удалить var и типаж параметр lParam к 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; 
   

   Или:

   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. оставить изменения var но параметр Этери типа в Boolean вместо 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; 
   

Любой подход позволит вам пройти @Result как lParam для EnumFontFamiliesEx() как в 32-битной и 64-битной:

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; 

На стороне записки, создавая a TImage просто иметь холст для перечисления с расточительным. Вам не нужно вообще:

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; 

При этом, вы можете упростить код, если вы используете TScreen.Fonts свойство вместо вызова EnumFontFamiliesEx() непосредственно:

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