フォルダ監視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

回答No.1

kkkkkm · ベストアンサー

> Sub MonitorFolder()
> Dim currentFiles As Collection
>
> Function GetFileList() As Collection
> Dim folderPath As String
> End Function
>
> Sub ExecuteBatchFile()
> Dim batchFilePath As String
> End Sub
>
> ' 現在のファイルリストを保存
> Set previousFiles = currentFiles
>
> ' 再度監視を開始
> StartMonitoring
> End Sub

この配置はおかしいと思いますので実行後「End Subがない」というエラーになると思います。
MonitorFolder()の中に
GetFileList()とExecuteBatchFile()があります。

あと

> 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

ここで
On Error Resume Next
の後でエラーになった場合
Exit For
で抜けたときには
On Error GoTo 0
が有効にならないのでその後エラーになっても
On Error Resume Next
が有効な為にエラーは無視されます。

お礼

ありがとうございました！ 指摘して頂いたおかげで、今正常に動いてそう（？）です。 様子見ですが 感謝です。

Powered by GRATICA