打入消息循环的另类方法

正常打入消息循环的方法:
如果要监视 WM_CONTEXTMENU 消息来实现菜单的右键菜单,一般做法是通过子类化 (subclass) Menus.PopupList.WndProc 的方法来处理窗口消息。简单讲就是:打入消息循环,完成我的处理,再把消息交还给原先的消息处理函数。当不需要监视消息的时候再退出消息处理(un-subclass)。这样做的好处是:不打破控件的结构。

procedure TMyMenuMessagesHandler.SubclassWndProc;
begin
  FDefMenuProc := Pointer(GetWindowLongA(PopupList.Window, GWL_WNDPROC));
  FObjInstance := Classes.MakeObjectInstance(CustomMenuWndProc);
  SetWindowLongA(PopupList.Window, GWL_WNDPROC, Longint(FObjInstance));
end;

procedure TMyMenuMessagesHandler.UnSubclassWndProc;
begin
  
if Assigned(FDefMenuProc) then
    SetWindowLongA(PopupList.Window, GWL_WNDPROC, Longint(FDefMenuProc));
  
if Assigned(FObjInstance) then
    Classes.FreeObjectInstance(FObjInstance);
end;

procedure TMyMenuMessagesHandler.CustomMenuWndProc(var Message: TMessage);
var
  CancelPopupContextMenu: Boolean;
begin
  
if Message.Msg = WM_CONTEXTMENU then
  
begin
    
// My own code ....
    Message.Result := 
1;
    Exit;
  
end;

  
// Send message to default message handler
  
with Message do
    Result := CallWindowProcA(FDefMenuProc, PopupList.Window, Msg, wParam, lParam);
end


问题的提出
但是这样做有个隐藏问题如果你接管的消息窗口提前释放了那么消息处理链就断了这个时候程序可能会崩溃。如果我们可以直接修改Menus.PopupList.WndProc,那么就不用通过 subclass 来实现消息接管了。幸运的是,对于 Menus.PopupList 这个特殊的全局变量来说,这个是可以做到的。

实现原理:
PopupList 的类型是 TPopupList,我们可以在自己的程序里面定义一个继承类,名为TPopupListEx。因为这是个特殊的全局变量,它是在 Menus.pas 的初始化部分就创建的,我们可以在它创建之后,立刻释放它,然后以 TPopupListEx的形式重新创建。只要声明部分没有任何变化,这种方法可以 “骗过” 任何调用者,它们以为还是在调用TPopupList。

具体代码:
把上面的代码替换成如下代码即可

//PATCH-BEGIN
type
  TPopupListEx = 
class(TPopupList)
  
private
    FOnCustomWndProc: TWndMethod;
  
public
    
property OnCustomWndProc: TWndMethod read FOnCustomWndProc write FOnCustomWndProc;
  
protected
    
procedure WndProc(var Message: TMessage); override;
  
end;

procedure TPopupListEx.WndProc(var Message: TMessage);
begin
  
if Assigned(OnCustomWndProc) then
  
begin
    OnCustomWndProc(Message);
    
if Message.Result = 1 then
      Exit;
  
end;
  
inherited;
end;
//PATCH-END

procedure TMyMenuMessagesHandler.SubclassWndProc;
begin
  
if Assigned(PopupList) then
    TPopupListEx(PopupList).OnCustomWndProc := CustomMenuWndProc;
end;

procedure TMyMenuMessagesHandler.UnSubclassWndProc;
begin
  
if Assigned(PopupList) then
    TPopupListEx(PopupList).OnCustomWndProc := 
nil;
end;

procedure TMyMenuMessagesHandler.CustomMenuWndProc(var Message: TMessage);
var
  CancelPopupContextMenu: Boolean;
begin
  
if Message.Msg = WM_CONTEXTMENU then
  
begin
    
// My own code ....
    Message.Result := 
1;
  
end;
end


initialization
  FreeAndNil(PopupList);
  PopupList := TPopupListEx.Create;

finalization
//FreeAndNil(PopupList); //NOTE: will be freed by finalization section of Menus.pas
end.

 

说明
但是我还不清楚为什么用 subclass 方法的时候,一旦消息窗口释放,程序会崩溃。目前也只能先用这个方法了。

另类多线程的实现(消息

09-06

此份代码利用自定义消息来实现“多线程”的功能,严格意义上来说不能说成是多线程因为是利用消息机制让代码跑在主线程上来的,具体大家自己看代码。在某种要求下可以当多线程来使用。rnrnAttribute VB_Name = "modMultiThread"rnOption ExplicitrnrnPrivate Const GWL_WNDPROC = -4rnrnPrivate Const WM_COPYDATA = &H4ArnrnPrivate Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As LongrnrnPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)rnrnPrivate Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As LongrnrnPrivate Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongrnrnPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongrnrnPrivate Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongrnrnrnrnPrivate lpPrevWndProc As LongrnrnPrivate ShellCode(80) As ByternrnrnPublic Function TestProc(ByVal lpParameter) As Longrnrn MsgBox Hex(lpParameter)rn' DbgBreakPointrnrnEnd Functionrnrn'Public Sub TestProc(ByVal lpParameter)rn' MsgBox Hex(lpParameter)rn'' DbgBreakPointrn'End SubrnrnPublic Sub Unhook(ByVal hWnd As Long)rn If lpPrevWndProc Thenrn SetWindowLong hWnd, GWL_WNDPROC, lpPrevWndProcrn End IfrnEnd SubrnrnPublic Sub StartHook(ByVal hWnd As Long)rn lpPrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)rnEnd SubrnrnPrivate Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Longrn Dim MessageId As Longrn Dim dwFunAddress As Longrn Dim dwParameter As Longrn Dim pData As Longrn rn If uMsg = WM_COPYDATA Thenrn CopyMemory pData, ByVal lParam + 8, 4rn rn CopyMemory MessageId, ByVal pData, 4rn 'Debug.Print "MessageId: " & Hex(MessageId)rn If MessageId = &H1000 Thenrn CopyMemory dwFunAddress, ByVal pData + 4, 4rn CopyMemory dwParameter, ByVal pData + 8, 4rn Debug.Print "FunAddress: " & Hex(dwFunAddress) & ",Parameter: " & Hex(dwParameter)rn '这里不能使用移花接木,可惜了,所以只能自己建立一个函数表然后和地址对应,然后通过查表来对应调用哪个函数了rn TestProc dwParameterrn End Ifrn End Ifrn rn WindowProc = CallWindowProc(lpPrevWndProc, hWnd, uMsg, wParam, lParam)rnEnd FunctionrnrnrnPublic Function CHCreateThread(ByVal hWnd As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Longrn Dim wValue As Integerrn Dim dwValue As Longrn Dim dwThreadId As Longrn Dim hThread As Longrn rn wValue = &HEC83rn CopyMemory ByVal VarPtr(ShellCode(0)), ByVal VarPtr(wValue), 2rn ShellCode(2) = &H18 'sub esp, 18hrn rn dwValue = &H1C24448Brn CopyMemory ByVal VarPtr(ShellCode(3)), ByVal VarPtr(dwValue), 4 'mov eax, [esp+1Ch]rn rn dwValue = &HC24548Drn CopyMemory ByVal VarPtr(ShellCode(7)), ByVal VarPtr(dwValue), 4 'lea edx, [esp+0xC]rn rn ShellCode(11) = &H52 'push edx ; lParamrn rn wValue = &H6Arn CopyMemory ByVal VarPtr(ShellCode(12)), ByVal VarPtr(wValue), 2 'push 0 ; wParamrnrn dwValue = &H8244C8Drn CopyMemory ByVal VarPtr(ShellCode(14)), ByVal VarPtr(dwValue), 4 'lea ecx, [esp+8]rn rn wValue = &H4A6Arn CopyMemory ByVal VarPtr(ShellCode(18)), ByVal VarPtr(wValue), 2 'push 4Ah ; Msgrn rn ShellCode(20) = &H68rn dwValue = hWndrn CopyMemory ByVal VarPtr(ShellCode(21)), ByVal VarPtr(dwValue), 4 'push hWndrn rn dwValue = &H102444C7rn CopyMemory ByVal VarPtr(ShellCode(25)), ByVal VarPtr(dwValue), 4rn dwValue = &H1000rn CopyMemory ByVal VarPtr(ShellCode(29)), ByVal VarPtr(dwValue), 4 'mov dword ptr [esp+10h], 1000hrn rn dwValue = &H142444C7rn CopyMemory ByVal VarPtr(ShellCode(33)), ByVal VarPtr(dwValue), 4rn dwValue = lpStartAddressrn CopyMemory ByVal VarPtr(ShellCode(37)), ByVal VarPtr(dwValue), 4 'mov dword ptr [esp+14h], lpStartAddressrn rn dwValue = &H18244489rn CopyMemory ByVal VarPtr(ShellCode(41)), ByVal VarPtr(dwValue), 4 'mov [esp+18h], eaxrn rn dwValue = &H1C2444C7rn CopyMemory ByVal VarPtr(ShellCode(45)), ByVal VarPtr(dwValue), 4rn dwValue = 0rn CopyMemory ByVal VarPtr(ShellCode(49)), ByVal VarPtr(dwValue), 4 'mov dword ptr [esp+1ch], 0rn rn dwValue = &H202444C7rn CopyMemory ByVal VarPtr(ShellCode(53)), ByVal VarPtr(dwValue), 4rn dwValue = &HCrn CopyMemory ByVal VarPtr(ShellCode(57)), ByVal VarPtr(dwValue), 4 'mov dword ptr [esp+20h], 0xCrn rn dwValue = &H24244C89rn CopyMemory ByVal VarPtr(ShellCode(61)), ByVal VarPtr(dwValue), 4 'mov [esp+24h], ecxrn rn ShellCode(65) = &HB8rn dwValue = GetProcAddress(GetModuleHandle("User32.dll"), "SendMessageA")rn CopyMemory ByVal VarPtr(ShellCode(66)), ByVal VarPtr(dwValue), 4 'mov eax, SendMessageArn rn wValue = &HD0FFrn CopyMemory ByVal VarPtr(ShellCode(70)), ByVal VarPtr(wValue), 2 'call eaxrn rn wValue = &HC033rn CopyMemory ByVal VarPtr(ShellCode(72)), ByVal VarPtr(wValue), 2 'xor eax, eaxrn rn wValue = &HC483rn CopyMemory ByVal VarPtr(ShellCode(74)), ByVal VarPtr(wValue), 2rn ShellCode(76) = &H18 'add esp, 18hrn rn wValue = &H4C2rn CopyMemory ByVal VarPtr(ShellCode(77)), ByVal VarPtr(wValue), 2rn ShellCode(79) = &H0 'ret 4rnrn' ShellCode(77) = &HCC 'int 3rn' wValue = &H4C2rn' CopyMemory ByVal VarPtr(ShellCode(78)), ByVal VarPtr(wValue), 2rn' ShellCode(80) = &H0 'ret 4rn rn hThread = CreateThread(ByVal 0&, _rn 0, _rn ByVal VarPtr(ShellCode(0)), _rn ByVal lpParameter, _rn dwCreationFlags, _rn dwThreadId _rn )rn If lpThreadId Thenrn lpThreadId = dwThreadIdrn End Ifrn CHCreateThread = hThreadrnEnd Functionrn

没有更多推荐了,返回首页

私密
私密原因:
请选择设置私密原因
  • 广告
  • 抄袭
  • 版权
  • 政治
  • 色情
  • 无意义
  • 其他
其他原因:
120
出错啦
系统繁忙,请稍后再试