从网上看了一篇《分享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 IfEnd Sub
'*************************************************************************'**函 数 名：UnSysMsgRegister'**输 入：无'**输 出：无'**功能描述：取消注册'**全局变量：'**调用模块：'**作 者：叶帆'**日 期：2005-12-23 13:19:06'**修 改 人：'**日 期：'**版 本：V1.0.0'*************************************************************************Public Sub UnSysMsgRegister() If lngHandle > 0 Then SHChangeNotifyDeregister lngHandle End IfEnd Sub
在Windows XP / VB 6.0环境下测试成功。源代码下载地址：http://www.sky-walker.com.cn/YeFan/SourceCode/yfsysmsg.rar
