Перенос класса из Delphi в Lazarus: использование WM_DEVICECHANGE для обнаружения USB-устройств

Delphi , ОС и Железо , Справочник по сообщениям

Если вы пытаетесь перенести класс, написанный на Delphi, в Lazarus и столкнулись с проблемами при приеме и обработке оконных сообщений Windows, в том числе WM_DEVICECHANGE, чтобы обнаружить подключенные USB-устройства, эта статья поможет вам разобраться в этом вопросе.

Проблема

При переносе класса из Delphi в Lazarus компонент не получает оконные сообщения Windows, в то время как в Delphi все работает исправно. После исследования было установлено, что AllocateHwnd является всего лишь Platzhalter в Free Pascal. В результате было решено имитировать то, что делает LCL для этой цели.

Ниже приведен пример кода, который не работает в Lazarus, но работает в Delphi:

TUSB = class(TComponent)
private
  FHandle: HWND;
  procedure WndProc(var Msg: TMessage);
  procedure AllocHandle(Method: TWndMethod);
public
  constructor Create(AOwner: TComponent);
end;

procedure CallbackAllocateHWnd(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam); stdcall;
var
  Msg: TMessage;
  PMethod: ^TWndMethod;
begin
  FillChar(Msg, SizeOf(Msg), #0);
  Msg.msg := uMsg;
  Msg.wParam := wParam;
  Msg.lParam := lParam;
  PMethod := ^{}Pointer(GetWindowLong(ahwnd, GWL_USERDATA));
  if Assigned(PMethod) then PMethod^(Msg);
  Windows.DefWindowProc(ahwnd, uMsg, wParam, lParam);
end;

procedure TUSB.AllocHandle(Method: TWndMethod);
var
  PMethod: ^TWndMethod;
begin
  FHandle := Windows.CreateWindow(PChar('STATIC'), '', WS_OVERLAPPED, 0, 0, 0, 0, 0, 0, MainInstance, nil);
  if Assigned(Method) then
  begin
    GetMem(PMethod, SizeOf(TMethod));
    PMethod^ := Method;
    SetWindowLong(FHandle, GWL_USERDATA, ^{}PtrInt(PMethod));
  end;
  SetWindowLong(FHandle, GWL_WNDPROC, ^{}PtrInt(@CallbackAllocateHWnd));
end;

constructor TUSB.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  AllocHandle(@WndProc);
end;

Приведенный выше код создает окно, но вызов CallbackAllocateHWnd не происходит. Несмотря на то, что это специфично для Windows и не переносимо, сейчас это не главная проблема. Цель состоит в том, чтобы создать класс, унаследованный от TComponent, и иметь возможность получать и обрабатывать оконные сообщения Windows.

Решение

После изучения форума Lazarus было установлено, что включение единицы LCLIntf в раздел uses решает проблему. При просмотре кода в runtime было установлено, что он в конечном итоге вызывает Windows.SetWindowLongPtrW. Таким образом, замена второго вызова SetWindowLong на Windows.SetWindowLongPtrW решает проблему, и все работает!

Пример рабочего кода

Ниже приведен рабочий пример кода, основанный на приведенном выше нерабочем примере:

TUSB = class(TComponent)
private
  FHandle: HWND;
  procedure WndProc(var Msg: TMessage);
  procedure AllocHandle(Method: TWndMethod);
public
  constructor Create(AOwner: TComponent);
end;

uses
  LCLIntf;

procedure CallbackAllocateHWnd(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam); stdcall;
var
  Msg: TMessage;
  PMethod: ^TWndMethod;
begin
  FillChar(Msg, SizeOf(Msg), #0);
  Msg.msg := uMsg;
  Msg.wParam := wParam;
  Msg.lParam := lParam;
  PMethod := ^{}Pointer(GetWindowLong(ahwnd, GWL_USERDATA));
  if Assigned(PMethod) then PMethod^(Msg);
  Windows.DefWindowProc(ahwnd, uMsg, wParam, lParam);
end;

procedure TUSB.AllocHandle(Method: TWndMethod);
var
  PMethod: ^TWndMethod;
begin
  FHandle := Windows.CreateWindow(PChar('STATIC'), '', WS_OVERLAPPED, 0, 0, 0, 0, 0, 0, MainInstance, nil);
  if Assigned(Method) then
  begin
    GetMem(PMethod, SizeOf(TMethod));
    PMethod^ := Method;
    SetWindowLong(FHandle, GWL_USERDATA, ^{}PtrInt(PMethod));
  end;
  Windows.SetWindowLongPtrW(FHandle, GWL_WNDPROC, ^{}PtrInt(@CallbackAllocateHWnd));
end;

constructor TUSB.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  AllocHandle(@WndProc);
end;

Теперь компонент должен правильно получать и обрабатывать оконные сообщения Windows, включая WM_DEVICECHANGE, что позволяет обнаруживать подключенные USB-устройства в Lazarus.

Создано по материалам из источника по ссылке.

При переносе класса из Delphi в Lazarus, компонент не получает оконные сообщения Windows, в том числе `WM_DEVICECHANGE`, для обнаружения USB-устройств из-за проблем с `AllocateHwnd`.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: Справочник по сообщениям ::