API高手进(关于文件夹适时监控的例子)

Question

这是一个适时监控文件夹变动的例子
在VB设计模式时运行正常,但编译成EXE后,出错
哪位大侠能帮我修改下,在下不胜感激'先引用 Windows Script Host Object Model
'窗体form1 加入1个Command1,1个Text1,1个Check1,1个List1,全部取默认名
'加入以下代码
Option ExplicitDim ThreadHandle As LongPrivate Sub Form_Load()
    WatchStart = False
    Text1.Text = "c:\"
    Check1.Caption = "包含子目录"
    Command1.Caption = "开始监控"
End SubPrivate Sub Form_Unload(Cancel As Integer)
  WatchStart = False
End Sub
Private Sub Command1_Click()
  Dim Dummy As Long
  Dim Changes As String
  Dim WaitNum As Long
  Dim I As Integer
  Dim Fl As String
  Dim Fm As String
  
  If UCase(Command1.Caption) = "开始监控" Then
    Command1.Caption = "停止"
    WSubFolder = Check1.Value
    WatchStart = True    FolderPath = Text1.Text
    If right(FolderPath, 1) <> "\" Then FolderPath = FolderPath + "\"
    
    DirHndl = GetDirHndl(FolderPath)
    
    If (DirHndl = 0) Or (DirHndl = -1) Then MsgBox "Cannot create handle": Exit Sub    Do
      ThreadHandle = CreateThread(ByVal 0&, ByVal 0&, AddressOf StartWatch, DirHndl, 0, Dummy)
      Do
        WaitNum = WaitForSingleObject(ThreadHandle, 50)
        DoEvents
      Loop Until (WaitNum = 0) Or (WatchStart = False)
      Changes = ""
      If WaitNum = 0 Then Changes = GetChanges
      If Changes <> "" Then
        List1.AddItem Changes
        If left(Changes, 11) = "Added file-" Then
          Fl = Mid(Changes, 12, Len(Changes) - 11)
          Fm = UCase(right(Fl, 3))
        End If
      End If
    Loop Until Not WatchStart
    
    If DirHndl <> 0 Then ClearHndl DirHndl
    If ThreadHandle <> 0 Then Call TerminateThread(ThreadHandle, ByVal 0&): ThreadHandle = 0
  Else    WatchStart = False
    Command1.Caption = "开始监控"  End If
End Sub

Answer 1

'=======================
'以下是模块 APIs 的代码
'=======================
Option ExplicitDeclare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINT_TYPE) As Long
Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function SetCapture Lib "user32.dll" (ByVal hwnd As Long) As Long
Declare Function ReleaseCapture Lib "user32.dll" () As Long
Declare Function TextOut Lib "gdi32.dll" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Declare Function SetTextAlign Lib "gdi32.dll" (ByVal hdc As Long, ByVal wFlags As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function TransparentBlt Lib "msimg32" (ByVal hDCDst As Long, ByVal nXOriginDst As Long, ByVal nYOriginDst As Long, ByVal nWidthDst As Long, ByVal nHeightDst As Long, ByVal hDCSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal crTransparent As Long) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyHeight As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As LongPublic Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As IntegerPublic Const DI_MASK = &H1
Public Const DI_IMAGE = &H2
Public Const DI_NORMAL = &H3
Public Const DI_COMPAT = &H4
Public Const DI_DEFAULTSIZE = &H8Public Const BLACKNESS = &H42
Public Const DSTINVERT = &H550009
Public Const MERGECOPY = &HC000CA
Public Const MERGEPAINT = &HBB0226
Public Const NOTSRCCOPY = &H330008
Public Const NOTSRCERASE = &H1100A6
Public Const PATCOPY = &HF00021
Public Const PATINVERT = &H5A0049
Public Const PATPAINT = &HFB0A09
Public Const SRCAND = &H8800C6
Public Const SRCCOPY = &HCC0020
Public Const SRCERASE = &H440328
Public Const SRCINVERT = &H660046
Public Const SRCPAINT = &HEE0086
Public Const WHITENESS = &HFF0062Public Const TA_BASELINE = 24
Public Const TA_BOTTOM = 8
Public Const TA_CENTER = 6
Public Const TA_LEFT = 0
Public Const TA_NOUPDATECP = 0
Public Const TA_RIGHT = 2
Public Const TA_RTLREADING = 256
Public Const TA_TOP = 0
Public Const TA_UPDATECP = 1Type POINT_TYPE
  X As Long
  Y As Long
End TypeType RECT
  left As Long
  top As Long
  right As Long
  bottom As Long
End Type

Answer 2

'=============================
'以下是模块 modFunction 的代码
'=============================
Option ExplicitPublic FolderPath As String
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)Type FILE_NOTIFY_INFORMATION
  NextEntryOffset As Long
  Action As Long
  FileNameLength As Long
  FileName As String
End TypePublic WSubFolder  As Boolean
Public Const FILE_FLAG_OVERLAPPED = &H40000000
Public Const FILE_LIST_DIRECTORY = &H1
Public Const FILE_SHARE_READ = &H1&
Public Const FILE_SHARE_DELETE = &H4&
Public Const OPEN_EXISTING = 3
Public Const FILE_FLAG_BACKUP_SEMANTICS = &H2000000
Public Const FILE_NOTIFY_CHANGE_FILE_NAME = &H1&
Public Const FILE_NOTIFY_CHANGE_LAST_WRITE = &H10&
Public Const FILE_SHARE_WRITE As Long = &H2
Public Const FILE_NOTIFY_CHANGE_ATTRIBUTES As Long = &H4
Public Const FILE_NOTIFY_CHANGE_DIR_NAME As Long = &H2Public Const FILE_ACTION_ADDED = &H1&
Public Const FILE_ACTION_REMOVED = &H2&
Public Const FILE_ACTION_MODIFIED = &H3&
Public Const FILE_ACTION_RENAMED_OLD_NAME = &H4&
Public Const FILE_ACTION_RENAMED_NEW_NAME = &H5&Public Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpcSource As Any, ByVal dwLength As Long)
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function ReadDirectoryChangesW Lib "kernel32" (ByVal hDirectory As Long, lpBuffer As Any, ByVal nBufferLength As Long, ByVal bWatchSubtree As Long, ByVal dwNotifyFilter As Long, lpBytesReturned As Long, ByVal PassZero As Long, ByVal PassZero As Long) As Long
Public Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal PassZero As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal PassZero As Long) As Long
Public Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Public Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As LongPublic Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Answer 3

'==========================
'以下是模块 modWatch 的代码
'==========================
Option ExplicitGlobal WatchStart As Boolean
Global DirHndl As Long
Private Const FILE_NOTIF_GLOB = FILE_NOTIFY_CHANGE_ATTRIBUTES Or _
                                FILE_NOTIFY_CHANGE_FILE_NAME Or _
                                FILE_NOTIFY_CHANGE_DIR_NAME Or _
                                FILE_NOTIFY_CHANGE_ATTRIBUTES Or _
                                FILE_NOTIFY_CHANGE_LAST_WRITE
Private nBufLen As Long
Private nReadLen As Long
Private sAction As String
Private fiBuffer As FILE_NOTIFY_INFORMATION
Private cBuffer() As Byte
Private cBuff2() As Byte
Private lpBuf As Long
    
Public Function GetDirHndl(ByVal PathDir As String) As Long
  On Error Resume Next
  Dim hDir As Long
  If right(PathDir, 1) <> "\" Then PathDir = PathDir + "\"
  hDir = CreateFile(PathDir, FILE_LIST_DIRECTORY, _
                    FILE_SHARE_READ + FILE_SHARE_WRITE + FILE_SHARE_DELETE, _
                    ByVal 0&, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS _
                    Or FILE_FLAG_OVERLAPPED, ByVal 0&)
  GetDirHndl = hDir
End FunctionPublic Sub StartWatch()
  If (DirHndl = 0) Or (DirHndl = -1) Then Exit Sub
  nBufLen = 1024
  ReDim cBuffer(0 To nBufLen)
  Call ReadDirectoryChangesW(DirHndl, cBuffer(0), nBufLen, WSubFolder, FILE_NOTIF_GLOB, nReadLen, 0, 0)
End SubPublic Function GetChanges() As String
  On Error Resume Next
  Dim fName As String
  MoveMemory fiBuffer.NextEntryOffset, cBuffer(0), 4
  MoveMemory fiBuffer.Action, cBuffer(4), 4
  MoveMemory fiBuffer.FileNameLength, cBuffer(8), 4
  ReDim cBuff2(0 To fiBuffer.FileNameLength)
  MoveMemory cBuff2(0), cBuffer(12), fiBuffer.FileNameLength
  fiBuffer.FileName = cBuff2
  Select Case fiBuffer.Action
    Case FILE_ACTION_ADDED:
      sAction = "Added file"
    Case FILE_ACTION_REMOVED:
      sAction = "Removed file"
    Case FILE_ACTION_MODIFIED:
      sAction = "Modified file"
    Case FILE_ACTION_RENAMED_OLD_NAME:
      sAction = "Renamed from"
    Case FILE_ACTION_RENAMED_NEW_NAME:
      sAction = "Renamed to"
    Case Else
      sAction = "Unknown"
  End Select
  fName = sAction + "-" + FolderPath + fiBuffer.FileName
  If sAction <> "Unknown" Then GetChanges = fName
End Function
      
Public Sub ClearHndl(Handle As Long)
  CloseHandle Handle
  Handle = 0
End Sub

Answer 4

查看以下例子
http://www.dunzip.com/download/watchdir.rar