How to pass a class method to SetWindowLongPtr()?-CodePudding

I want to handle WM_MOUSEMOVE messages in a TComboBox drop-down list, to show item-aware hints. But I just can't make SetWindowLongPtr() work.

If I don't use a functional type variable (TWndProc), the compiler stops with "Not enough parameter" / "Variable required" errors.

If I pass the variable's address (@ptrWndProc), it compiles, but instantly crashes on drop-down.

I tried to make prtWndProc a global variable, but the crash does not disappear.

Could somebody make it work?

Method pointer TWndProc type solution:

unit Unit3;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  PWndProc = ^TWndProc;
  TWndProc = function (hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT of object; stdcall;

  TForm3 = class(TForm)
    ComboBox1: TComboBox;
    procedure ComboBox1DropDown(Sender: TObject);
    procedure ComboBox1CloseUp(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    fDropDownListHandle : THandle;
    fOldDropDownWndProc : TWndProc;
  protected
    function SubClassProc(hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
  public
    { Public declarations }

  end;

var
  Form3: TForm3;

implementation


{$R *.dfm}

function TForm3.SubClassProc(hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin
  case ( msg ) of
    WM_MOUSEMOVE:
      ;
    else
      result := fOldDropDownWndProc( hwnd, msg, wParam, lParam );
  end;
end;

procedure TForm3.ComboBox1CloseUp(Sender: TObject);
var
  ptrWndProc : TWndProc;
begin
  ptrWndProc := SubClassProc;
  fOldDropDownWndProc := PWndProc( SetWindowLongPtr( ComboBox1.Handle, GWLP_WNDPROC, LONG_PTR( @ptrWndProc ) ) )^;
end;

procedure TForm3.ComboBox1DropDown(Sender: TObject);
begin
  SetWindowLongPtr( ComboBox1.Handle, GWLP_WNDPROC, LONG_PTR( @fOldDropDownWndProc ) );
end;

procedure TForm3.FormCreate(Sender: TObject);
var
  cbi : TCOMBOBOXINFO;
begin
  GETCOMBOBOXINFO( ComboBox1.Handle, cbi );
  fDropDownListHandle := cbi.hwndList;
end;

end.

Regular function TWndProc type solution:

unit Unit3;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  PWndProc = ^TWndProc;
  TWndProc = function (hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;

  TForm3 = class(TForm)
    ComboBox1: TComboBox;
    procedure ComboBox1DropDown(Sender: TObject);
    procedure ComboBox1CloseUp(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    fDropDownListHandle : THandle;
  public
    { Public declarations }

  end;

var
  Form3: TForm3;

implementation


{$R *.dfm}

var
  GLOBAL_ptrWndProc : TWndProc;
  GLOBAL_OldDropDownWndProc : TWndProc;

function SubClassProc(hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin
  case ( msg ) of
    WM_MOUSEMOVE:
      ;
    else
      result := GLOBAL_OldDropDownWndProc( hwnd, msg, wParam, lParam );
  end;
end;

procedure TForm3.ComboBox1CloseUp(Sender: TObject);
begin
  GLOBAL_ptrWndProc := SubClassProc;
  GLOBAL_OldDropDownWndProc := PWndProc( SetWindowLongPtr( ComboBox1.Handle, GWLP_WNDPROC, LONG_PTR( @GLOBAL_ptrWndProc ) ) )^;
end;

procedure TForm3.ComboBox1DropDown(Sender: TObject);
begin
  SetWindowLongPtr( ComboBox1.Handle, GWLP_WNDPROC, LONG_PTR( @GLOBAL_OldDropDownWndProc ) );
end;

procedure TForm3.FormCreate(Sender: TObject);
var
  cbi : TCOMBOBOXINFO;
begin
  GETCOMBOBOXINFO( ComboBox1.Handle, cbi );
  fDropDownListHandle := cbi.hwndList;
end;

end.

The DFM:

object Form3: TForm3
  Left = 0
  Top = 0
  Caption = 'Form3'
  ClientHeight = 411
  ClientWidth = 852
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object ComboBox1: TComboBox
    Left = 192
    Top = 96
    Width = 145
    Height = 21
    TabOrder = 0
    Text = 'ComboBox1'
    OnCloseUp = ComboBox1CloseUp
    OnDropDown = ComboBox1DropDown
  end
end

CodePudding user response：

First off, you are hooking the TComboBox's own HWND, not the HWND of its drop-down list. The VCL already hooks the TComboBox's HWND for you, so to process messages sent directly to the TComboBox itself, you can simply:

derive a new class from TComboBox and override the virtual WndProc() method, or use a message handler.
to hook an existing object (as in your example), just subclass its public WindowProc property.

Either way, no need to deal with SetWindowLongPtr() at all.

Now, since you actually want to hook the drop-down list instead (otherwise why are you retrieving its HWND?), then you cannot use a non-static class method as a Win32 callback (at least, not the way you are trying to). It has a hidden Self parameter which the API won't be able to pass back in when calling your callback.

Also, you are passing the wrong memory addresses to SetWindowLongPtr(), which is why you are crashing. You are passing in the addresses of variables, not the addresses of functions.

Also, when using SetWindowLongPtr() to subclass an HWND, you can't call the old window procedure directly, you must use CallWindowProc() instead.

That being said, you have 3 alternatives to make your code work:

use a static class method (or a standalone function) with SetWindowLongPtr(). If you need to access the TComboBox from inside your callback, you can store the TComboBox object pointer in the drop-down list's HWND:

unit Unit3;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm3 = class(TForm)
    ComboBox1: TComboBox;
    procedure ComboBox1DropDown(Sender: TObject);
    procedure ComboBox1CloseUp(Sender: TObject);
  private
    { Private declarations }
    fDropDownListHandle : HWND;
    fOldDropDownWndProc : TFNWndProc;
  protected
    class function SubClassProc(hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; static;
  public
    { Public declarations }
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}

class function TForm3.SubClassProc(hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  cb: TComboBox;
begin
  case ( msg ) of
    WM_MOUSEMOVE:
      begin
        cb := TComboBox( GetProp( fDropDownListHandle, 'ComboBoxPtr' ) );
        // use cb as needed ...
      end;
    else
      Result := CallWindowProc( fOldDropDownWndProc, hwnd, msg, wParam, lParam );
  end;
end;

procedure TForm3.ComboBox1CloseUp(Sender: TObject);
begin
  if fDropDownListHandle <> 0 then
  begin
    SetWindowLongPtr( fDropDownListHandle, GWLP_WNDPROC, LONG_PTR( fOldDropDownWndProc ) );
    RemoveProp( fDropDownListHandle, 'ComboBoxPtr' );
    fDropDownListHandle := 0;
    fOldDropDownWndProc := nil;
  end;
end;

procedure TForm3.ComboBox1DropDown(Sender: TObject);
var
  cbi : TCOMBOBOXINFO;
begin
  cbi.cbSize := SizeOf(cbi);
  if GetComboBoxInfo( ComboBox1.Handle, cbi ) and ( cbi.hwndList <> 0 ) then
  begin
    fDropDownListHandle := cbi.hwndList;
    SetProp( fDropDownListHandle, 'ComboBoxPtr', THandle( ComboBox1 ) );
    fOldDropDownWndProc := TFNWndProc( SetWindowLongPtr( fDropDownListHandle, GWLP_WNDPROC, LONG_PTR( @SubClassProc ) ) );
  end;
end;

end.

use a static class method (or a standalone function) with SetWindowSubclass(), which allows you to pass around a user-defined value, such as the TComboBox object pointer. No need to store it in the subclassed HWND itself:

unit Unit3;

interface

uses
  Winapi.Windows, Winapi.CommCtrl, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm3 = class(TForm)
    ComboBox1: TComboBox;
    procedure ComboBox1DropDown(Sender: TObject);
    procedure ComboBox1CloseUp(Sender: TObject);
  private
    { Private declarations }
    fDropDownListHandle : HWND;
  protected
    class function SubClassProc(hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM; uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall; static;
  public
    { Public declarations }
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}

class function TForm3.SubClassProc(hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM; uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall;
var
  cb: TComboBox;
begin
  case ( msg ) of
    WM_MOUSEMOVE:
      begin
        cb := TComboBox( dwRefData );
        // use cb as needed ...
      end;
    else
      Result := DefSubclassProc( hwnd, msg, wParam, lParam );
  end;
end;

procedure TForm3.ComboBox1CloseUp(Sender: TObject);
begin
  if fDropDownListHandle <> 0 then
  begin
    RemoveWindowSubclass( fDropDownListHandle, @SubClassProc, 1 );
    fDropDownListHandle := 0;
  end;
end;

procedure TForm3.ComboBox1DropDown(Sender: TObject);
var
  cbi : TCOMBOBOXINFO;
begin
  cbi.cbSize := SizeOf(cbi);
  if GetComboBoxInfo( ComboBox1.Handle, cbi ) and ( cbi.hwndList <> 0 ) then
  begin
    fDropDownListHandle := cbi.hwndList;
    SetWindowSubclass( fDropDownListHandle, @SubClassProc, 1, DWORD_PTR( ComboBox1 ) );
  end;
end;

end.

use the RTL's MakeObjectInstance() function to create a proxy stub so that you can use a non-static class method with SetWindowLongPtr() (does not work with SetWindowSubclass()):

unit Unit3;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm3 = class(TForm)
    ComboBox1: TComboBox;
    procedure ComboBox1DropDown(Sender: TObject);
    procedure ComboBox1CloseUp(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    fDropDownListHandle : HWND;
    fOldDropDownWndProc : TFNWndProc;
    fNewDropDownWndProc: Pointer;
  protected
    procedure SubClassProc(var Message: TMessage);
  public
    { Public declarations }
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}

procedure TForm3.FormCreate(Sender: TObject);
begin
  fNewDropDownWndProc := MakeObjectInstance( SubClassProc );
end;

procedure TForm3.FormDestroy(Sender: TObject);
begin
  FreeObjectInstance( fNewDropDownWndProc );
end;

procedure TForm3.SubClassProc(var TMessage: TMessage);
begin
  case ( Message.Msg ) of
    WM_MOUSEMOVE:
      begin
        // use ComboBox1 as needed ...
      end;
    else
      Message.Result := CallWindowProc( fOldDropDownWndProc, fDropDownListHandle, Message.Msg, Message.WParam, Message.LParam );
  end;
end;

procedure TForm3.ComboBox1CloseUp(Sender: TObject);
begin
  if fDropDownListHandle <> 0 then
  begin
    SetWindowLongPtr( fDropDownListHandle, GWLP_WNDPROC, LONG_PTR( fOldDropDownWndProc ) );
    fDropDownListHandle := 0;
    fOldDropDownWndProc := nil;
  end;
end;

procedure TForm3.ComboBox1DropDown(Sender: TObject);
var
  cbi : TCOMBOBOXINFO;
begin
  cbi.cbSize := SizeOf(cbi);
  if GetComboBoxInfo( ComboBox1.Handle, cbi ) and ( cbi.hwndList <> 0 ) then
  begin
    fDropDownListHandle := cbi.hwndList;
    fOldDropDownWndProc := TFNWndProc( SetWindowLongPtr( fDropDownListHandle, GWLP_WNDPROC, LONG_PTR( fNewDropDownWndProc ) ) );
  end;
end;

end.