说三道四技术文摘-感悟人生的经典句子
说三道四 > 文档快照

请问怎样监视目录的变化

编辑:说三道四文库 发布时间:2018-02-24 06:24
HTML文档下载 WORD文档下载 PDF文档下载
请问怎样监视目录的变化
就是增加和删除目录能监视的到,
比如我 监视c:\111
那么c:\111里增加222的目录和333的目录,我能马上知道并放映到text1.text或list里
list里时时列出c:\111\的目录一增加c:\111\222
list里就多一个222
删掉222
list里就少个222
需要源代码
能用的立即加分

用timer控件
http://www.21code.com/codebase/?pos=down&id=273
http://www.21code.com/codebase/?pos=down&id=274
看看这两个程序
我有相关的源码,要的就留下EMail.
源码如下:
mDef.Bas
-------------
Option Explicit

Declare 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 Long

Public 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 Long

Public 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

Declare 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 Long

Public Type SHFILEINFO
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
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

'根据一个特定文件夹对象的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 Function

Public 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 Explicit

Private m_hSHNotify As Long     '系统消息通告句柄
Private m_pidlDesktop As Long

'定义系统通告的消息值
Public Const WM_SHNOTIFY = &H401

Public Type PIDLSTRUCT
    pidl As Long
    bWatchSubFolders As Long
End Type

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

Type SHNOTIFYSTRUCT
    dwItem1 As Long
    dwItem2 As Long
End Type

Declare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" _
        (ByVal hNotify As Long) As Boolean

Declare 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 If

Public 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

Public 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 Function

Public 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 Function

Public 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 Explicit

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

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

Public 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是admint@163.com
如果合用,我会加分的
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

找的时候会找到“.”和“..”,这两个是当前目录和上级目录的意思
如果没有用可以用代码屏蔽掉
顺便说一下,这个目录要是有很多子目录这个方法有点太慢了。
我试试,谢谢
如果能用,我就给分
目录数不会多于60
备案号:鲁ICP备13029499号-2 说三道四 www.s3d4.cn 说三道四技术文摘