获取Windows 外壳信息通知（VB源程序）

从网上看了一篇《分享windows的秘密－外壳通知消息》的文章，感觉很不错，可是它是delphi的程序，和VB相差很大，API在VB中没有对应的声明，并且一些结构体在VB中没有现成的定义，所以很是研究了一番，优盘的插入、拔出，光盘的插入、取出都有了相应的通知，效果不错。

可以接收的消息如下：

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.bjjr.com.cn/YeFan/SourceCode/yfsysmsg.rar

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