Здравствуйте! Заинтересовался возможностью мониторить определённую директорию на предмет появления новых файлов в реальном времени (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, у Вас ошибка несоответствия типа переменной, следовательно нужно проверить декларацию, а там этот параметр Long. Вот тут можно посмотреть как надо декларировать...
Цитата
vladjuha написал: на него немножко ругается компилятор
Немножко - это потому, что он только начал ругаться. А эта ошибка может быть не единственной...
окай... Поменял я все 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
В какие-то библиотеки полезли. Написать макрос который проверят количество файлов и их имена, если надо. Потом зациклить его через таймер, например, через каждые 10 минут. Всё. Ну и кнопочку ОТКЛ и ВКЛ сделать. Ну это как один из вариантов.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
БМВ, у автора вроде только появление новых файлов. Про изменение ничего не сказано.
Цитата
vladjuha написал: мониторить определённую директорию на предмет появления новых файлов
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
Андрей VG, я тут замучился уже автоматизацию в 1С своих разработок в сотый раз тестировать, так что извините, я пас. От этого слоова уже не хорошо делается. А вообще тема без ТС хорошо пошла.
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("путьимяфайла")
Я думаю этого достаточно будет.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
Если б этого было достаточно, то в сообщении #3 не была бы ссылка на скачивание файла Для того чтобы самостоятельно принимать решение о типах переменных используемых в API-функциях нужно иметь представление о некой архитектуре их организации.
Цитата
Alemox написал: Если уж понадобиться и изменение, то можно мониторить следующие параметры:
С чем я полностью согласен! Но,
Цитата
Андрей VG написал: Попробуйте вариант на "родственном" языке VBScript
Этот вариант мне наиболее симпатичен и в том плане, что не грузит рутиной Excel... PS Да, и еще, как правило результаты мониторинга нужны только в определенный момент, связанный неким событием. Так вот если к этому событию привязать подход Alemox, то вопрос, наверное решен.
Здравствуйте, Андрей! Посмотрел Ваш файл из #15. Справляется с работой прекрасно, практически не загружая процессор. При запуске на сетевом диске в начале выдает весь список файлов, затем мониторит изменения (новые и переименованные файлы). Мне нравится!
sokol92 написал: При запуске на сетевом диске в начале выдает весь список файлов
Добрый вечер, Владимир. Спасибо большое за тестирование. Странно, конечно, что создаёт список существующих файлов. Может из-за того, что сетевой диск? У меня при тестировании в локальной папке показывал только вновь созданные (те две штуки). Завтра попробую по unc пути сетевого ресурса запустить.
Здравствуйте, Андрей! У меня по UNC сетевые диски не запускаются, только через Диск:\.... Локальный диск - показывает только изменения, сетевые - сначала все существующие файлы, потом изменения. Проверили сетевые диски на базе Windows Server и Linux+Samba.
Результат работы макроса понятен...не понятен процесс ) Подскажите, как отследить работу модуля класса? Он же в фоновом режиме запускается. При каких условиях он останавливается? Как ошибки посмотреть?
Сергей Евдокимов написал: А то что-то у меня локально работает, а сетевую папку не мониторит.
Цитата
testuser написал: Попробуйте подключить сетевую папку как диск
Цитата
sokol92 написал (#23): по UNC сетевые диски не запускаются, только через Диск:\.... Локальный диск - показывает только изменения, сетевые - сначала все существующие файлы, потом изменения. Проверили сетевые диски на базе Windows Server и Linux+Samba.