获取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.sky-walker.com.cn/YeFan/SourceCode/yfsysmsg.rar

【叶帆源码】获取Windows 外壳信息通知

12-23

从网上看了一篇《分享windows的秘密-外壳通知消息》的文章,感觉很不错,可是它是delphi的程序,和VB相差很大,API在VB中没有对应的声明,并且一些结构体在VB中没有现成的定义,所以很是研究了一番,优盘的插入、拔出,光盘的插入、取出都有了相应的通知,效果不错。rnrn 可以接收的消息如下:rnrn SHCNE_ASSOCCHANGED 一个文件关联被改变了rn SHCNE_ATTRIBUTES 一个项目或文件夹的属性被改变了rn SHCNE_CREATE 文件夹的外壳成员被创建了rn SHCNE_DELETE 非文件夹的外壳成员被删除了rn SHCNE_DRIVEADD 添加了一个驱动器rn SHCNE_DRIVEADDGUI 通过外壳添加的驱动器rn SHCNE_DRIVEREMOVED 一个驱动器被删除了rn SHCNE_EXTENDED_EVENT 未被使用rn SHCNE_FREESPACE 驱动器的自由空间数有了变化rn SHCNE_MEDIAINSERTED 存储介质被插入到驱动器中rn SHCNE_MEDIAREMOVED 存储介质从驱动器中被删除rn SHCNE_MKDIR 一个目录被创建rn SHCNE_NETSHARE 本地的目录被共享rn SHCNE_NETUNSHARE 本地目录被取消共享rn SHCNE_RENAMEFOLDER 文件夹名称被改变rn SHCNE_RENAMEITEM 非文件的外壳对象的名称被改变rn SHCNE_RMDIR 一个文件夹被删除rn SHCNE_SERVERDISCONNECT 计算机被服务器断开rn SHCNE_UPDATEDIR 一个文件夹中的内容被改变rn SHCNE_UPDATEIMAGE 系统图像列表中的一个图像被改变rn SHCNE_UPDATEITEM 一个非文件夹外壳对象的名称被改变rnrnrn 【文章链接】http://blog.csdn.net/yefanqiu/archive/2005/12/23/560234.aspxrn 【源码地址】http://www.bjjr.com.cn/YeFan/SourceCode/yfsysmsg.rarrn 【示例图片】http://blog.csdn.net/images/blog_csdn_net/yefanqiu/23649/o_Test.jpgrn 【关键源码】rn rn'*************************************************************************rn'**函 数 名:SysMsgRegisterrn'**输 入:无rn'**输 出:无rn'**功能描述:消息注册rn'**全局变量:rn'**调用模块:rn'**作 者:叶帆rn'**日 期:2005-12-23 13:18:02rn'**修 改 人:rn'**日 期:rn'**版 本:V1.0.0rn'*************************************************************************rnPublic Sub SysMsgRegister(hwnd As Long)rn Dim nr As NotifyRegisterrnrn lngFlag = Array(SHCNE_ASSOCCHANGED, _rn SHCNE_ATTRIBUTES, _rn SHCNE_CREATE, _rn SHCNE_DELETE, _rn SHCNE_DRIVEADD, _rn SHCNE_DRIVEADDGUI, _rn SHCNE_DRIVEREMOVED, _rn SHCNE_EXTENDED_EVENT, _rn SHCNE_FREESPACE, _rn SHCNE_MEDIAINSERTED, _rn SHCNE_MEDIAREMOVED, _rn SHCNE_MKDIR, _rn SHCNE_NETSHARE, _rn SHCNE_NETUNSHARE, _rn SHCNE_RENAMEFOLDER, _rn SHCNE_RENAMEITEM, _rn SHCNE_RMDIR, _rn SHCNE_SERVERDISCONNECT, _rn SHCNE_UPDATEDIR, _rn SHCNE_UPDATEIMAGE, _rn SHCNE_UPDATEITEM)rnrn strFlag = Array("文件关联被改变", _rn "文件夹属性被改变", _rn "文件夹外壳成员被创建", _rn "非文件夹外壳成员被删除", _rn "添加了一个驱动器", _rn "通过外壳添加的驱动器", _rn "一个驱动器被删除了", _rn "未使用", _rn "驱动器自由空间发生变化", _rn "存储介质插入驱动器", _rn "存储介质被移除", _rn "一个目录被创建", _rn "本地目录被共享", _rn "本地目录被取消共享", _rn "文件夹名称被改变", _rn "非文件的外壳对象名称被改变", _rn "一个文件夹被删除", _rn "计算机被服务器断开", _rn "一个文件夹的内容被改变", _rn "系统图像列表中的一个图像被改变", _rn "一个非文件夹外壳对象的名称被改变")rnrn lngHandle = SHChangeNotifyRegister(hwnd, SHCNF_ACCEPT_INTERRUPTS Or SHCNF_ACCEPT_NON_INTERRUPTS, SHCNE_ALLEVENTS, WM_YFSYSMSG, 1, nr)rn If lngHandle > 0 Thenrn frmSysmsg.picFlag.BackColor = RGB(0, 200, 0)rn Elsern frmSysmsg.picFlag.BackColor = RGB(255, 0, 0)rn End IfrnEnd Subrnrn'*************************************************************************rn'**函 数 名:UnSysMsgRegisterrn'**输 入:无rn'**输 出:无rn'**功能描述:取消注册rn'**全局变量:rn'**调用模块:rn'**作 者:叶帆rn'**日 期:2005-12-23 13:19:06rn'**修 改 人:rn'**日 期:rn'**版 本:V1.0.0rn'*************************************************************************rnPublic Sub UnSysMsgRegister()rn If lngHandle > 0 Thenrn SHChangeNotifyDeregister lngHandlern End IfrnEnd Subrnrnrn rn

没有更多推荐了,返回首页

私密
私密原因:
请选择设置私密原因
  • 广告
  • 抄袭
  • 版权
  • 政治
  • 色情
  • 无意义
  • 其他
其他原因:
120
出错啦
系统繁忙,请稍后再试