Delphi中通過子類化實現全局WINDOWS事件處理

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;