擷取Windows 外殼資訊通知（VB源程式）

從網上看了一篇《分享windows的秘密－外殼通知消息》的文章，感覺很不錯，可是它是delphi的程式，和VB相差很大，API在VB中沒有對應的聲明，并且一些結構體在VB中沒有現成的定義，是以很是研究了一番，優盤的插入、拔出，CD光牒的插入、取出都有了相應的通知，效果不錯。

可以接收的消息如下：

SHCNE_ASSOCCHANGED  一個檔案關聯被改變了
  SHCNE_ATTRIBUTES    一個項目或檔案夾的屬性被改變了
  SHCNE_CREATE        檔案夾的外殼成員被建立了
  SHCNE_DELETE        非檔案夾的外殼成員被删除了
  SHCNE_DRIVEADD      添加了一個驅動器
  SHCNE_DRIVEADDGUI   通過外殼添加的驅動器
  SHCNE_DRIVEREMOVED  一個驅動器被删除了
  SHCNE_EXTENDED_EVENT  未被使用
  SHCNE_FREESPACE     驅動器的自由空間數有了變化
  SHCNE_MEDIAINSERTED  存儲媒體被插入到驅動器中
  SHCNE_MEDIAREMOVED  存儲媒體從驅動器中被删除
  SHCNE_MKDIR         一個目錄被建立
  SHCNE_NETSHARE      本地的目錄被共享
  SHCNE_NETUNSHARE    本地目錄被取消共享
  SHCNE_RENAMEFOLDER  檔案夾名稱被改變
  SHCNE_RENAMEITEM    非檔案的外殼對象的名稱被改變
  SHCNE_RMDIR         一個檔案夾被删除
  SHCNE_SERVERDISCONNECT  計算機被伺服器斷開
  SHCNE_UPDATEDIR     一個檔案夾中的内容被改變
  SHCNE_UPDATEIMAGE   系統圖像清單中的一個圖像被改變
  SHCNE_UPDATEITEM    一個非檔案夾外殼對象的名稱被改變           

運作後的截圖：

關鍵源碼：

'*************************************************************************
'**函 數 名：WindowProc
'**輸    入：ByVal hwnd(Long)   -
'**        ：ByVal uMsg(Long)   -
'**        ：ByVal wParam(Long) -
'**        ：ByVal lParam(Long) -
'**輸    出：(Long) -
'**功能描述：子類函數
'**全局變量：
'**調用子產品：
'**作    者：葉帆
'**日    期：2005年12月23日
'**修 改 人：
'**日    期：
'**版    本：V1.0
'*************************************************************************
Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    '-------------------------------
    Dim i As Long
    If uMsg = WM_YFSYSMSG Then
        For i = 0 To 20
            If (lParam And lngFlag(i)) > 0 Then
                frmSysmsg.lstMsg.AddItem Format(Now, "HH:MM:SS") & " " & strFlag(i)
            End If
        Next
        Exit Function
    End If
    
    '-------------------------------
    WindowProc = CallWindowProc(lngPreWinProc, hwnd, uMsg, wParam, lParam)
End Function

'*************************************************************************
'**函 數 名：ISubProc
'**輸    入：hwnd(Long) - 視窗句柄
'**輸    出：無
'**功能描述：
'**全局變量：
'**調用子產品：安裝子類
'**作    者：葉帆
'**日    期：2005-12-23 11:41:37
'**修 改 人：
'**日    期：
'**版    本：V1.0.0
'*************************************************************************
Public Sub ISubProc(hwnd As Long)
    '記錄原本的Window Procedure的位址
    lngPreWinProc = GetWindowLong(hwnd, GWL_WNDPROC)
    Call SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

'*************************************************************************
'**函 數 名：UnISubProc
'**輸    入：hwnd(Long) - 視窗句柄
'**輸    出：無
'**功能描述：解除安裝子類
'**全局變量：
'**調用子產品：
'**作    者：葉帆
'**日    期：2005-12-23 11:43:53
'**修 改 人：
'**日    期：
'**版    本：V1.0.0
'*************************************************************************
Public Sub UnISubProc(hwnd As Long)
    '取消Message的截取，而使之又隻送往原來的Window Procedure
    Call SetWindowLong(hwnd, GWL_WNDPROC, lngPreWinProc)
End Sub

'*************************************************************************
'**函 數 名：SysMsgRegister
'**輸    入：無
'**輸    出：無
'**功能描述：消息注冊
'**全局變量：
'**調用子產品：
'**作    者：葉帆
'**日    期：2005-12-23 13:18:02
'**修 改 人：
'**日    期：
'**版    本：V1.0.0
'*************************************************************************
Public Sub SysMsgRegister(hwnd As Long)
    Dim nr As NotifyRegister

    lngFlag = Array(SHCNE_ASSOCCHANGED, _
              SHCNE_ATTRIBUTES, _
              SHCNE_CREATE, _
              SHCNE_DELETE, _
              SHCNE_DRIVEADD, _
              SHCNE_DRIVEADDGUI, _
              SHCNE_DRIVEREMOVED, _
              SHCNE_EXTENDED_EVENT, _
              SHCNE_FREESPACE, _
              SHCNE_MEDIAINSERTED, _
              SHCNE_MEDIAREMOVED, _
              SHCNE_MKDIR, _
              SHCNE_NETSHARE, _
              SHCNE_NETUNSHARE, _
              SHCNE_RENAMEFOLDER, _
              SHCNE_RENAMEITEM, _
              SHCNE_RMDIR, _
              SHCNE_SERVERDISCONNECT, _
              SHCNE_UPDATEDIR, _
              SHCNE_UPDATEIMAGE, _
              SHCNE_UPDATEITEM)

    strFlag = Array("檔案關聯被改變", _
              "檔案夾屬性被改變", _
              "檔案夾外殼成員被建立", _
              "非檔案夾外殼成員被删除", _
              "添加了一個驅動器", _
              "通過外殼添加的驅動器", _
              "一個驅動器被删除了", _
              "未使用", _
              "驅動器自由空間發生變化", _
              "存儲媒體插入驅動器", _
              "存儲媒體被移除", _
              "一個目錄被建立", _
              "本地目錄被共享", _
              "本地目錄被取消共享", _
              "檔案夾名稱被改變", _
              "非檔案的外殼對象名稱被改變", _
              "一個檔案夾被删除", _
              "計算機被伺服器斷開", _
              "一個檔案夾的内容被改變", _
              "系統圖像清單中的一個圖像被改變", _
              "一個非檔案夾外殼對象的名稱被改變")

    lngHandle = SHChangeNotifyRegister(hwnd, SHCNF_ACCEPT_INTERRUPTS Or SHCNF_ACCEPT_NON_INTERRUPTS, SHCNE_ALLEVENTS, WM_YFSYSMSG, 1, nr)
    If lngHandle > 0 Then
        frmSysmsg.picFlag.BackColor = RGB(0, 200, 0)
    Else
        frmSysmsg.picFlag.BackColor = RGB(255, 0, 0)
    End If
End Sub

'*************************************************************************
'**函 數 名：UnSysMsgRegister
'**輸    入：無
'**輸    出：無
'**功能描述：取消注冊
'**全局變量：
'**調用子產品：
'**作    者：葉帆
'**日    期：2005-12-23 13:19:06
'**修 改 人：
'**日    期：
'**版    本：V1.0.0
'*************************************************************************
Public Sub UnSysMsgRegister()
    If lngHandle > 0 Then
        SHChangeNotifyDeregister lngHandle
    End If
End Sub           

在Windows XP / VB 6.0環境下測試成功。

源代碼下載下傳位址：

http://www.sky-walker.com.cn/YeFan/SourceCode/yfsysmsg.rar