Delphi中通过子类化实现全局WINDOWS事件处理

最新推荐文章于 2023-02-15 15:01:06 发布

Aquarius_1983

最新推荐文章于 2023-02-15 15:01:06 发布

阅读量1.7k

点赞数

文章标签： delphi windows integer function byte

本文链接：https://blog.csdn.net/Aquarius_1983/article/details/470762

版权

var

oldWndProc: Pointer = nil;
SubclassHandles : TList;
SubclassWndProc: TList;

procedure SaveInstance(instance: Pointer);
type
Parser = packed record
     funcPtr: Pointer;
     objPtr: Pointer;
end;
PObjectInstance = ^TObjectInstance;
TObjectInstance = packed record
    Code: Byte;
    Offset: Integer;
    case Integer of
      0: (Next: PObjectInstance);
      1: (Method: TWndMethod);
end;
var
pObjectInst: PObjectInstance;
ps: Parser;
wc: TWinControl;
begin
pObjectInst:= PObjectInstance(instance);
ps:= Parser(pObjectInst.Method);
wc:= TWinControl(ps.objPtr);
SubclassHandles.Add( Pointer(wc.Handle));

SubclassWndProc.Add(instance);
end;

function DispatchSubclass(hWin: HWND; uMsg: Cardinal; wPm: WPARAM; lPm: LPARAM): Integer;stdcall;
var
idx: integer;
begin
Result:= 0;
idx:= SubclassHandles.IndexOf(Pointer(hWin));
if idx >= 0 then
begin
Result:= CallWindowProc(SubclassWndProc.Items[ idx ], hWin, uMsg, wPm, lPm);
end;
end;

function SubclassProc(hWin: HWND; uMsg, wPm, lPm: Longint): Longint;stdcall;
begin
if uMsg = WM_ERASEBKGND then
begin
Result:= 0;
end
else begin
Result:= DispatchSubclass(hWin, uMsg, wPm, lPm);
end;
end;

procedure TForm1.FormShow(Sender: TObject);
var
i: integer;
begin

if not firstShow then
begin
    try
      SubclassHandles:= TList.Create;
      SubclassWndProc:= TList.Create;
      firstShow:= true;
      for i:= 0 to self.ComponentCount - 1 do
      begin
        if (self.Components[ i ] is TWinControl) then
        begin
          oldWndProc:= Pointer(SetWindowLong(
            TWinControl(self.Components[ i ]).Handle, GWL_WNDPROC,
            Integer(@SubclassProc)));
          SaveInstance(oldWndProc);
        end;
      end;
    except
      SubclassHandles.Free;
      SubclassWndProc.Free;
    end;
end;
end;