unit Unit4;

interface

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

type
  TForm4 = class(TForm)
    procedure SysCommand(var Message: TMessage); // message WM_SYSCOMMAND;
    procedure SysCommand2(var Message: TMessage);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form4: TForm4;

type
  TMethodTest = procedure of object;

implementation

{$R *.dfm}

procedure AddMethod(&Class: Pointer; Selector: SmallInt; MethodAddress: Pointer);
{$POINTERMATH ON}
label NewStart, EndStep;
type
  ArrPointer = array of Pointer;

  TArrayMethod = array of SmallInt;

  TDynaMethodTable = record
    Count: Word;
    Selectors: array [0 .. 9999999] of SmallInt;
  end;

  PDynaMethodTable = ^TDynaMethodTable;
var
  Tabl: PDynaMethodTable;
  Addrs1, Addrs2, Ptr: PPointer;
  OldCount, I: Word;
  OldProtect: Cardinal;

  Addres, BytePtr: PByte;
  MNewStart: Boolean;
begin
  Addres := PByte(PPointer(&Class^)^);
NewStart: MNewStart := False;
  Ptr := PPointer(Addres + VmtDynamicTable);
  BytePtr := PByte(Ptr);
  if VirtualProtect(BytePtr, SizeOf(BytePtr^), PAGE_EXECUTE_READWRITE, OldProtect) then
  begin
    try
      Tabl := Ptr^;
      if Tabl = nil then
        goto EndStep;

      OldCount := Tabl.Count;

      Addrs2 := PPointer(PByte(@Tabl.Selectors) + Tabl.Count * SizeOf(Tabl.Selectors[0]));

      Tabl.Count := Tabl.Count + 1;

      Addrs1 := PPointer(PByte(@Tabl.Selectors) + Tabl.Count * SizeOf(Tabl.Selectors[0]));

      I := OldCount;
      while I > 0 do
      begin
        Dec(I);
        ArrPointer(Addrs1)[I] := ArrPointer(Addrs2)[I];
      end;

      ArrPointer(Addrs1)[OldCount] := MethodAddress;

      Tabl.Selectors[OldCount] := Selector;

    EndStep:

      if Tabl = nil then
      begin
        GetMem(PPointer(Addres + VmtDynamicTable)^, Sizeof(TDynaMethodTable));
        MNewStart := True;
      end;

    finally
      VirtualProtect(BytePtr, SizeOf(BytePtr^), OldProtect, OldProtect);
      FlushInstructionCache(GetCurrentProcess, BytePtr, SizeOf(BytePtr^));
    end;
    if MNewStart then
      goto NewStart;
  end;

end;

procedure TForm4.SysCommand2(var Message: TMessage);
begin
  Message.Result := 0;
end;

procedure TForm4.FormCreate(Sender: TObject);
begin
  AddMethod(@Self, WM_SYSCOMMAND, Self.MethodAddress('SysCommand'));
  AddMethod(@Self, WM_CONTEXTMENU, Self.MethodAddress('SysCommand2'));
end;

procedure TForm4.SysCommand(var Message: TMessage);
begin
  Form4.Caption := Message.WParam.ToString;
end;

end.

unit FormHookEX;

interface

uses
  Winapi.Windows, Vcl.Forms, Winapi.Messages;

type
  ThookMessage = class(TForm)
    procedure CallMessage(var Message: TMessage);
  end;

 procedure FormSetHookMessage(Form: TForm);  // Могу запретить любой форме делать всё, что укажу 

procedure AddMethod(&Class: Pointer; Selector: SmallInt; MethodAddress: Pointer);

implementation

 procedure ThookMessage.CallMessage(var Message: TMessage); 
 begin 
   if Message.Msg = 123 then 
     Message.Result := 0 
   else 
     case Message.WParam of 
       61441, 61443, 61444, 61445, 61447, 61456, 61458, 61472, 61488, 61490, 61536, 61539, 61587, 
         61696, 61730: Message.Result := 0 
     else DefWindowProc(Handle, Message.Msg, Message.WParam, Message.LParam) 
     end; 
 end; 

procedure FormSetHookMessage(Form: TForm);
begin
  AddMethod(@Form, WM_SYSCOMMAND, @ThookMessage.CallMessage);
  AddMethod(@Form, WM_CONTEXTMENU, @ThookMessage.CallMessage);
end;

procedure AddMethod(&Class: Pointer; Selector: SmallInt; MethodAddress: Pointer);
label NewStart, EndStep;
type
  ArrPointer = array of Pointer;

  TArrayMethod = array of SmallInt;

  TDynaMethodTable = record
    Count: Word;
    Selectors: array [0 .. 9999999] of SmallInt;
  end;

  PDynaMethodTable = ^TDynaMethodTable;
var
  Tabl: PDynaMethodTable;
  Addrs1, Addrs2, Ptr: PPointer;
  OldCount, I: Word;
  OldProtect: Cardinal;

  Addres, BytePtr: PByte;
  MNewStart: Boolean;
begin
  Addres := PByte(PPointer(&Class^)^);
NewStart: MNewStart := False;
  Ptr := PPointer(Addres + VmtDynamicTable);
  BytePtr := PByte(Ptr);
  if VirtualProtect(BytePtr, SizeOf(BytePtr^), PAGE_EXECUTE_READWRITE, OldProtect) then
  begin
    try
      Tabl := Ptr^;
      if Tabl = nil then
        goto EndStep;

      OldCount := Tabl.Count;

      Addrs2 := PPointer(PByte(@Tabl.Selectors) + Tabl.Count * SizeOf(Tabl.Selectors[0]));

      Tabl.Count := Tabl.Count + 1;

      Addrs1 := PPointer(PByte(@Tabl.Selectors) + Tabl.Count * SizeOf(Tabl.Selectors[0]));

      I := OldCount;
      while I > 0 do
      begin
        Dec(I);
        ArrPointer(Addrs1)[I] := ArrPointer(Addrs2)[I];
      end;

      ArrPointer(Addrs1)[OldCount] := MethodAddress;

      Tabl.Selectors[OldCount] := Selector;

    EndStep:

      if Tabl = nil then
      begin
        GetMem(PPointer(Addres + VmtDynamicTable)^, Sizeof(TDynaMethodTable));
        MNewStart := True;
      end;

    finally
      VirtualProtect(BytePtr, SizeOf(BytePtr^), OldProtect, OldProtect);
      FlushInstructionCache(GetCurrentProcess, BytePtr, SizeOf(BytePtr^));
    end;
    if MNewStart then
      goto NewStart;
  end;

end;

initialization

finalization

end.

unit FormHookEX;

interface

uses
  Vcl.Forms, Vcl.Controls, Winapi.Messages;

type
  ThookMessage = class(TForm)
    procedure CallMessage(var Message: TMessage);
    function GetFormHookEXWndProc(): TWndMethod;
  end;

procedure FormSetHookMessage(Form: TForm);

procedure FormRemoveHookMessage(Form: TForm);

implementation

function ThookMessage.GetFormHookEXWndProc(): TWndMethod;
begin
  Result := WndProc;
end;

procedure ThookMessage.CallMessage(var Message: TMessage);
begin
  if Message.Msg = 123 then
    Message.Result := 0
  else
    case Message.WParam of
      61441, 61443, 61444, 61445, 61447, 61456, 61458, 61472, 61488, 61490, 61536, 61539, 61587,
        61696, 61730: Message.Result := 0
    else WndProc(Message);
    end;
end;

procedure FormSetHookMessage(Form: TForm);
var
  T: TWndMethod;
begin
  TMethod(T).Data := Form;
  TMethod(T).Code := @ThookMessage.CallMessage;
  TControl(Form).WindowProc := T;
end;

procedure FormRemoveHookMessage(Form: TForm);
var
  T, T2: TMethod;
  V: function: TWndMethod of object;
begin
  T := TMethod(TControl(Form).WindowProc);
  if T.Code = @ThookMessage.CallMessage then
  begin
    TMethod(V).Data := Form;
    TMethod(V).Code := @ThookMessage.GetFormHookEXWndProc;

    TControl(Form).WindowProc := V();
  end;
end;

initialization

finalization

end.