【叶帆文章】无崩溃子类化技术实现

[叶帆]

凡是用VB做相对高深一些的东西的时候，不可避免都会或多或少用到子类技术，我上一篇文章介绍的www.vbaccelerator.com 网站，上面关于控件、图形等等几乎都用到了子类技术。

但是如果简单的用几个API来实现子类，那么只要你非正常关闭窗体或者加入中断点调试，不好意思，VB IDE崩溃，所有的一切都要重来。

有没有无崩溃的子类技术呢？我这里目前不光有一种，还有两种：）

第一种，也就是www.vbaccelerator.com 网站常用的技术，就是用VB做了一个进程内组件DLL（SSubTmr6.dll），由它实现子类。效果不错，但是需要挂接一个COM组件，有背绿色软件之道，所以这个技术就不介绍了（详细代码，请上vba...网站，上面有源码）。

第二种，其实这是我看 HookMenu源码的心得，是高手的结晶，这里不敢夺爱。HookMenu作者高就高在，用汇编代码实现了窗口消息处理函数，然后编译成二进制码，由VB程序进行调用，这样仅需要在程序中添加一个类（外引用一个该类的接口文件SubclassingSink.tlb），就可以很绿色，并且无崩溃的实现了子类化，由于作者原代码包含内容较多，所以我简化了一下，自己重新封装了一个类，然后又做了一个示例。这样让高端技术平民化，让每一个VB爱好者都会使用。

示例代码如下：

'*************************************************************************
'**模 块 名：frmDemo
'**说 明：Sky Walker(天行者) 版权所有2006 - 2007(C)
'**创 建 人：叶帆
'**日 期：2006-01-02 17:29:24
'**修 改 人：
'**日 期：
'**描 述：窗口子类化示例（无崩溃）
'** ：叶帆Blog：http://blog.csdn.net/yefanqiu
'**版 本：V1.0.0
'*************************************************************************
Option Explicit
Implements ISubclassingSink '接口定义 需引用接口文件SubclassingSink.tlb
Private mSubclass As CSubclass '实现类

Private Const WM_SIZE = &H5
Private Const WM_MOUSEWHEEL = &H20A
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205

'*************************************************************************
'**函 数 名：Form_Load
'**输 入：无
'**输 出：无
'**功能描述：初始化子类
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2006-01-02 17:33:02
'**修 改 人：
'**日 期：
'**版 本：V1.0.0
'*************************************************************************
Private Sub Form_Load()
Set mSubclass = New CSubclass '初始化一个子类
'添加消息 (前截获)
mSubclass.AddBeforeMsgs WM_MOUSEWHEEL, WM_SIZE, WM_LBUTTONDOWN, WM_LBUTTONUP, WM_LBUTTONDBLCLK
'添加消息 (后截获)
mSubclass.AddAfterMsgs WM_MOUSEWHEEL, WM_RBUTTONDOWN, WM_RBUTTONUP

'获取全部的消息
'mSubclass.AllAfterMsgs = True
'mSubclass.AllBeforeMsgs = True

[Summer006]

唉。。悲哀，看了半天都不知道what talk about。。。太打击我了

• 打赏
• 举报

回复 赞

[叶帆]

关键在无崩溃,不知道,你的是否能实现

• 打赏
• 举报

回复 赞

[jinjazz]

ms咋不管呢

• 打赏
• 举报

回复 赞

[rainstormmaster]

//关键在无崩溃,不知道,你的是否能实现

呵呵:),说的不错


其实无崩溃的话,处理消息循环也可以,不过开销太大了

• 打赏
• 举报

回复 赞

[mndsoft]

嗯，好，把复杂的东西简单化，这就是高手！

• 打赏
• 举报

回复 赞

[boyzhang]

用汇编的那种方法是用了两个类模块实现的.

我的只有一个类.

• 打赏
• 举报

回复 赞

[VBAHZ]

To boyzhang(张郎)(爱你爱到Windows没BUG的那天) :

除了CSubclass类模块再加一个演示窗体frmDemo外，哪里有第二个类？

也许楼主太不负责了，为什么只有一个类呢？

还请麻烦张郎老兄，把另一个类传上来看看，谢谢！

• 打赏
• 举报

回复 赞

[boyzhang]

@_@ #

不好意思,我以为楼主用的是PSCODE上的那个内嵌ASM的

子类化类模块.

• 打赏
• 举报

回复 赞

[boyzhang]

偶的类.
献丑了.

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "Class_Hook"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'模块描述
'---------------------------------------------------------------------------------------
' Date-Time : 2006-01-02 23:10:43
' Author : boyzhang[QQ:20437023]
' Purpose : 挂钩类
'---------------------------------------------------------------------------------------
'结构体
Private Type FunctionSPointerS
FunctionPtr As Long
FunctionAddress As Long
End Type
'API函数
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal HMEM As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal HMEM As Long) As Long
Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal HMEM As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'常数
Private Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_ZEROINIT As Long = &H40
'变量
Private mb_running As Boolean
Private mlng_memhandle As Long
Private mlng_proc As Long
Private mlng_handle As Long
Private mlng_hwnd As Long
'事件
Public Event NewMessage(ByVal hWnd As Long, ByRef FunctionPtr As Long, ByRef uMsg As Long, ByRef wParam As Long, ByRef lParam As Long, ByRef Cancel As Boolean)

'子类过程
Public Function SubClassProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim Bool As Boolean
'触发事件
RaiseEvent NewMessage(hWnd, SubClassProc, uMsg, wParam, lParam, Bool)
'消息是否返回原地址
If Bool = True Then Exit Function
'返回原地址
SubClassProc = CallWindowProc(mlng_handle, hWnd, uMsg, wParam, lParam)
End Function

'传函数指针
Public Function GetFunctionPtr()
GetFunctionPtr = mlng_proc
End Function

'挂钩
Public Sub Hook(ByVal hWnd As Long, Optional Style As Long = -4)
mlng_hwnd = hWnd
If Not mb_running Then
mb_running = True
mlng_handle = SetWindowLong(mlng_hwnd, Style, mlng_proc)
End If
End Sub

'脱钩
Public Sub UnHook()
If mb_running Then
SetWindowLong mlng_hwnd, (-4), mlng_handle
mb_running = False
End If
End Sub

'构造函数
Private Sub Class_Initialize()
'生成函数指针
Dim lng_fncptr As Long
Dim lng_objptr As Long
Dim lng_vtable As Long
Dim lng_ptx As Long
Dim lng_proc As Long
Dim lng_varnum As Long
Dim lng_objvarnum As Long
Dim lng_funcnum As Long
lng_objptr = ObjPtr(Me)
CopyMemory lng_vtable, ByVal lng_objptr, 4
lng_ptx = lng_vtable + 28 + (lng_varnum * 2 * 4) + (lng_objvarnum * 3 * 4) + lng_funcnum * 4
CopyMemory lng_fncptr, ByVal lng_ptx, 4
mlng_memhandle = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, 105)
mlng_proc = GlobalLock(mlng_memhandle)
DelegateFunction mlng_proc, Me, lng_fncptr, 4
End Sub

'析构函数
Private Sub Class_Terminate()
If mb_running Then UnHook
Call GlobalUnlock(mlng_memhandle)
Call GlobalFree(mlng_memhandle)
End Sub

'托管函数
Private Function DelegateFunction(ByVal CallingADR As Long, Obj As Object, ByVal MethodAddress As Long, ByVal NumberOfParameters As Byte)
Dim TmpA As Long
Dim u As Long
TmpA = CallingADR
CopyMemory ByVal CallingADR, &H68EC8B55, 4
CallingADR = CallingADR + 4
CopyMemory ByVal CallingADR, TmpA + 31 + (NumberOfParameters * 3) - 4, 4
CallingADR = CallingADR + 4
Dim StackP As Byte
StackP = 4 + 4 * NumberOfParameters
For u = 1 To NumberOfParameters
CopyMemory ByVal CallingADR, CInt(&H75FF), 2
CallingADR = CallingADR + 2
CopyMemory ByVal CallingADR, StackP, 1
CallingADR = CallingADR + 1
StackP = StackP - 4
Next u
CopyMemory ByVal CallingADR, CByte(&H68), 1
CallingADR = CallingADR + 1
CopyMemory ByVal CallingADR, ObjPtr(Obj), 4
CallingADR = CallingADR + 4
CopyMemory ByVal CallingADR, CByte(&HE8), 1
CallingADR = CallingADR + 1
Dim PERFCALL As Long
PERFCALL = CallingADR - TmpA - 1
PERFCALL = MethodAddress - (TmpA + (CallingADR - TmpA - 1)) - 5
CopyMemory ByVal CallingADR, PERFCALL, 4
CallingADR = CallingADR + 4
CopyMemory ByVal CallingADR, CByte(&HA1), 1
CallingADR = CallingADR + 1
CopyMemory ByVal CallingADR, TmpA + 31 + (NumberOfParameters * 3) - 4, 4
CallingADR = CallingADR + 4
CopyMemory ByVal CallingADR, CInt(&HC2C9), 2
CallingADR = CallingADR + 2
CopyMemory ByVal CallingADR, CInt(NumberOfParameters * 4), 2
End Function

• 打赏
• 举报

回复 赞

[RayLynn]

梦里寻她千白度```

• 打赏
• 举报

回复 赞

[daixinhou]

用这种技术调用类的时候，就不会出现崩溃的情况了？有点怀疑，不过先去试试。

• 打赏
• 举报

回复 赞

[boyzhang]

呵呵,我的子类化类是用函数指针写的,

用了一段时间,感觉还可以.

脱钩时如果出错的话,也可以正常停止,

只是,如果再次运行的话,就有可能会挂掉.

不过. :) 一般我都保存以后退出VB后再

进入. 呵呵,主要是一个类就实现了,

结构简单,调试起来也方便.

• 打赏
• 举报

回复 赞

[VBAHZ]

楼主的这个不就是类吗？

• 打赏
• 举报

回复 赞

[叶帆]

思路比较好，但是加中断点调试的时候，还是有崩溃和无法终止程序的现象。
这是我的调试代码 XP Sp2＋VB6
Option Explicit
Dim WithEvents ISubClass As Class_Hook

Private Sub Command1_Click()
MsgBox "dsfasd"
End Sub

Private Sub Form_Load()
Set ISubClass = New Class_Hook
ISubClass.Hook Me.hWnd
End Sub

Private Sub Form_Unload(Cancel As Integer)
ISubClass.UnHook
Set ISubClass = Nothing
End Sub

Private Sub ISubClass_NewMessage(ByVal hWnd As Long, FunctionPtr As Long, uMsg As Long, wParam As Long, lParam As Long, Cancel As Boolean)
Debug.Print Timer, uMsg, wParam, lParam
End Sub

• 打赏
• 举报

回复 赞

[kmlxk0]

强～！顶顶顶顶顶！

• 打赏
• 举报

回复 赞

[韧恒]

唉，怎么说呢，我见过的所有的方法都无可避免地出现一些问题，也许这已经是VB的极限了吧。恐怕与VB本身的实现结构有关。
另外还有个问题，引用叶兄的主题“第一种，也就是www.... 但是需要挂接一个COM组件，有背绿色软件之道....”，不明白叶兄所说的绿色软件是怎样的概念呢？如果挂接一个dll就不算绿色软件的话，那么第二种方法带上一个tlb就算绿色了么？
我一直在寻找一个将tlb移入VB中的方案，当然，如果tlb中仅是几个API声明到罢了，但要是声明了一些ole对象我们将如何在vb中创建它呢？

• 打赏
• 举报

回复 赞

[rise139]

好 这个无崩溃子类可否用来截获其他系统消息 如外壳消息 添加删除文件等等

• 打赏
• 举报

回复 赞

[boyzhang]

to:yefanqiu(叶帆:http://blog.csdn.net/yefanqiu)

呵呵,现丑了,COM我基本上不会.

这个代码也是看了几个老外的代码以后自己写的.

班门弄斧了. :)

• 打赏
• 举报

回复 赞

[proer9988]

good!

• 打赏
• 举报

回复 赞

[叶帆]

to songyaowu

这个dll指的是COM组件，它需要在注册表注册，非绿色
tlb文件仅仅是一个接口问题，便于你在VB中访问。正常情况下一个tlb（或多个）必须对应一个DLL（COM),但这一个特殊一些，它与Exe文件合在一起了，编译后，直接拷贝就可以使用，不需要注册，也不需要tlb文件。

• 打赏
• 举报

回复 赞