无崩溃（VB IDE）子类技术实现

凡是用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

'添加子类
mSubclass.Subclass hWnd, Me
End Sub

'*************************************************************************
'**函 数 名：Form_Unload
'**输 入：Cancel(Integer) -
'**输 出：无
'**功能描述：卸载子类
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2006-01-02 17:35:16
'**修 改 人：
'**日 期：
'**版 本：V1.0.0
'*************************************************************************
Private Sub Form_Unload(Cancel As Integer)
mSubclass.UnSubclass
End Sub

'*************************************************************************
'**函 数 名：ISubclassingSink_After
'**输 入：lReturn(Long) -
'** ：ByVal hwnd(Long) -
'** ：ByVal uMsg(Long) -
'** ：ByVal wParam(Long) -
'** ：ByVal lParam(Long) -
'**输 出：无
'**功能描述：
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2006-01-02 17:36:40
'**修 改 人：
'**日 期：
'**版 本：V1.0.0
'*************************************************************************
Private Sub ISubclassingSink_After(lReturn As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Debug.Print "ISubclassingSink_After " & " - " & Hex(uMsg) & " - " & Timer
End Sub

'*************************************************************************
'**函 数 名：ISubclassingSink_Before
'**输 入：bHandled(Boolean) -
'** ：lReturn(Long) -
'** ：hwnd(Long) -
'** ：uMsg(Long) -
'** ：wParam(Long) -
'** ：lParam(Long) -
'**输 出：无
'**功能描述：
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2006-01-02 17:36:41
'**修 改 人：
'**日 期：
'**版 本：V1.0.0
'*************************************************************************
Private Sub ISubclassingSink_Before(bHandled As Boolean, lReturn As Long, hWnd As Long, uMsg As Long, wParam As Long, lParam As Long)
Debug.Print "ISubclassingSink_Before " & " - " & Hex(uMsg) & " - " & Timer
'bHandled = True 'ISubclassingSink_After消息不在触发,并且该消息不向原窗体下发
'lReturn=mSubclass.CallOrigWndProc(uMsg, wParam, lParam) '向原窗体发送消息
End Sub
类的代码就不在列举了，请大家看源码

源码下载地址：http://www.bjjr.com.cn/YeFan/SourceCode/ISubClass.rar

<iframe align="center" marginwidth="0" marginheight="0" src="http://www.zealware.com/csdnblog.html" frameborder="0" width="728" scrolling="no" height="90"></iframe>