求监视目录的代码，最好是时间响应的

Question

？

Answer 1

利用Windows的未公开函数SHChangeNotifyRegister实现文件目录操作即时监视程序可以监视在Explore中的重命名、新建、删除文件或目录；改变文件关联；插入、取出CD和添加删除网络共享都可以被该程序记录下来代码太多了有个例子
[email protected]://expert.csdn.net/Expert/topic/1612/1612330.xml?temp=.42857

Answer 2

Option ExplicitPublic Const INFINITE = &HFFFFPublic Const FILE_NOTIFY_CHANGE_FILE_NAME As Long = &H1
Public Const FILE_NOTIFY_CHANGE_DIR_NAME As Long = &H2
Public Const FILE_NOTIFY_CHANGE_ATTRIBUTES As Long = &H4
Public Const FILE_NOTIFY_CHANGE_SIZE As Long = &H8
Public Const FILE_NOTIFY_CHANGE_LAST_WRITE As Long = &H10
Public Const FILE_NOTIFY_CHANGE_LAST_ACCESS As Long = &H20
Public Const FILE_NOTIFY_CHANGE_CREATION As Long = &H40
Public Const FILE_NOTIFY_CHANGE_SECURITY As Long = &H100
Public Const FILE_NOTIFY_FLAGS = FILE_NOTIFY_CHANGE_ATTRIBUTES Or _
                                 FILE_NOTIFY_CHANGE_FILE_NAME Or _
                                 FILE_NOTIFY_CHANGE_LAST_WRITEDeclare Function FindFirstChangeNotification Lib "kernel32" _
    Alias "FindFirstChangeNotificationA" _
   (ByVal lpPathName As String, _
    ByVal bWatchSubtree As Long, _
    ByVal dwNotifyFilter As Long) As LongDeclare Function FindCloseChangeNotification Lib "kernel32" _
   (ByVal hChangeHandle As Long) As LongDeclare Function FindNextChangeNotification Lib "kernel32" _
   (ByVal hChangeHandle As Long) As LongDeclare Function WaitForSingleObject Lib "kernel32" _
   (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As LongPublic Const WAIT_OBJECT_0 = &H0
Public Const WAIT_ABANDONED = &H80
Public Const WAIT_IO_COMPLETION = &HC0
Public Const WAIT_TIMEOUT = &H102
Public Const STATUS_PENDING = &H103Option Explicit
Dim hChangeHandle As Long
Dim hWatched As Long
Dim terminateFlag As Long
Dim vDir As Variant
Dim vFiles As Variant
Public password As String
Public inputpath As String
Public outputpath As String
Public cutfilesize As Integer
Public dns As String
Public pid As String
Private Const filename = ".\config.ini"
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetprivateProfileString Lib "Kernel32.dll" Alias "GetPrivateProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
 
'从config.ini中引导文件
Public Sub loadfile()
If inputpath <> "" Then
Exit Sub
End If
Dim filename1 As Stringfilename1 = App.path + "\config.ini"
'MsgBox filename1, vbOKOnly, "title"
 Dim s As String * 256
  GetprivateProfileString "path", "inputpath", "", s, 256, filename1
  inputpath = s
  Textinput.Text = inputpath
  '
  's = ""
  GetprivateProfileString "path", "outputpath", "", s, 256, filename1
  outputpath = s
  Textoutput.Text = outputpath
  '
  s = ""
   GetprivateProfileString "path", "password", "", s, 256, filename1
  password = s
  '因为md5不可逆向解密，因而用一串特殊数字来显示
  Textpwd.Text = "~~~~~~~~"
  Textcfmpwd.Text = "~~~~~~~~"
  'Textinput.Text = inputpath
  s = ""
    GetprivateProfileString "path", "dns", "", s, 256, filename1
  dns = s
  Textdns.Text = dns
  '
  s = ""
GetprivateProfileString "path", "cutfilesize", "1", s, 256, filename1
  cutfilesize = CInt(s)
  Textcutfilesize.Text = s
    GetprivateProfileString "path", "pid", "", s, 256, filename1
    pid = s
    Textpid.Text = pid
End Sub
Public Function BrowseForFolder() As StringDim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfoWith udtBI
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat("选择目录", "")
.ulFlags = BIF_RETURNONLYFSDIRS
End WithlpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
BrowseForFolder = sPath
End FunctionPrivate Sub Cmdinput_Click()
Dim path As String
path = BrowseForFolder
If path <> "" Then
Textinput.Text = path
End If
inputpath = Textinput.Text
End SubPrivate Sub Cmdoutput_Click()
Dim path As String
path = BrowseForFolder
If path <> "" Then
Textoutput.Text = path
End If
outputpath = Textoutput.Text
End Sub'保存文件
Public Sub savefile()
Dim filename1 As String
filename1 = App.path + "\config.ini"
WritePrivateProfileString "path", "inputpath", inputpath, filename1
WritePrivateProfileString "path", "outputpath", outputpath, filename1
End Sub
 
Private Function FindDir(ByVal sFileDir As String) As Variant
    Dim sFile() As String
    Dim sTempDir As String
    Dim i As Integer
    
    sTempDir = Dir(sFileDir, vbDirectory)
    i = -1
    Do While sTempDir <> ""
        If sTempDir <> "." And sTempDir <> ".." And Len(sTempDir) < 12 Then
            i = i + 1
            If GetAttr(sFileDir + sTempDir) And vbDirectory = vbDirectory Then
                ReDim Preserve sFile(i)
                sFile(i) = sTempDir
            End If
        End If
        sTempDir = Dir
    Loop
    FindDir = IIf(i > -1, sFile, Null)
End Function
'查找以sFileExt为扩展名的文件
Public Function FindFiles(ByVal sFileDir As String, ByVal sFileExt As String) As Variant
    On Error Resume Next
    Dim sFile() As Variant
    Dim FindExtFiles As Variant
    Dim sTempFile As String
    Dim i As Long
    Dim sFindFileName As String    i = -1
    If sFileDir = "" Or sFileExt = "" Then
        FindExtFiles = Null
        Exit Function
    End If
    
    sFindFileName = sFileDir & "*." & sFileExt
    sTempFile = Dir(sFindFileName, vbNormal)
    Do While sTempFile <> ""
        i = i + 1
        ReDim Preserve sFile(i)
        sFile(i) = sTempFile
        sTempFile = Dir()
    Loop
    FindFiles = IIf(i > -1, sFile, Null)
End Function

Answer 3

Public Sub BackupFile(ByVal sFileName As String, ByVal sBackupPath As String, ByVal sBackupFileName As String)
    FileCopy sFileName, sBackupPath & sBackupFileName
End SubPrivate Sub cmdEnd_Click()
   If hWatched > 0 Then Call WatchDelete(hWatched)
   Unload Me
   Set Form1 = Nothing
End SubPrivate Sub cmdStop_Click()
   Call WatchDelete(hWatched)
   hWatched = 0
   cmdBegin.Enabled = True
End SubPrivate Sub cmdBegin_Click()
   Dim r As Long
   Dim watchPath As String
   Dim watchStatus As Long
   
   Dim i As Integer
   Dim sFileName As String
   Dim bkpsFileName As String
   Dim monitorPath As String
   Dim backupPath As String   On Error Resume Next
   
   
   If Textinput.Text = "" Then
       MsgBox "必须选择节目文件路径", vbOKOnly, "提示信息"
       Exit Sub
   End If
   If Textoutput.Text = "" Then
       MsgBox "必须选择发送文件路径", vbOKOnly, "提示信息"
       Exit Sub
   End If
 
  Call savefile
  
   monitorPath = Trim(Textinput.Text)
   backupPath = Trim(Textoutput.Text)
   
   watchPath = monitorPath
   
   terminateFlag = False
   cmdBegin.Enabled = False
 
   WatchChangeAction watchPath
'   MsgBox "开始监视文件夹：" & watchPath
   
   vFiles = FindFiles(monitorPath & "\", "*")
   If Not IsNull(vFiles) Then
      For i = LBound(vFiles) To UBound(vFiles)
        sFileName = vFiles(i)
        Sleep 3000
        BackupFile monitorPath & "\" & sFileName, backupPath & "\", sFileName
        Kill monitorPath & "\" & sFileName
      Next i
   End If
       
   
   
   hWatched = WatchCreate(watchPath, FILE_NOTIFY_FLAGS)
   
  '循环监视文件夹
   watchStatus = WatchDirectory(hWatched, 100)
  
  '如果watchStatus = 0，说明文件夹有改变
   If watchStatus = 0 Then
       WatchChangeAction watchPath
       vFiles = FindFiles(monitorPath & "\", "*")
       If Not IsNull(vFiles) Then
         For i = LBound(vFiles) To UBound(vFiles)
            sFileName = vFiles(i)
            Sleep 3000
            BackupFile monitorPath & "\" & sFileName, backupPath & "\", sFileName
            Kill monitorPath & "\" & sFileName
         Next i
       End If
       
       Do
         watchStatus = WatchResume(hWatched, 100)
         If watchStatus = -1 Then
               MsgBox "停止监视目录：" & watchPath
         Else: WatchChangeAction watchPath
               vFiles = FindFiles(monitorPath & "\", "*")
               If Not IsNull(vFiles) Then
                 For i = LBound(vFiles) To UBound(vFiles)
                   sFileName = vFiles(i)
                   Sleep 3000
                   BackupFile monitorPath & "\" & sFileName, backupPath & "\", sFileName
                   Kill monitorPath & "\" & sFileName
                 Next i
               End If
            
         End If
       Loop While watchStatus = 0
   
    Else
      MsgBox "停止监视目录:" & watchPath
   
   End If
   Exit Sub
   
End SubPrivate Function WatchCreate(lpPathName As String, flags As Long) As Long
  
   WatchCreate = FindFirstChangeNotification(lpPathName, False, flags)End FunctionPrivate Sub WatchDelete(hWatched As Long)
   Dim r As Long
   terminateFlag = True
   DoEvents
   r = FindCloseChangeNotification(hWatched)
End SubPrivate Function WatchDirectory(hWatched As Long, interval As Long) As Long
  'r = 0,说明发生了一个变化
  
   Dim r As Long
   Do
      r = WaitForSingleObject(hWatched, interval)
      DoEvents
   Loop While r <> 0 And terminateFlag = False
   WatchDirectory = r
   
End FunctionPrivate Function WatchResume(hWatched As Long, interval) As Boolean
   Dim r As Long
   r = FindNextChangeNotification(hWatched)
   Do
      r = WaitForSingleObject(hWatched, interval)
      DoEvents
   Loop While r <> 0 And terminateFlag = False
   
   WatchResume = r
   
End FunctionPrivate Sub WatchChangeAction(fPath As String)
   Dim fName As String
   fName = Dir(fPath & "\" & "*.*")
End SubPrivate Sub Form_Load()
Call loadfile
End Sub