無崩潰（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.sky-walker.com.cn/YeFan/SourceCode/ISubClass.rar