Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
vba Мониторинг директории в реальном времени, (починка кода)
 
Здравствуйте!
Заинтересовался возможностью мониторить определённую директорию на предмет появления новых файлов в реальном времени (ReadDirectoryChangesW).
Подыскал подходящий код, но на него немножко ругается компилятор (win10 x64, excel x64): строка 168, AddressOf StartWatch_CallBack - Type mismatch.
Подскажите, пожалуйста, что где покрутить надобнать?
Код
Option Explicit
 
Private Type FILE_NOTIFY_INFORMATION
   NextEntryOffset As Long
   Action As Long
   FileNameLength As Long
   FileName As String
End Type
 
Private Const FILE_FLAG_OVERLAPPED = &H40000000
Private Const FILE_LIST_DIRECTORY = &H1
Private Const FILE_SHARE_READ = &H1&
Private Const FILE_SHARE_DELETE = &H4&
Private Const OPEN_EXISTING = 3
Private Const CREATE_NEW = 1
Private Const FILE_FLAG_BACKUP_SEMANTICS = &H2000000
Private Const FILE_NOTIFY_CHANGE_FILE_NAME = &H1&
Private Const FILE_NOTIFY_CHANGE_LAST_WRITE = &H10&
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const FILE_NOTIFY_CHANGE_ATTRIBUTES As Long = &H4
Private Const FILE_NOTIFY_CHANGE_DIR_NAME As Long = &H2
Private Const FILE_ACTION_ADDED = &H1&
Private Const FILE_ACTION_REMOVED = &H2&
Private Const FILE_ACTION_MODIFIED = &H3&
Private Const FILE_ACTION_RENAMED_OLD_NAME = &H4&
Private Const FILE_ACTION_RENAMED_NEW_NAME = &H5&
 
Private Declare PtrSafe Sub MoveMemory Lib _
"kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpcSource As Any, ByVal dwLength As Long)
 
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Declare PtrSafe 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
 
Private Declare PtrSafe 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
 
Private Declare PtrSafe 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
 
Private Declare PtrSafe Function TerminateThread Lib "kernel32" _
(ByVal hThread As Long, ByVal dwExitCode As Long) As Long
 
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
 
'Get the directory chages using ReadDirectoryChangesW
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 WSubFolder As Boolean
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
Private WatchStart As Boolean
Private DirHndl As Long
Private FolderPath As String
Private ThreadHandle    As Long
 
Private 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 Function
 
Private Sub StartWatch_CallBack()
    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 Sub
 
Private 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
 
Private Sub ClearHndl(Handle As Long)
 
    CloseHandle Handle
    Handle = 0
 
End Sub
 
'______________________________________________________________________________________
Private Sub DisplayInfoOnSheet(i As Long, changes As String)
 
    With ThisWorkbook.Sheets(1)
        .Cells(i, 1) = changes
        .Columns("A:A").EntireColumn.AutoFit
   End With
 
End Sub
 
Sub StartWatch()
 
    Dim changes As String
    Dim WaitNum As Long
    Dim i As Long
 
    WSubFolder = True
    If Not WatchStart Then
        WatchStart = True
    Else
        MsgBox " The Directory Watcher is already enabled", vbInformation
        Exit Sub
    End If
    'Get Folder Handle
    FolderPath = "C:\test\" 'change this path as required
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath + "\"
    DirHndl = GetDirHndl(FolderPath)
    If (DirHndl = 0) Or (DirHndl = -1) Then MsgBox "Cannot create handle": Exit Sub
    i = 1
    Do
        'Create thread to Watch changes
        ThreadHandle = CreateThread(ByVal 0&, ByVal 0&, AddressOf StartWatch_CallBack, 0, 0, 0)
        Do
            WaitNum = WaitForSingleObject(ThreadHandle, 50)
            DoEvents
        Loop Until (WaitNum = 0) Or (WatchStart = False)
        changes = ""
        If WaitNum = 0 Then changes = GetChanges
        If changes <> "" Then Call DisplayInfoOnSheet(i, changes): i = i + 1
    Loop Until Not WatchStart
    'Terminate the Thread & Clear Handle
    If DirHndl <> 0 Then ClearHndl DirHndl
    If ThreadHandle <> 0 Then Call TerminateThread(ThreadHandle, ByVal 0&): ThreadHandle = 0
 
End Sub
 
Sub StopWatch()
    WatchStart = False
    With ThisWorkbook.Sheets(1)
        .Columns("A:A").ClearContents
        .Columns("A:A").ColumnWidth = Columns("B:B").ColumnWidth
    End With
 
End Sub
Изменено: vladjuha - 25 Май 2018 17:02:57
 
Перенос макроса из 32 бит в 64 бит
Согласие есть продукт при полном непротивлении сторон.
 
vladjuha, у Вас ошибка несоответствия типа переменной, следовательно нужно проверить декларацию, а там этот параметр Long.
Вот тут можно посмотреть как надо декларировать...
Цитата
vladjuha написал:
на него немножко ругается компилятор
Немножко - это потому, что он только начал ругаться. А эта ошибка может быть не единственной...  ;)
Изменено: AAF - 25 Май 2018 19:25:12
 
На win7 x64, excel x32 код исправно работает.
 
окай...
Поменял я все Long на LongPtr  - компилятор теперь не ругается. Но в полевых испытаниях, при любом изменении в отслеживаемой директории, Excel тупо перезапускается без каких-либо сообщений. Куда двигаться? Any ideas? )
Код
Option Explicit
 
Private Type FILE_NOTIFY_INFORMATION
   NextEntryOffset As LongPtr
   Action As LongPtr
   FileNameLength As Long
   FileName As String
End Type
  
Private Const FILE_FLAG_OVERLAPPED = &H40000000
Private Const FILE_LIST_DIRECTORY = &H1
Private Const FILE_SHARE_READ = &H1&
Private Const FILE_SHARE_DELETE = &H4&
Private Const OPEN_EXISTING = 3
Private Const CREATE_NEW = 1
Private Const FILE_FLAG_BACKUP_SEMANTICS = &H2000000
Private Const FILE_NOTIFY_CHANGE_FILE_NAME = &H1&
Private Const FILE_NOTIFY_CHANGE_LAST_WRITE = &H10&
Private Const FILE_SHARE_WRITE As LongPtr = &H2
Private Const FILE_NOTIFY_CHANGE_ATTRIBUTES As LongPtr = &H4
Private Const FILE_NOTIFY_CHANGE_DIR_NAME As LongPtr = &H2
Private Const FILE_ACTION_ADDED = &H1&
Private Const FILE_ACTION_REMOVED = &H2&
Private Const FILE_ACTION_MODIFIED = &H3&
Private Const FILE_ACTION_RENAMED_OLD_NAME = &H4&
Private Const FILE_ACTION_RENAMED_NEW_NAME = &H5&
 
Private Declare PtrSafe Sub MoveMemory Lib _
"kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpcSource As Any, ByVal dwLength As LongPtr)
 
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As LongPtr
 
Private Declare PtrSafe Function ReadDirectoryChangesW Lib "kernel32" _
(ByVal hDirectory As LongPtr, lpBuffer As Any, ByVal nBufferLength As LongPtr, _
ByVal bWatchSubtree As LongPtr, ByVal dwNotifyFilter As LongPtr, _
lpBytesReturned As LongPtr, ByVal PassZero As LongPtr, ByVal PassZero As LongPtr) As LongPtr
 
Private Declare PtrSafe Function CreateFile Lib "kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, ByVal dwDesiredAccess As LongPtr, ByVal dwShareMode As LongPtr, _
ByVal PassZero As LongPtr, ByVal dwCreationDisposition As LongPtr, _
ByVal dwFlagsAndAttributes As LongPtr, ByVal PassZero As LongPtr) As LongPtr
  
Private Declare PtrSafe Function CreateThread Lib "kernel32" _
(lpThreadAttributes As Any, ByVal dwStackSize As LongPtr, _
ByVal lpStartAddress As LongPtr, lpParameter As Any, ByVal dwCreationFlags As LongPtr, _
lpThreadID As LongPtr) As LongPtr
 
Private Declare PtrSafe Function TerminateThread Lib "kernel32" _
(ByVal hThread As LongPtr, ByVal dwExitCode As LongPtr) As LongPtr
 
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As LongPtr, ByVal dwMilliseconds As LongPtr) As LongPtr
 
'Get the directory chages using ReadDirectoryChangesW
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 WSubFolder As Boolean
Private nBufLen As Long
Private nReadLen As LongPtr
Private sAction As String
Private fiBuffer As FILE_NOTIFY_INFORMATION
Private cBuffer() As Byte
Private cBuff2() As Byte
Private lpBuf As LongPtr
Private WatchStart As Boolean
Private DirHndl As LongPtr
Private FolderPath As String
Private ThreadHandle As LongPtr
 
Private Function GetDirHndl(ByVal PathDir As String) As LongPtr
 
    On Error Resume Next
 
    Dim hDir As LongPtr
 
    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 Function
 
Private Sub StartWatch_CallBack()
    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 Sub
 
Private 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
 
Private Sub ClearHndl(Handle As LongPtr)
 
    CloseHandle Handle
    Handle = 0
 
End Sub
 
'______________________________________________________________________________________
Private Sub DisplayInfoOnSheet(i As LongPtr, changes As String)
 
    With ThisWorkbook.Sheets(1)
        .Cells(i, 1) = changes
        .Columns("A:A").EntireColumn.AutoFit
   End With
 
End Sub
 
Sub StartWatch()
 
    Dim changes As String
    Dim WaitNum As LongPtr
    Dim i As LongPtr
 
    WSubFolder = True
    If Not WatchStart Then
        WatchStart = True
    Else
        MsgBox " The Directory Watcher is already enabled", vbInformation
        Exit Sub
    End If
    'Get Folder Handle
    FolderPath = "R:\Dir\" 'change this path as required
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath + "\"
    DirHndl = GetDirHndl(FolderPath)
    If (DirHndl = 0) Or (DirHndl = -1) Then MsgBox "Cannot create handle": Exit Sub
    i = 1
    Do
        'Create thread to Watch changes
        ThreadHandle = CreateThread(ByVal 0&, ByVal 0&, AddressOf StartWatch_CallBack, 0, 0, 0)
        Do
            WaitNum = WaitForSingleObject(ThreadHandle, 50)
            DoEvents
        Loop Until (WaitNum = 0) Or (WatchStart = False)
        changes = ""
        If WaitNum = 0 Then changes = GetChanges
        If changes <> "" Then Call DisplayInfoOnSheet(i, changes): i = i + 1
    Loop Until Not WatchStart
    'Terminate the Thread & Clear Handle
    If DirHndl <> 0 Then ClearHndl DirHndl
    If ThreadHandle <> 0 Then Call TerminateThread(ThreadHandle, ByVal 0&): ThreadHandle = 0
 
End Sub
 
Sub StopWatch()
    WatchStart = False
    With ThisWorkbook.Sheets(1)
        .Columns("A:A").ClearContents
        .Columns("A:A").ColumnWidth = Columns("B:B").ColumnWidth
    End With
 
End Sub
 
Доброе время суток.
Цитата
vladjuha написал:
Куда двигаться? Any ideas? )
Попробуйте вариант на "родственном" языке VBScript: слежение за созданием файлов в указанном каталоге
 
В какие-то библиотеки полезли.
Написать макрос который проверят количество файлов и их имена, если надо. Потом зациклить его через таймер, например, через каждые 10 минут. Всё. Ну и кнопочку ОТКЛ и ВКЛ сделать.
Ну это как один из вариантов.
Никаких врагов, зато и никаких друзей.
 
Alemox,
Цитата
Alemox написал:
Написать макрос который проверят количество файлов и их имена,
и размер, и даты создания модификации , и хаш суммы и …..   Не по взрослому это.
 
БМВ, у автора вроде только появление новых файлов. Про изменение ничего не сказано.
Цитата
vladjuha написал:
мониторить определённую директорию на предмет появления новых файлов
Никаких врагов, зато и никаких друзей.
 
Alemox, при копировании, перезапись в папке одним файлом одноименного другого это новый файл или изменение?
 
Цитата
Alemox написал:
автора вроде только появление новых файлов
появление оно разное бывает, как правильно отметил PooHkrd,  Однако возможно vladjuha, будет достаточно и предложенного вами решения.

Через WMI решение мне понравилось.
 
Цитата
vladjuha написал:
на предмет появления новых файлов
Так что если понимать ТЗ буквально, то достаточно количества.
Изменено: StoTisteg - 31 Май 2018 17:20:14
 
А если удалили-создали?
 
Цитата
StoTisteg написал:
достаточно количества.
если написано при увеличении количества файлов. Новый это другой, ранее которого не было. Вот вы штаны покупаете в замен старым, вы в новых штанах?
 
Цитата
PooHkrd написал:
при копировании, перезапись в папке одним файлом одноименного другого это новый файл или изменение?
Алексей, возьмётесь по тестировать?
 
Цитата
БМВ написал: Вот вы штаны покупаете в замен старым, вы в новых штанах?
Если возле кассы, то в старых. В примерочной - тут время влияет и местоположение (местонадевание) старых штанов )
 
Андрей VG, я тут замучился уже автоматизацию в 1С своих разработок в сотый раз тестировать, так что извините, я пас. От этого слоова уже не хорошо делается.   :cry:
А вообще тема без ТС хорошо пошла.  :D
 
Цитата
PooHkrd написал:
при копировании, перезапись в папке одним файлом одноименного другого это новый файл или изменение?
Тут можно двояко понять, если сделано не из "заметания следов", то это просто изменения имеющегося файла. А если содержимое совершенно другое, то тут конечно это новый файл, но при этом надо не забывать, что старый надо удалить предварительно, чтобы создать на его месте новый другой, ну или заменить.
Если автору надо на самом деле контролировать изменения, то я думаю, что автор бы создал тему "как отследить изменения файлов в заданном месте", но тут именно "появление".
Если уж понадобиться и изменение, то можно мониторить следующие параметры:
Количество файлов в папке
Код
a = CreateObject("Scripting.FileSystemObject").GetFolder("C:\адреспапки\").Files.Count
Имена файлов (и папок если надо)
Код
b = Dir("адреспапки" & "\")
Do While b <> ""
    Debug.Print b
b = Dir
Loop
Размер файлов
Код
c = CreateObject("Scripting.FileSystemObject").GetFile("путьимяфайла").Size
Время изменения
Код
d = FileDateTime("путьимяфайла")
Я думаю этого достаточно будет.
Никаких врагов, зато и никаких друзей.
 
Я как раз хотел как про сделать :D Через шелдур - это понятно
 
Цитата
vladjuha написал:
Поменял я все Long на LongPtr  
Если б этого было достаточно, то в сообщении #3 не была бы ссылка на скачивание файла
Для того чтобы самостоятельно принимать решение о типах переменных используемых в API-функциях нужно иметь представление о некой архитектуре их организации.
Цитата
Alemox написал:
Если уж понадобиться и изменение, то можно мониторить следующие параметры:
С чем я полностью согласен! Но,
Цитата
Андрей VG написал:
Попробуйте вариант на "родственном" языке  VBScript
Этот вариант мне наиболее симпатичен и в том плане, что не грузит рутиной Excel... :)
PS
Да, и еще, как правило результаты мониторинга нужны только в определенный момент, связанный неким событием.
Так вот если к этому событию привязать подход Alemox, то вопрос, наверное решен.
Изменено: AAF - 31 Май 2018 19:39:10
 
Здравствуйте, Андрей! Посмотрел Ваш файл из #15. Справляется с работой прекрасно, практически не загружая процессор. При запуске на сетевом диске в начале выдает весь список файлов, затем мониторит изменения (новые и переименованные файлы). Мне нравится!
Владимир
 
Цитата
sokol92 написал:
При запуске на сетевом диске в начале выдает весь список файлов
Добрый вечер, Владимир.
Спасибо большое за тестирование.
Странно, конечно, что создаёт список существующих файлов. Может из-за того, что сетевой диск? У меня при тестировании в локальной папке показывал только вновь созданные (те две штуки). Завтра попробую по unc пути сетевого ресурса запустить.
 
Здравствуйте, Андрей! У меня по UNC сетевые диски не запускаются, только через Диск:\.... Локальный диск - показывает только изменения, сетевые - сначала все существующие файлы, потом изменения. Проверили сетевые диски на базе Windows Server и Linux+Samba.
Изменено: sokol92 - 1 Июн 2018 16:45:01
Владимир
 
Андрей VG, спасибо за предложенный вариант! Я пока воюю с реализациями на ReadDirectoryChangesW - руки не дошли потестить
 
Цитата
sokol92 написал:
показывает только изменения, сетевые - сначала все существующие файлы, потом изменения.
Владимир, спасибо!
Страницы: 1
Читают тему (гостей: 1)