Receive and Handle Windows Messages
lazarus / 67-Windows

----------------------------------------------------------------------
DelphiBoy · 2017-04-09 05:28

I'm trying to port a class I've written in Delphi to Lazarus. It
relies on WM_DEVICECHANGE to detect attached USB devices (need to
derive from TComponent). I can't get my component to receive Windows
messages, while it was working perfectly in Delphi.

I know that AllocateHwnd is just a placeholder in Free Pascal, so I'm
trying to mimic what LCL does (here I'm using WM_PAINT for testing):

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i TUSB =
class(TComponent)private    FHandle: HWND;    procedure WndProc(var
Msg: TMessage);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{%H-}, SizeOf(Msg), #0);  
Msg.msg := uMsg;  Msg.wParam := wParam;  Msg.lParam := lParam;  
PMethod := {%H-}Pointer(GetWindowLong(ahwnd, GWL_USERDATA));   if
Assigned(PMethod) then PMethod^(Msg);   Windows.DefWindowProc(ahwnd,
uMsg, wParam, lParam);end;  function MyAllocateHwnd(Method:
TWndMethod):HWND;var  PMethod: ^TWndMethod; begin  Result :=
Windows.CreateWindow(PChar('STATIC'),   '', WS_OVERLAPPED, 0, 0, 0, 0,
HWND_MESSAGE, 0, MainInstance, nil);   if (Result = 0) then
ShowMessage('error:'+IntToStr(GetLastError));   if Assigned(Method)
then  begin    Getmem(PMethod, SizeOf(TMethod));    PMethod^ :=
Method;     SetWindowLong(Result, GWL_USERDATA,
{%H-}PtrInt(PMethod));  end;   SetWindowLong(Result, GWL_WNDPROC,
{%H-}PtrInt(@CallbackAllocateHWnd));end; procedure TUSB.WndProc(var
Msg: TMessage);begin  if Msg.Msg = WM_PAINT then   
ShowMessage('message received')  else    Msg.Result:=
DefWindowProc(FHandle, Msg.Msg, Msg.WParam,
Msg.LParam);end; constructor TUSB.Create(AOwner: TComponent);begin 
inherited Create(AOwner);   FHandle:= MyAllocateHwnd(@WndProc);end;  
 
This gives me a valid window handle, but a breakpoint in
CallbackAllocateHWnd is never hit by SendMessage(). Exactly the same
lines of code, works in Delphi (without using built-in AllocateHwnd).
What am I missing?

PS: I know this is specific to Windows and not portable. That's fine.

----------------------------------------------------------------------
Handoko · 2017-04-09 07:31

Hello DelphiBoy,
Welcome to this forum.

I found that this link below maybe useful for you:
http://forum.lazarus.freepascal.org/index.php?topic=6062.0

----------------------------------------------------------------------
marcov · 2017-04-09 10:32

He registers an own handle, so it should be entirely outside of the
lcl's control.

At first glace everything is ok. Checking return values from functions
seems most prudent

----------------------------------------------------------------------
DelphiBoy · 2017-04-10 06:09

I just found out that after line

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i
SetWindowLong(Result, GWL_WNDPROC,
{%H-}PtrInt(@CallbackAllocateHWnd)); 
GetLastError returns 1413, which is "invalid index". I added
SetLastError(0) as per instructions here:
https://msdn.microsoft.com/en-
us/library/windows/desktop/ms633591(v=vs.85).aspx

Just to test, I replaced SetWindowLong, with GetWindowLong and it also
gives me 1413.

Any ideas?

----------------------------------------------------------------------
DonAlfredo · 2017-04-10 06:50

I use an LCL function to alloc:

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i {$ifdef
FPC}    FHWnd := LCLIntf.AllocateHWnd(EventPipe);{$else}    FHWnd :=
AllocateHWnd(EventPipe);{$endif}

----------------------------------------------------------------------
DelphiBoy · 2017-04-10 15:55

What is EventPipe? Can you please share more code?

What I'm doing is very similar to what LCL does. Why  do I get 1413?

----------------------------------------------------------------------
DonAlfredo · 2017-04-10 16:55

Code can be found here:
https://github.com/LongDirtyAnimAlf/FPC-USB-HID
https://github.com/LongDirtyAnimAlf/FPC-USB-
HID/blob/master/jvcl/jvcl/run/JvHidControllerClass.pas

I tried your method. Did not succeed. Used LCL !

----------------------------------------------------------------------
antekgla · 2017-07-09 13:56

I want to share a solution at this found in  https://www.experts-
exchange.com/questions/24135127/Improve-code-for-detecting-USB-drive-
insertion-removal.html

It is for Delphi but I ported to Lazarus and works OK.
Maybe someone here with more experiencie could make it better, maybe a
separate unit with a return value of USB detected. I am a beginner in
Delphi/Lazarus:

It is a Form with only a Label what reflect the USB unit attached.

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
Unit1; {$mode objfpc}{$H+} interface uses  Classes, SysUtils,
FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
Windows; type   { TForm1 }   TForm1 = class(TForm)    Label1: TLabel; 
  procedure FormCreate(Sender: TObject);  private    { private
declarations }  public    { public declarations }  end; var 
PrevWndProc: WNDPROC;  Form1: TForm1;   // Device constants  const   
DBT_DEVICEARRIVAL          =  $00008000;    DBT_DEVICEREMOVECOMPLETE 
=  $00008004;    DBT_DEVTYP_VOLUME          =  $00000002;   // Device
structs  type    _DEV_BROADCAST_HDR         =  packed record     
 dbch_size:              DWORD;       dbch_devicetype:        DWORD; 
    dbch_reserved:          DWORD;    end;    DEV_BROADCAST_HDR      
  =  _DEV_BROADCAST_HDR;    TDevBroadcastHeader        =
 DEV_BROADCAST_HDR;    PDevBroadcastHeader        =
 ^TDevBroadcastHeader;   type    _DEV_BROADCAST_VOLUME      =  packed
record       dbch_size:              DWORD;       dbch_devicetype:   
   DWORD;       dbch_reserved:          DWORD;       dbcv_unitmask:  
      DWORD;       dbcv_flags:             WORD;    end;   
DEV_BROADCAST_VOLUME       =  _DEV_BROADCAST_VOLUME;   
TDevBroadcastVolume        =  DEV_BROADCAST_VOLUME;   
PDevBroadcastVolume        =
 ^TDevBroadcastVolume;  implementation {$R *.lfm} { TForm1 } function
WndCallback(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam:
LParam):LRESULT; stdcall;var  lpdbhHeader:   PDevBroadcastHeader;   
 lpdbvData:     PDevBroadcastVolume;     dwIndex:       Integer;   
 lpszDrive:      String;begin  if uMsg = WM_DEVICECHANGE then  begin 
 // Get the device notification header 
lpdbhHeader:=PDevBroadcastHeader(lParam);   // Handle the message 
lpszDrive:='Drive ';  case WParam of     DBT_DEVICEARRIVAL       :  
 {a USB drive was connected}     begin        if
(lpdbhHeader^.dbch_devicetype = DBT_DEVTYP_VOLUME) then        begin 
        lpdbvData:=PDevBroadcastVolume(lParam);           for dwIndex
:=0 to 25 do           begin              if
((lpdbvData^.dbcv_unitmask shr dwIndex) = 1) then              begin 
              lpszDrive:=lpszDrive+Chr(65+dwIndex)+':';              
 break;              end;           end;         
 Form1.Label1.Caption:=lpszDrive + ' connected';        end;     end; 
   DBT_DEVICEREMOVECOMPLETE:    {a USB drive was removed}     begin  
    if (lpdbhHeader^.dbch_devicetype = DBT_DEVTYP_VOLUME) then       
begin           lpdbvData:=PDevBroadcastVolume(lParam);           for
dwIndex:=0 to 25 do           begin              if
((lpdbvData^.dbcv_unitmask shr dwIndex) = 1) then              begin 
              lpszDrive:=lpszDrive+Chr(65+dwIndex)+':';              
 break;              end;           end;         
 Form1.Label1.Caption:=lpszDrive + ' removed';        end;     end; 
end;  end;  result:=
CallWindowProc(PrevWndProc,Ahwnd,uMsg,WParam,LParam);  // If Msg is
not WM_DEVICECHANGE pass the Msgend;  procedure
TForm1.FormCreate(Sender: TObject);begin  Label1.Caption:=''; 
PrevWndProc:= Windows.WNDPROC(SetWindowLongPtr(Self.Handle,GWL_WNDPROC
,PtrInt(@WndCallback)));end; end.

----------------------------------------------------------------------
Remy Lebeau · 2017-07-11 20:59

Quote from: DelphiBoy on April 10, 2017, 05:55:12 pmWhat is EventPipe?

It is the message handler procedure.

http://lazarus-ccr.sourceforge.net/docs/lcl/lclintf/allocatehwnd.html

http://docwiki.embarcadero.com/Libraries/en/System.Classes.AllocateHWn
d