http://pctgl.cnblogs.com

公告

日历

  1 Option Explicit
  2 
  3 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As Long = 4)
  4 Private 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 Long
  5 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  6 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  7 Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
  8 Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
  9 Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
 10 Private Declare Function GetProcessHeap Lib "kernel32" () As Long
 11 Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
 12 Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long
 13 
 14 Private Type ThisClassSet
 15 
 16     s_DefaultWindowProc     As Long
 17     s_Hwnd                  As Long
 18     s_BlockProtect          As Long
 19     
 20     n_ThunkCodeAddress      As Long
 21     
 22 End Type
 23 
 24 Dim LinkProc()              As Long
 25 Dim PG                      As ThisClassSet
 26 
 27 Event MsgHook(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
 28 
 29 Private Sub GetWindowMessage(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
 30     '子类化接口过程
 31     RaiseEvent MsgHook(Result, cHwnd, Message, wParam, lParam)
 32 End Sub
 33 
 34 Private Function GetWndProcAddress(ByVal SinceCount As Long) As Long
 35 '   地址指针 ＝ GetWndProcAddress( 取第 N 个公共函数（属性）  =或= 所有公共函数个数 + 第 N 个私有函数的函数地址）
 36     Dim mePtr As Long
 37     Dim jmpAddress As Long
 38 
 39     mePtr = ObjPtr(Me)
 40     CopyMemory jmpAddress, ByVal mePtr, 4
 41     CopyMemory jmpAddress, ByVal jmpAddress + (SinceCount - 1) * 4 + &H1C, 4
 42 
 43     If App.LogMode = 0 Then
 44 
 45         ReDim LinkProc(15) As Long
 46         LinkProc(0) = &H83EC8B55
 47         LinkProc(1) = &H75FFFCC4
 48         LinkProc(2) = &H1075FF14
 49         LinkProc(3) = &HFF0C75FF
 50         LinkProc(4) = &HB90875
 51         LinkProc(5) = &HFF000010
 52         LinkProc(6) = &H1F883D1
 53         LinkProc(7) = &H4D8D1575
 54         LinkProc(8) = &H6851FC
 55         LinkProc(9) = &HB8000020
 56         LinkProc(10) = &H3000
 57         LinkProc(11) = &H458BD0FF
 58         LinkProc(12) = &HB807EBFC
 59         LinkProc(13) = &H4000
 60         LinkProc(14) = &HC2C9D0FF
 61         LinkProc(15) = &H10
 62         
 63         CopyMemory ByVal VarPtr(LinkProc(4)) + 3, GetProcAddress(GetModuleHandle("vba6.dll"), "EbMode"), 4&
 64         CopyMemory ByVal VarPtr(LinkProc(8)) + 3, ObjPtr(Me), 4&
 65         LinkProc(10) = jmpAddress
 66         LinkProc(13) = PG.s_DefaultWindowProc
 67 
 68         PG.n_ThunkCodeAddress = HeapAlloc(GetProcessHeap, &H8, 64&)
 69         CopyMemory ByVal PG.n_ThunkCodeAddress, LinkProc(0), 64&
 70         VirtualProtect ByVal PG.n_ThunkCodeAddress, ByVal 64&, ByVal &H40&, PG.s_BlockProtect
 71         GetWndProcAddress = PG.n_ThunkCodeAddress
 72 
 73     Else
 74         ReDim LinkProc(10)
 75         LinkProc(0) = &H83EC8B55
 76         LinkProc(1) = &H75FFFCC4
 77         LinkProc(2) = &H1075FF14
 78         LinkProc(3) = &HFF0C75FF
 79         LinkProc(4) = &H458D0875
 80         LinkProc(5) = &H6850FC
 81         LinkProc(6) = &HB8000010
 82         LinkProc(7) = &H2000
 83         LinkProc(8) = &H458BD0FF
 84         LinkProc(9) = &H10C2C9FC
 85         
 86         CopyMemory ByVal VarPtr(LinkProc(5)) + 3, ObjPtr(Me), 4&
 87         LinkProc(7) = jmpAddress
 88         VirtualProtect ByVal VarPtr(LinkProc(0)), ByVal 40&, ByVal &H40&, PG.s_BlockProtect
 89         GetWndProcAddress = VarPtr(LinkProc(0))
 90 
 91     End If
 92     
 93 End Function
 94 
 95 Function CallDefaultWindowProc(ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 96     '调用窗口默认处理过程
 97     CallDefaultWindowProc = CallWindowProc(PG.s_DefaultWindowProc, ByVal cHwnd&, ByVal Message&, ByVal wParam&, ByVal lParam&)
 98 End Function
 99 
100 Function SetMsgHook(ByVal cHwnd As Long) As Long
101     '设置指定窗口的子类化
102     PG.s_Hwnd = cHwnd
103     PG.s_DefaultWindowProc = GetWindowLong(cHwnd, ByVal -4&)
104     SetWindowLong ByVal cHwnd, ByVal -4&, ByVal GetWndProcAddress(4)
105     SetMsgHook = PG.s_DefaultWindowProc
106 End Function
107 
108 Sub SetMsgUnHook()
109     '取消窗口子类化
110     SetWindowLong ByVal PG.s_Hwnd&, ByVal -4&, ByVal PG.s_DefaultWindowProc&
111     If PG.n_ThunkCodeAddress Then
112         VirtualProtect ByVal PG.n_ThunkCodeAddress, ByVal 64&, ByVal PG.s_BlockProtect, PG.s_BlockProtect
113         HeapFree GetProcessHeap, ByVal 0&, PG.n_ThunkCodeAddress
114         PG.n_ThunkCodeAddress = 0
115     End If
116 End Sub
117 
118 Private Sub Class_Terminate()
119     SetMsgUnHook
120 End Sub
121 
122 ''//    在编译后, GetWndProcAddress 释放以下内嵌汇编代码, 效率最大化
123 ''ComCallBack1 proc hWnd,Msg,wParam,lParam
124 ''
125 ''        LOCAL Result
126 ''
127 ''        push lParam
128 ''        push wParam
129 ''        push Msg
130 ''        push hWnd
131 ''
132 ''        lea eax, Result
133 ''        push eax        ;//
134 ''
135 ''        push 1000h      ;// objptr(me)
136 ''
137 ''        mov eax,2000h       ;// sub: LinkProc
138 ''        Call eax
139 ''
140 ''        mov eax,Result      ;// Return Value
141 ''
142 ''    ret
143 ''ComCallBack1 endp
144 ''
145 ''============================================================================================================================================
146 ''
147 ''//    在 IDE 调试运行时, GetWndProcAddress 释放以下内嵌汇编代码, 用以实现在调试时不崩溃
148 ''ComCallBack proc hWnd,Msg,wParam,lParam
149 ''
150 ''        LOCAL Result
151 ''
152 ''        push lParam
153 ''        push wParam
154 ''        push Msg
155 ''        push hWnd
156 ''
157 ''        mov ecx,1000h
158 ''        call ecx            ;// call vba6.dll::EbMode
159 ''
160 ''        .if eax == 1
161 ''            ;// 调试模式下正常运行
162 ''            lea ecx, Result
163 ''            push ecx        ;// result
164 ''            push 2000h      ;// objptr(me)
165 ''            mov eax,3000h   ;// sub: LinkProc
166 ''            Call eax
167 ''
168 ''            mov eax, Result
169 ''
170 ''        .else
171 ''            ;// 调试模式下非正常运行, 中断 打断 断点 结束
172 ''            mov eax,4000h   ;// sub: Deault Window Proc
173 ''            Call eax
174 ''
175 ''        .endif
176 ''
177 ''        ret
178 ''
179 ''ComCallBack endp

iSubClass

本来不打算再写新的 iSubClass ，之前的版本有关无崩溃的问题一直没有完美解决

这两天地雷，不知道突然抽什么疯，仔细研究了一下泊来的那个不崩溃子类化的类，发现了 vba6.dll:: EbMode

这个函数能够在 IDE 状态下获取 vb 调试器的状态 Return Value： 0 调试器停止； 1 调试器正常运行； 2 调试器被中断

很强大。。。根据 ws地雷提供的信息，对之前版本的 iSubClass 稍稍改造了一下，终于实现了基本稳定，不崩溃的子类化代码，而且兼具强悍效率。

泊来的那个单类子类化代码，又乱，又不高效（同时多开几个实例，程序会很卡），可能唯一的好处就是稳定了

现在这个代码还是有几个小问题：

1. 用 ■ 中断停止，会有 64 字节的资源泄漏，不过问题不大，且编译后不存在这个问题，使用者完全可以无视。

2. 遇有错误代码导致的调试中断（暂时状态，非退出调试）时，可能会临时性的引起vb工具栏的冻结，貌似也问题不大，多点几下 ▲ 或者 ■ 就行了

其他问题，暂时还没发现，如有请跟帖告之。。。

本次修改，对代码接口稍有修改，主要是为了看着顺眼，如果要替换之前已做好的代码，去马子的网站要马子之前拿到的版本。

马子的那份代码可以直接把原来的 iSubClass 删掉，换新的即可，接口代码一点没变，直接用。

要是用本帖的代码，可能你需要修改一下，事件的名字改了一下，改成了 MsgHook ，内接函数改成了 GetWindowMessage

然后就是优化了一下代码，给马子的版本里面有很多笔误代码没改掉

再放一个演示代码：无崩溃子类化代码终极版

posted on 2013-06-23 01:08 PctGL 阅读(1911) 评论(4) 编辑收藏举报

刷新页面返回顶部


Copyright © 2024 PctGL Powered by .NET 9.0 on Kubernetes 博客园

导航