フォルダ監視vba
下記、20秒置きにフォルダを監視し、変化があればバックアップのファイルを発動させるマクロを組みました。エクセルを開くとマクロは動くようにしています。初めは動いているのですが、途中から動きません。監視してるフォルダに、ファイルを増やしても、反応がありません。どこかおかしな点、わかる方教えていただけないでしょうか。
Option Explicit
Dim previousFiles As Collection
Sub StartMonitoring()
' 初回実行時にファイルリストを取得
Set previousFiles = GetFileList()
Application.OnTime Now + TimeValue("00:00:20"), "MonitorFolder"
End Sub
Sub MonitorFolder()
Dim currentFiles As Collection
Dim fileName As Variant
Dim fileAdded As Boolean
Dim file As Variant
Dim fileArray() As Variant
Dim i As Integer
fileAdded = False
Set currentFiles = GetFileList()
' Collection を配列に変換
ReDim fileArray(1 To currentFiles.Count)
i = 1
For Each file In currentFiles
fileArray(i) = file
i = i + 1
Next file
' 現在のファイルリストと以前のファイルリストを比較
For Each file In fileArray
On Error Resume Next
If IsEmpty(previousFiles(file)) Then
fileAdded = True
Exit For
End If
On Error GoTo 0
Next file
If fileAdded Then
ExecuteBatchFile
MsgBox "File added detected. Batch file executed."
End If
Function GetFileList() As Collection
Dim folderPath As String
Dim fileSystem As Object
Dim folder As Object
Dim file As Object
Dim fileList As New Collection
folderPath = "C:\Path\To\Your\Folder" ' 監視するフォルダのパスを設定
Set fileSystem = CreateObject("Scripting.FileSystemObject")
Set folder = fileSystem.GetFolder(folderPath)
For Each file In folder.Files
fileList.Add file.Name, file.Name
Next file
Set GetFileList = fileList
End Function
Sub ExecuteBatchFile()
Dim batchFilePath As String
batchFilePath = "C:\Path\To\BackupScript.bat" ' バッチファイルのパスを設定
Shell batchFilePath, vbNormalFocus
End Sub
' 現在のファイルリストを保存
Set previousFiles = currentFiles
' 再度監視を開始
StartMonitoring
End Sub
Private Sub Workbook_Open()
StartMonitoring
End Sub
お礼
とてもよくわかりました。 ありがとうございました。