请问怎样监视目录的变化

我有相关的源码，要的就留下EMail.

源码如下：
mDef.Bas
-------------
Option ExplicitDeclare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, _
        pSource As Any, ByVal dwLength As Long)
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)Public Const MAX_PATH = 260
Public Const NOERROR = 0'SHGetSpecialFolderLocation获得某一个特殊的目录的位置,如果函数调用成功返回NOERROR
'或者一个OLE错误
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
                              (ByVal hwndOwner As Long, _
                              ByVal nFolder As SHSpecialFolderIDs, _
                              pidl As Long) As LongPublic 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'SHGetPathFromIDList函数将一个Item转换为文件路径
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
                              (ByVal pidl As Long, _
                              ByVal pszPath As String) As Long'SHGetFileInfoPidl函数获得某个文件对象的信息。
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 LongPublic 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 TypeDeclare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" _
                              (ByVal pszPath As String, _
                              ByVal dwFileAttributes As Long, _
                              psfi As SHFILEINFO, _
                              ByVal cbFileInfo As Long, _
                              ByVal uFlags As SHGFI_flags) As LongPublic Type SHFILEINFO
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End TypeEnum 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'根据一个特定文件夹对象的ID获得它的目录pidl
Public Function GetPIDLFromFolderID(hOwner As Long, nFolder As SHSpecialFolderIDs) As Long
    Dim pidl As Long
    If SHGetSpecialFolderLocation(hOwner, nFolder, pidl) = NOERROR Then
        GetPIDLFromFolderID = pidl
    End If
End Function'这里是根据Pidl获得文件的名称Public Function GetDisplayNameFromPIDL(pidl As Long) As String
    Dim sfib As SHFILEINFOBYTE
    If SHGetFileInfoPidl(pidl, 0, sfib, Len(sfib), SHGFI_PIDL Or SHGFI_DISPLAYNAME) Then
        GetDisplayNameFromPIDL = GetStrFromBufferA(StrConv(sfib.szDisplayName, vbUnicode))
    End If
End Function'这里是根据Pidl获得文件的路径及名称Public Function GetPathFromPIDL(pidl As Long) As String
    Dim sPath As String * MAX_PATH
    If SHGetPathFromIDList(pidl, sPath) Then
        GetPathFromPIDL = GetStrFromBufferA(sPath)
    End If
End FunctionPublic 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

续上：Shell1.Bas
------------------------
Option ExplicitPrivate m_hSHNotify As Long     '系统消息通告句柄
Private m_pidlDesktop As Long'定义系统通告的消息值
Public Const WM_SHNOTIFY = &H401Public Type PIDLSTRUCT
    pidl As Long
    bWatchSubFolders As Long
End TypeDeclare 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 LongType SHNOTIFYSTRUCT
    dwItem1 As Long
    dwItem2 As Long
End TypeDeclare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" _
        (ByVal hNotify As Long) As BooleanDeclare Sub SHChangeNotify Lib "shell32" _
                        (ByVal wEventId As SHCN_EventIDs, _
                        ByVal uFlags As SHCN_ItemFlags, _
                        ByVal dwItem1 As Long, _
                        ByVal dwItem2 As Long)Public 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#If (WIN32_IE >= &H400) Then
    Public Const SHCNEE_ORDERCHANGED = &H2
#End IfPublic 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 EnumPublic Function SHNotify_Register(hWnd As Long) As Boolean
    Dim ps As PIDLSTRUCT

    If (m_hSHNotify = 0) Then

        m_pidlDesktop = GetPIDLFromFolderID(0, CSIDL_DESKTOP)
        If m_pidlDesktop Then

            ps.pidl = m_pidlDesktop
            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_pidlDesktop)
        End If
    End If
End FunctionPublic Function SHNotify_Unregister() As Boolean
    If m_hSHNotify Then
        If SHChangeNotifyDeregister(m_hSHNotify) Then
            m_hSHNotify = 0
            Call CoTaskMemFree(m_pidlDesktop)
            m_pidlDesktop = 0
            SHNotify_Unregister = True
        End If
    End If
End FunctionPublic Function SHNotify_GetEventStr(strPath1, strPath2 As String, dwEventID As Long) As String
    Dim sEvent As String

    Select Case dwEventID
        Case SHCNE_RENAMEITEM: sEvent = "重命名文件" + strPath1 + "为" + strPath2
        Case SHCNE_CREATE: sEvent = "建立文件文件名：" + strPath1
        Case SHCNE_DELETE: sEvent = "删除文件文件名：" + strPath1: Form1.Text2.Text = sEvent
        Case SHCNE_MKDIR: sEvent = "新建目录目录名：" + strPath1
        Case SHCNE_RMDIR: sEvent = "删除目录目录名：" + strPath1
        Case SHCNE_MEDIAINSERTED: sEvent = strPath1 + "中插入可移动存储介质"
        Case SHCNE_MEDIAREMOVED: sEvent = strPath1 + "中移去可移动存储介质"
        Case SHCNE_DRIVEREMOVED: sEvent = "移去驱动器" + strPath1
        Case SHCNE_DRIVEADD: sEvent = "添加驱动器" + strPath1
        Case SHCNE_NETSHARE: sEvent = "改变目录" + strPath1 + "的共享属性"
        Case SHCNE_UPDATEDIR: sEvent = "更新目录" + strPath1
        Case SHCNE_UPDATEITEM: sEvent = "更新文件文件名：" + strPath1
        Case SHCNE_SERVERDISCONNECT: sEvent = "断开与服务器的连" + strPath1 + "  " + strPath2
        Case SHCNE_UPDATEIMAGE: sEvent = "SHCNE_UPDATEIMAGE"
        Case SHCNE_DRIVEADDGUI: sEvent = "SHCNE_DRIVEADDGUI"
        Case SHCNE_RENAMEFOLDER: sEvent = "重命名文件夹" + strPath1 + "为" + strPath2
        Case SHCNE_FREESPACE: sEvent = "磁盘空间大小改变"

        Case SHCNE_ASSOCCHANGED: sEvent = "改变文件关联"
    End Select

    SHNotify_GetEventStr = sEvent
End Function
-----------
mSub.Bas
------------------------
Option ExplicitPrivate 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 LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
        (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate 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 LongPublic 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 FunctionPublic 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 FunctionPublic 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        '处理系统消息通告函数
            Call Form1.NotificationReceipt(wParam, lParam)
        Case WM_NCDESTROY
            Call UnSubClass(hWnd)
            MsgBox "Unubclassed &H" & Hex(hWnd), vbCritical, "WndProc Error"
    End Select

    WndProc = CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
End Function

上面这段代码我有，它的功能太强了，我用不到，其实我只要一段很简单的程序就ok了,不过也谢谢了
我的mail是[email protected]
如果合用，我会加分的

Private Sub Timer1_Timer()
    Dim tStr As String
    Dim tDir As String
    tDir = Dir("c:\111\*.*", vbDirectory)
    Do While tDir <> ""
        If tDir <> "" Then
            tStr = tStr & vbCrLf & tDir
        End If
        tDir = Dir
    Loop
    If Me.Text1 <> tStr Then Me.Text1 = tStr
End Sub找的时候会找到“.”和“..”，这两个是当前目录和上级目录的意思
如果没有用可以用代码屏蔽掉

调试易

请问怎样监视目录的变化

解决方案 »