有时候需要监控某个指定的目录下的文件/文件夹操作记录，有不少群友们建议用定时器定时分析比较，这是比较累的做法。
其实操作系统提供了一些 api 可以实现这个需求，通过分析系统消息可以实时获取到文件系统的变化，从而取得需要的信息。
本项目来自 newxing，总共有一个模块文件，一个类模块文件，一个窗体文件，
其中窗体上放置一个 listbox控件，和一个按钮控件。然后引入这个 bas 和 cls 模块文件，就可以调用了，最终要写的业务代码就图中几行：看效果
哦，对了，还需要引用这两个东西：（其中 tlb 文件在本文底部可以下载）
以下给出源码：
模块代码：
modMonitorFolder.bas
'Download by http://www.NewXing.com
'保存接管之前的值
Public preMonitorFolderProc As Long
'保存热键对象句柄
Public objMonitorFolder As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
Private Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
Private Declare Function SHGetDesktopFolder Lib "shell32.dll" (ppshf As Folder) As Long
Private Const WM_NCDESTROY = &H82
Private Const GWL_WNDPROC = (-4)
Private Const OLDWNDPROC = "OldWndProc"
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal _
hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal _
hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal _
hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Const MAX_PATH = 260
Private Enum SHSpecialFolderIDs '列出所有Windows下特殊文件夹的ID
CSIDL_DESKTOP = &H0
CSIDL_INTERNET = &H1
CSIDL_PROGRAMS = &H2
CSIDL_CONTROLS = &H3
CSIDL_PRINTERS = &H4
CSIDL_PERSONAL = &H5
CSIDL_FAVORITES = &H6
CSIDL_STARTUP = &H7
CSIDL_RECENT = &H8
CSIDL_SENDTO = &H9
CSIDL_BITBUCKET = &HA
CSIDL_STARTMENU = &HB
CSIDL_DESKTOPDIRECTORY = &H10
CSIDL_DRIVES = &H11
CSIDL_NETWORK = &H12
CSIDL_NETHOOD = &H13
CSIDL_FONTS = &H14
CSIDL_TEMPLATES = &H15
CSIDL_COMMON_STARTMENU = &H16
CSIDL_COMMON_PROGRAMS = &H17
CSIDL_COMMON_STARTUP = &H18
CSIDL_COMMON_DESKTOPDIRECTORY = &H19
CSIDL_APPDATA = &H1A
CSIDL_PRINTHOOD = &H1B
CSIDL_ALTSTARTUP = &H1D
CSIDL_COMMON_ALTSTARTUP = &H1E
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum
Private Declare Function SHGetFileInfoPidl Lib "shell32" Alias "SHGetFileInfoA" _
(ByVal pidl As Long, _
ByVal dwFileAttributes As Long, _
psfib As SHFILEINFOBYTE, _
ByVal cbFileInfo As Long, _
ByVal uFlags As SHGFI_flags) As Long
Private Type SHFILEINFOBYTE
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName(1 To MAX_PATH) As Byte
szTypeName(1 To 80) As Byte
End Type
Enum SHGFI_flags
SHGFI_LARGEICON = &H0
SHGFI_SMALLICON = &H1
SHGFI_OPENICON = &H2
SHGFI_SHELLICONSIZE = &H4
SHGFI_PIDL = &H8
SHGFI_USEFILEATTRIBUTES = &H10
SHGFI_ICON = &H100
SHGFI_DISPLAYNAME = &H200
SHGFI_TYPENAME = &H400
SHGFI_ATTRIBUTES = &H800
SHGFI_ICONLOCATION = &H1000
SHGFI_EXETYPE = &H2000
SHGFI_SYSICONINDEX = &H4000
SHGFI_LINKOVERLAY = &H8000
SHGFI_SELECTED = &H10000
End Enum
Private m_hSHNotify As Long '系统消息通告句柄
Private m_PathPIDL As Long '被监视目录的PIDL
'定义系统通告的消息值
Private Const WM_SHNOTIFY = &H401
Private Type PIDLSTRUCT
pidl As Long
bWatchSubFolders As Long
End Type
Private Declare Function SHChangeNotifyRegister Lib "shell32" Alias "#2" _
(ByVal hWnd As Long, _
ByVal uFlags As SHCN_ItemFlags, _
ByVal dwEventID As SHCN_EventIDs, _
ByVal uMsg As Long, _
ByVal cItems As Long, _
lpps As PIDLSTRUCT) As Long
Private Declare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" _
(ByVal hNotify As Long) As Boolean
Private Enum SHCN_EventIDs
SHCNE_RENAMEITEM = &H1
SHCNE_CREATE = &H2
SHCNE_DELETE = &H4
SHCNE_MKDIR = &H8
SHCNE_RMDIR = &H10
SHCNE_MEDIAINSERTED = &H20
SHCNE_MEDIAREMOVED = &H40
SHCNE_DRIVEREMOVED = &H80
SHCNE_DRIVEADD = &H100
SHCNE_NETSHARE = &H200
SHCNE_NETUNSHARE = &H400
SHCNE_ATTRIBUTES = &H800
SHCNE_UPDATEDIR = &H1000
SHCNE_UPDATEITEM = &H2000
SHCNE_SERVERDISCONNECT = &H4000
SHCNE_UPDATEIMAGE = &H8000&
SHCNE_DRIVEADDGUI = &H10000
SHCNE_RENAMEFOLDER = &H20000
SHCNE_FREESPACE = &H40000
SHCNE_ASSOCCHANGED = &H8000000
SHCNE_DISKEVENTS = &H2381F
SHCNE_GLOBALEVENTS = &HC0581E0
SHCNE_ALLEVENTS = &H7FFFFFFF
SHCNE_INTERRUPT = &H80000000
End Enum
Private Enum SHCN_ItemFlags
SHCNF_IDLIST = &H0
SHCNF_PATHA = &H1
SHCNF_PRINTERA = &H2
SHCNF_DWORD = &H3
SHCNF_PATHW = &H5
SHCNF_PRINTERW = &H6
SHCNF_TYPE = &HFF
SHCNF_FLUSH = &H1000
SHCNF_FLUSHNOWAIT = &H2000
#If UNICODE Then
SHCNF_PATH = SHCNF_PATHW
SHCNF_PRINTER = SHCNF_PRINTERW
#Else
SHCNF_PATH = SHCNF_PATHA
SHCNF_PRINTER = SHCNF_PRINTERA
#End If
End Enum
Function SHNotify_Register(ByVal hWnd As Long, ByVal sMonitorPath As String, Optional ByVal bWatchSubFolder As Boolean = True) As Boolean
Dim PS As PIDLSTRUCT
If (m_hSHNotify = 0) Then
'获得被监视目录的PIDL
m_PathPIDL = GetPIDLFromPath(sMonitorPath)
If m_PathPIDL Then
PS.pidl = m_PathPIDL
PS.bWatchSubFolders = True
'注册Windows监视,将获得的句柄保存到m_hSHNotify中
m_hSHNotify = SHChangeNotifyRegister(hWnd, SHCNF_TYPE Or SHCNF_IDLIST, _
SHCNE_ALLEVENTS Or SHCNE_INTERRUPT, _
WM_SHNOTIFY, 1, PS)
SHNotify_Register = CBool(m_hSHNotify)
Else
Call CoTaskMemFree(m_PathPIDL)
End If
End If
End Function
Function SHNotify_Unregister() As Boolean
If m_hSHNotify Then
If SHChangeNotifyDeregister(m_hSHNotify) Then
m_hSHNotify = 0
Call CoTaskMemFree(m_PathPIDL)
m_PathPIDL = 0
SHNotify_Unregister = True
End If
End If
End Function
Private Sub NotificationReceipt(wParam As Long, lParam As Long)
End Sub
Private Function GetPIDLFromPath(ByVal sPath As String) As Long
Dim ISF As IShellFolder
Dim pidlMain As Long
Dim cParsed As Long
Dim afItem As Long
Dim lFilePos As Long
Dim lR As Long
Dim sRet As String * 255
lR = GetFullPathName(sPath, MAX_PATH, sRet, lFilePos)
sPath = Left$(sRet, lR)
'将路径名称转换成PIDL
Set ISF = GetDesktopFolder
Call ISF.ParseDisplayName(0&, 0&, StrConv(sPath, vbUnicode), cParsed, pidlMain, afItem)
GetPIDLFromPath = pidlMain
End Function
Private Function GetDesktopFolder() As IShellFolder
SHGetDesktopFolder GetDesktopFolder
End Function
Function GetDisplayNameFromPIDL(pidl As Long) As String
Dim sfib As SHFILEINFOBYTE
If SHGetFileInfoPidl(pidl, 0, sfib, Len(sfib), SHGFI_PIDL Or SHGFI_DISPLAYNAME Or SHGFI_TYPENAME Or SHGFI_USEFILEATTRIBUTES Or SHGFI_ICON Or SHGFI_DISPLAYNAME Or SHGFI_TYPENAME Or SHGFI_ATTRIBUTES Or SHGFI_EXETYPE) Then
GetDisplayNameFromPIDL = GetStrFromBufferA(StrConv(sfib.szDisplayName, vbUnicode))
End If
End Function
Private Function GetStrFromBufferA(sz As String) As String
If InStr(sz, vbNullChar) Then
GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
Else
GetStrFromBufferA = sz
End If
End Function
Public Function SubClass(hWnd As Long) As Boolean
Dim lpfnOld As Long
Dim fSuccess As Boolean
If (GetProp(hWnd, OLDWNDPROC) = 0) Then
lpfnOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WndProc)
If lpfnOld Then
fSuccess = SetProp(hWnd, OLDWNDPROC, lpfnOld)
End If
End If
If fSuccess Then
SubClass = True
Else
If lpfnOld Then Call UnSubClass(hWnd)
MsgBox "Unable to successfully subclass &H" & Hex(hWnd), vbCritical
End If
End Function
Public Function UnSubClass(hWnd As Long) As Boolean
Dim lpfnOld As Long
lpfnOld = GetProp(hWnd, OLDWNDPROC)
If lpfnOld Then
If RemoveProp(hWnd, OLDWNDPROC) Then
UnSubClass = SetWindowLong(hWnd, GWL_WNDPROC, lpfnOld)
End If
End If
End Function
Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As _
Long, ByVal lParam As Long) As Long
Select Case uMsg
Case WM_SHNOTIFY '处理系统消息通告函数
'返回热键的ID
ptrMonitorFolder.FireEvent wParam, lParam
' Call NotificationReceipt(wParam, lParam)
Case WM_NCDESTROY
Call UnSubClass(hWnd)
End Select
WndProc = CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
End Function
'处理目录监视指针问题
Private Function ptrMonitorFolder() As cyMonitorFolder
Dim MF As cyMonitorFolder
CopyMemory MF, objMonitorFolder, 4&
Set ptrMonitorFolder = MF
CopyMemory MF, 0&, 4&
End Function
类模块代码：
cyMonitorFolder.cls
Option Explicit
'Download by http://www.NewXing.com
'保存目录监视接收窗口
Dim m_iMonitorFolderHwnd As Long
'激活的事件
Public Event cyFolderChangeEvent(ByVal sEventString As String, ByVal sFile1 As String, ByVal sFile2 As String)
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, _
pSource As Any, ByVal dwLength As Long)
Private Type SHNOTIFYSTRUCT
dwItem1 As Long
dwItem2 As Long
End Type
Public Sub cySetMonitorFolder(ByVal hWnd As Long, ByVal sMonitorPath As String, Optional ByVal bWatchSubFolder As Boolean = False)
'保存目录监视接收窗口
m_iMonitorFolderHwnd = hWnd
'获得本身的objprt
modMonitorFolder.objMonitorFolder = ObjPtr(Me)
If SubClass(hWnd) Then '改变Form1的消息处理函数
Call SHNotify_Register(m_iMonitorFolderHwnd, sMonitorPath, bWatchSubFolder)
End If
End Sub
Private Sub Class_Terminate()
Call SHNotify_Unregister
Call UnSubClass(m_iMonitorFolderHwnd)
End Sub
'激活事件
Friend Function FireEvent(ByVal wParam As Long, ByVal lParam As Long)
Dim SHNS As SHNOTIFYSTRUCT
Dim sDisplayName1 As String
Dim sDisplayName2 As String
Const SHCNE_RENAMEITEM = &H1
Const SHCNE_CREATE = &H2
Const SHCNE_DELETE = &H4
Const SHCNE_MKDIR = &H8
Const SHCNE_RMDIR = &H10
Const SHCNE_MEDIAINSERTED = &H20
Const SHCNE_MEDIAREMOVED = &H40
Const SHCNE_DRIVEREMOVED = &H80
Const SHCNE_DRIVEADD = &H100
Const SHCNE_NETSHARE = &H200
Const SHCNE_UPDATEDIR = &H1000
Const SHCNE_UPDATEITEM = &H2000
Const SHCNE_SERVERDISCONNECT = &H4000
Const SHCNE_UPDATEIMAGE = &H8000&
Const SHCNE_DRIVEADDGUI = &H10000
Const SHCNE_RENAMEFOLDER = &H20000
Const SHCNE_FREESPACE = &H40000
Const SHCNE_ASSOCCHANGED = &H8000000
MoveMemory SHNS, ByVal wParam, Len(SHNS)
If SHNS.dwItem1 Then
sDisplayName1 = GetDisplayNameFromPIDL(SHNS.dwItem1)
End If
If SHNS.dwItem2 Then
sDisplayName2 = GetDisplayNameFromPIDL(SHNS.dwItem2)
End If
Select Case lParam
Case SHCNE_RENAMEITEM: RaiseEvent cyFolderChangeEvent("重命名文件", sDisplayName1, sDisplayName2)
Case SHCNE_CREATE: RaiseEvent cyFolderChangeEvent("建立文件 文件名", sDisplayName1, sDisplayName2)
Case SHCNE_DELETE: RaiseEvent cyFolderChangeEvent("删除文件 文件名", sDisplayName1, sDisplayName2)
Case SHCNE_MKDIR: RaiseEvent cyFolderChangeEvent("新建目录 目录名", sDisplayName1, sDisplayName2)
Case SHCNE_RMDIR: RaiseEvent cyFolderChangeEvent("删除目录 目录名", sDisplayName1, sDisplayName2)
Case SHCNE_MEDIAINSERTED: RaiseEvent cyFolderChangeEvent("插入可移动存储介质", sDisplayName1, sDisplayName2)
Case SHCNE_MEDIAREMOVED: RaiseEvent cyFolderChangeEvent("移去可移动存储介质", sDisplayName1, sDisplayName2)
Case SHCNE_DRIVEREMOVED: RaiseEvent cyFolderChangeEvent("移去驱动器", sDisplayName1, sDisplayName2)
Case SHCNE_DRIVEADD: RaiseEvent cyFolderChangeEvent("添加驱动器", sDisplayName1, sDisplayName2)
Case SHCNE_NETSHARE: RaiseEvent cyFolderChangeEvent("改变目录的共享属性", sDisplayName1, sDisplayName2)
Case SHCNE_UPDATEDIR: RaiseEvent cyFolderChangeEvent("更新目录", sDisplayName1, sDisplayName2)
Case SHCNE_UPDATEITEM: RaiseEvent cyFolderChangeEvent("更新文件 文件名", sDisplayName1, sDisplayName2)
Case SHCNE_SERVERDISCONNECT: RaiseEvent cyFolderChangeEvent("断开与服务器的连", sDisplayName1, sDisplayName2)
Case SHCNE_UPDATEIMAGE: RaiseEvent cyFolderChangeEvent("SHCNE_UPDATEIMAGE", sDisplayName1, sDisplayName2)
Case SHCNE_DRIVEADDGUI: RaiseEvent cyFolderChangeEvent("SHCNE_DRIVEADDGUI", sDisplayName1, sDisplayName2)
Case SHCNE_RENAMEFOLDER: RaiseEvent cyFolderChangeEvent("重命名文件夹", sDisplayName1, sDisplayName2)
Case SHCNE_FREESPACE: RaiseEvent cyFolderChangeEvent("磁盘空间大小改变", sDisplayName1, sDisplayName2)
Case SHCNE_ASSOCCHANGED: RaiseEvent cyFolderChangeEvent("改变文件关联", sDisplayName1, sDisplayName2)
End Select
End Function
窗体代码：
frmMain.frm
Public sOut1 As String, s_flg As Integer
Dim WithEvents MF As cyMonitorFolder
'Download by http://www.NewXing.com
Private Sub Command1_Click()
Set MF = New cyMonitorFolder
MF.cySetMonitorFolder Me.hWnd, "d:\a"
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call SHNotify_Unregister
Call UnSubClass(hWnd)
End Sub
Private Sub MF_cyFolderChangeEvent(ByVal sEventString As String, ByVal sFile1 As String, ByVal sFile2 As String)
List1.AddItem Now & vbTab & sEventString & "：" & sFile1 & "=》" & sFile2, 0
End Sub
这里就是调用示例了，使用非常简单，引入前面的2个模块代码之后，在业务代码这里的窗体按钮事件里面启动监控，并设置好需要监控的目录地址，就完事了，
接下来该目录下的任何文件变动都会在类模块的事件里面触发，此示例演示了把变动的信息输出到窗体的 listbox 里面。
本项目用到的tlb文件
阿鬼建议把模块文件合并到类模块里面，有时间可以整理试试：
把回调指向类的成员函数，就可以干掉模块了
还能实现事件，何乐而不为呢
定格建议使用更简单的 api 来实现：
“FindFirstChangeNotification”
“FindNextChangeNotification”
这里我用 ai 拿了一个示例代码，未经测试：
使用 API 函数在 VB6 中实现目录更改监控 – VB6.PRO
https://vb6.pro/vi/677
另外有一个函数也可以实现，不过较为复杂
使用vb6写一个调用 ReadDirectoryChangesW 实现目录更改监控的示例 – VB6.PRO
https://vb6.pro/vi/680
Views: 111
