优化VBScript+Excel VBA实现15组文件夹延迟2小时移文件

核心思路 #

1. 用Excel工作表统一管理15组源文件夹-目标文件夹映射，避免重复创建文件
2. 修改VBScript，使其同时监控所有源文件夹
3. 调整VBA逻辑，接收文件所在的源路径，匹配对应的目标路径完成延迟迁移

步骤1：配置Excel文件夹映射表 #

在Folder monitor.xlsm中新建工作表，命名为FolderPairs，按如下格式填写（路径末尾需加反斜杠\）：

步骤2：修改Excel VBA代码 #

替换原标准模块中的代码为以下内容：

Option Explicit

Private Const ourScript As String = "FolderMonitor.vbs"

' 获取源路径对应的目标路径
Private Function GetTargetPath(sourcePath As String) As String
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("FolderPairs")
    
    Dim lastRow As Long, i As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lastRow
        If UCase(ws.Cells(i, "A").Value) = UCase(sourcePath) Then
            GetTargetPath = ws.Cells(i, "B").Value
            Exit Function
        End If
    Next i
    
    GetTargetPath = "" ' 未找到对应映射时返回空
End Function

Sub startMonitoring()
    Dim strVBSPath As String
    strVBSPath = ThisWorkbook.Path & "\VBScript\" & ourScript
    
    TerminateMonitoringScript ' 先终止已有监控进程
    Shell "cmd.exe /c """ & strVBSPath & """", 0
End Sub

Sub TerminateMonitoringScript()
    Dim objWMIService As Object, colItems As Object, objItem As Object, cmdLine As String
      
    Set objWMIService = GetObject("winmgmts:\.\root\CIMV2")
    Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", 48)

    For Each objItem In colItems
        If objItem.Caption = "wscript.exe" Then
            On Error Resume Next
            cmdLine = objItem.CommandLine
            On Error GoTo 0
            If InStr(1, cmdLine, ourScript) > 0 Then
                Debug.Print "终止Wscript进程..."
                objItem.Terminate
            End If
        End If
    Next
    
    Set objWMIService = Nothing: Set colItems = Nothing
End Sub

' 接收VBS传递的信息：文件名、创建时间、源文件夹路径
Sub GetMonitorInformation(arr As Variant)
    Dim sourcePath As String, targetPath As String
    sourcePath = arr(2)
    targetPath = GetTargetPath(sourcePath)
    
    If targetPath = "" Then
        Debug.Print "未找到" & sourcePath & "对应的目标路径，跳过文件" & arr(0)
        Exit Sub
    End If
    
    ' 延迟2小时执行迁移（测试时可改为00:01:00）
    Dim runTime As Date
    runTime = CDate(arr(1)) + TimeValue("02:00:00")
    
    ' 转义特殊字符，避免OnTime调用出错
    Dim safeFileName As String, safeSource As String, safeTarget As String
    safeFileName = Replace(arr(0), "'", "''")
    safeSource = Replace(sourcePath, "'", "''")
    safeTarget = Replace(targetPath, "'", "''")
    
    Application.OnTime runTime, "'DoSomething """ & safeFileName & """, """ & safeSource & """, """ & safeTarget & """'"
    Debug.Print "已安排" & arr(0) & "在" & runTime & "从" & sourcePath & "迁移到" & targetPath
End Sub

Sub DoSomething(strFileName As String, sourcePath As String, targetPath As String)
    ' 检查目标文件是否已存在
    If Dir(targetPath & strFileName) = "" Then
        On Error Resume Next
        Name sourcePath & strFileName As targetPath & strFileName
        On Error GoTo 0
        
        If Err.Number = 0 Then
            Debug.Print strFileName & "已从" & sourcePath & "迁移到" & targetPath
        Else
            MsgBox "迁移" & strFileName & "失败：" & Err.Description, vbExclamation
        End If
    Else
        MsgBox "目标路径已存在文件：" & targetPath & strFileName, vbExclamation
    End If
End Sub

步骤3：修改VBScript代码 #

替换原VBScript代码为以下内容：

Dim objExcel, wb, ws, lastRow, i
Dim strWB, strComputer, strTime, objWMIService, colMonitoredEvents
Dim folderPaths(), wmiPath, queryStr, objEventObject, fileInfo, sourcePath, fileName

strWB = "E:\Delta\Folder monitor.xlsm"

' 连接到已打开的Excel工作簿
Set objExcel = GetObject(,"Excel.Application")
Set wb = objExcel.Workbooks(Replace(strWB, "\", "/")) ' 兼容路径格式
If wb Is Nothing Then 
    WScript.Echo "未找到打开的工作簿：" & strWB
    WScript.Quit
End If

' 读取FolderPairs工作表中的源文件夹路径
Set ws = wb.Worksheets("FolderPairs")
lastRow = ws.Cells(ws.Rows.Count, "A").End(-4162).Row ' xlUp的数值
If lastRow < 2 Then
    WScript.Echo "FolderPairs工作表中未配置任何源文件夹"
    WScript.Quit
End If

' 将源路径转换为WMI需要的格式（4个反斜杠）
ReDim folderPaths(1 To lastRow - 1)
For i = 2 To lastRow
    sourcePath = ws.Cells(i, "A").Value
    ' 替换单个反斜杠为四个反斜杠
    wmiPath = Replace(sourcePath, "\", "\\\\")
    ' 构建WMI查询的条件片段
    folderPaths(i - 1) = "TargetInstance.GroupComponent='Win32_Directory.Name=" & Chr(34) & wmiPath & Chr(34) & "'"
Next i

' 构建多文件夹监控的WMI查询
strComputer = "."
strTime = "10" ' 每10秒检查一次
queryStr = "SELECT * FROM __InstanceOperationEvent WITHIN " & strTime & " WHERE " & _
           "Targetinstance ISA 'CIM_DirectoryContainsFile' and (" & Join(folderPaths, " OR ") & ")"

Set objWMIService = GetObject("winmgmts:\" & strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery(queryStr)

' 持续监控文件创建事件
Do While True
    Set objEventObject = colMonitoredEvents.NextEvent()
    Select Case objEventObject.Path_.Class
        Case "__InstanceCreationEvent"
            ' 解析文件所在的源路径
            fileInfo = Split(objEventObject.TargetInstance.GroupComponent, "=")
            sourcePath = Replace(Replace(fileInfo(1), Chr(34), ""), "\\\\", "\\")
            ' 解析文件名
            fileName = StrReverse(objEventObject.TargetInstance.PartComponent)
            fileName = StrReverse(Left(fileName, InStr(fileName, "\\") - 1))
            fileName = Mid(fileName, 1, Len(fileName) - 1)
            
            ' 传递信息给Excel VBA
            objExcel.Application.Run "'" & strWB & "'!GetMonitorInformation", Array(fileName, Now, sourcePath)
    End Select
Loop

使用说明 #

1. 确保Folder monitor.xlsm处于打开状态
2. 点击VBA中的startMonitoring宏启动监控
3. 若需要停止监控，运行TerminateMonitoringScript宏

内容的提问来源于stack exchange，提问作者Salman Shafi