* * *

Author Topic: Receive and Handle Windows Messages  (Read 1424 times)

DelphiBoy

  • Newbie
  • Posts: 3
Receive and Handle Windows Messages
« on: April 09, 2017, 07:28:17 am »
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]
  1. TUSB = class(TComponent)
  2. private
  3.     FHandle: HWND;
  4.     procedure WndProc(var Msg: TMessage);
  5. public
  6.      constructor Create(AOwner: TComponent);
  7. end;
  8. .
  9. .
  10. .
  11. procedure CallbackAllocateHWnd(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam); stdcall;
  12. var
  13.   Msg: TMessage;
  14.   PMethod: ^TWndMethod;
  15. begin
  16.   FillChar(Msg{%H-}, SizeOf(Msg), #0);
  17.  
  18.   Msg.msg := uMsg;
  19.   Msg.wParam := wParam;
  20.   Msg.lParam := lParam;
  21.  
  22.   PMethod := {%H-}Pointer(GetWindowLong(ahwnd, GWL_USERDATA));
  23.  
  24.   if Assigned(PMethod) then PMethod^(Msg);
  25.  
  26.   Windows.DefWindowProc(ahwnd, uMsg, wParam, lParam);
  27. end;
  28.  
  29. function MyAllocateHwnd(Method: TWndMethod):HWND;
  30. var
  31.   PMethod: ^TWndMethod;
  32.  
  33. begin
  34.   Result := Windows.CreateWindow(PChar('STATIC'),
  35.    '', WS_OVERLAPPED, 0, 0, 0, 0, HWND_MESSAGE, 0, MainInstance, nil);
  36.  
  37.   if (Result = 0) then ShowMessage('error:'+IntToStr(GetLastError));
  38.  
  39.   if Assigned(Method) then
  40.   begin
  41.     Getmem(PMethod, SizeOf(TMethod));
  42.     PMethod^ := Method;
  43.  
  44.     SetWindowLong(Result, GWL_USERDATA, {%H-}PtrInt(PMethod));
  45.   end;
  46.  
  47.   SetWindowLong(Result, GWL_WNDPROC, {%H-}PtrInt(@CallbackAllocateHWnd));
  48. end;
  49.  
  50. procedure TUSB.WndProc(var Msg: TMessage);
  51. begin
  52.   if Msg.Msg = WM_PAINT then
  53.     ShowMessage('message received')
  54.   else
  55.     Msg.Result:= DefWindowProc(FHandle, Msg.Msg, Msg.WParam, Msg.LParam);
  56. end;
  57.  
  58. constructor TUSB.Create(AOwner: TComponent);
  59. begin
  60.   inherited Create(AOwner);
  61.  
  62.   FHandle:= MyAllocateHwnd(@WndProc);
  63. end;  
  64.  
  65.  

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.
« Last Edit: April 09, 2017, 07:32:56 am by DelphiBoy »

Handoko

  • Hero Member
  • *****
  • Posts: 1326
  • My goal: build my own game engine using Lazarus
Re: Receive and Handle Windows Messages
« Reply #1 on: April 09, 2017, 09:31:18 am »
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

  • Global Moderator
  • Hero Member
  • *****
  • Posts: 5530
Re: Receive and Handle Windows Messages
« Reply #2 on: April 09, 2017, 12:32:38 pm »
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

  • Newbie
  • Posts: 3
Re: Receive and Handle Windows Messages
« Reply #3 on: April 10, 2017, 08:09:33 am »
I just found out that after line

Code: Pascal  [Select]
  1. SetWindowLong(Result, GWL_WNDPROC, {%H-}PtrInt(@CallbackAllocateHWnd));
  2.  

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?
« Last Edit: April 10, 2017, 08:27:31 am by DelphiBoy »

DonAlfredo

  • Hero Member
  • *****
  • Posts: 708
Re: Receive and Handle Windows Messages
« Reply #4 on: April 10, 2017, 08:50:32 am »
I use an LCL function to alloc:

Code: Pascal  [Select]
  1. {$ifdef FPC}
  2.     FHWnd := LCLIntf.AllocateHWnd(EventPipe);
  3. {$else}
  4.     FHWnd := AllocateHWnd(EventPipe);
  5. {$endif}

DelphiBoy

  • Newbie
  • Posts: 3
Re: Receive and Handle Windows Messages
« Reply #5 on: April 10, 2017, 05:55:12 pm »
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?


antekgla

  • New member
  • *
  • Posts: 11
Re: Receive and Handle Windows Messages
« Reply #7 on: July 09, 2017, 03:56:41 pm »
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]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, Windows;
  9.  
  10. type
  11.  
  12.   { TForm1 }
  13.  
  14.   TForm1 = class(TForm)
  15.     Label1: TLabel;
  16.     procedure FormCreate(Sender: TObject);
  17.   private
  18.     { private declarations }
  19.   public
  20.     { public declarations }
  21.   end;
  22.  
  23. var
  24.   PrevWndProc: WNDPROC;
  25.   Form1: TForm1;
  26.  
  27.   // Device constants
  28.   const
  29.     DBT_DEVICEARRIVAL          =  $00008000;
  30.     DBT_DEVICEREMOVECOMPLETE   =  $00008004;
  31.     DBT_DEVTYP_VOLUME          =  $00000002;
  32.  
  33.   // Device structs
  34.   type
  35.     _DEV_BROADCAST_HDR         =  packed record
  36.        dbch_size:              DWORD;
  37.        dbch_devicetype:        DWORD;
  38.        dbch_reserved:          DWORD;
  39.     end;
  40.     DEV_BROADCAST_HDR          =  _DEV_BROADCAST_HDR;
  41.     TDevBroadcastHeader        =  DEV_BROADCAST_HDR;
  42.     PDevBroadcastHeader        =  ^TDevBroadcastHeader;
  43.  
  44.   type
  45.     _DEV_BROADCAST_VOLUME      =  packed record
  46.        dbch_size:              DWORD;
  47.        dbch_devicetype:        DWORD;
  48.        dbch_reserved:          DWORD;
  49.        dbcv_unitmask:          DWORD;
  50.        dbcv_flags:             WORD;
  51.     end;
  52.     DEV_BROADCAST_VOLUME       =  _DEV_BROADCAST_VOLUME;
  53.     TDevBroadcastVolume        =  DEV_BROADCAST_VOLUME;
  54.     PDevBroadcastVolume        =  ^TDevBroadcastVolume;
  55.  
  56.  
  57. implementation
  58.  
  59. {$R *.lfm}
  60.  
  61. { TForm1 }
  62.  
  63. function WndCallback(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam):LRESULT; stdcall;
  64. var  lpdbhHeader:   PDevBroadcastHeader;
  65.      lpdbvData:     PDevBroadcastVolume;
  66.      dwIndex:       Integer;
  67.      lpszDrive:      String;
  68. begin
  69.   if uMsg = WM_DEVICECHANGE then
  70.   begin
  71.     // Get the device notification header
  72.   lpdbhHeader:=PDevBroadcastHeader(lParam);
  73.  
  74.   // Handle the message
  75.   lpszDrive:='Drive ';
  76.   case WParam of
  77.      DBT_DEVICEARRIVAL       :    {a USB drive was connected}
  78.      begin
  79.         if (lpdbhHeader^.dbch_devicetype = DBT_DEVTYP_VOLUME) then
  80.         begin
  81.            lpdbvData:=PDevBroadcastVolume(lParam);
  82.            for dwIndex :=0 to 25 do
  83.            begin
  84.               if ((lpdbvData^.dbcv_unitmask shr dwIndex) = 1) then
  85.               begin
  86.                  lpszDrive:=lpszDrive+Chr(65+dwIndex)+':';
  87.                  break;
  88.               end;
  89.            end;
  90.            Form1.Label1.Caption:=lpszDrive + ' connected';
  91.         end;
  92.      end;
  93.      DBT_DEVICEREMOVECOMPLETE:    {a USB drive was removed}
  94.      begin
  95.         if (lpdbhHeader^.dbch_devicetype = DBT_DEVTYP_VOLUME) then
  96.         begin
  97.            lpdbvData:=PDevBroadcastVolume(lParam);
  98.            for dwIndex:=0 to 25 do
  99.            begin
  100.               if ((lpdbvData^.dbcv_unitmask shr dwIndex) = 1) then
  101.               begin
  102.                  lpszDrive:=lpszDrive+Chr(65+dwIndex)+':';
  103.                  break;
  104.               end;
  105.            end;
  106.            Form1.Label1.Caption:=lpszDrive + ' removed';
  107.         end;
  108.      end;
  109.   end;
  110.   end;
  111.   result:= CallWindowProc(PrevWndProc,Ahwnd,uMsg,WParam,LParam);  // If Msg is not WM_DEVICECHANGE pass the Msg
  112. end;
  113.  
  114.  
  115. procedure TForm1.FormCreate(Sender: TObject);
  116. begin
  117.   Label1.Caption:='';
  118.   PrevWndProc:= Windows.WNDPROC(SetWindowLongPtr(Self.Handle,GWL_WNDPROC,PtrInt(@WndCallback)));
  119. end;
  120.  
  121. end.
  122.  
« Last Edit: July 09, 2017, 04:39:41 pm by antekgla »

Remy Lebeau

  • Sr. Member
  • ****
  • Posts: 275
    • Lebeau Software
Remy Lebeau
Lebeau Software - Owner, Developer
Internet Direct (Indy) open source project - Admin, Developer

 

Recent

Get Lazarus at SourceForge.net. Fast, secure and Free Open Source software downloads Open Hub project report for Lazarus