基于两小时延迟将文件从多个源文件夹移动到多个目标文件夹

Question

昨天我们已经完成并测试了代码（代码的第一部分是 VBScript），代码的第二部分是（在 Excel VBA 中）基于两个小时的延迟成功地将文件从一个源文件夹移动到一个目标文件夹（即每个将到达源文件夹的文件都会延迟 2 小时上传），但情况是我实际上有 15 个源文件夹和 15 个目标文件夹。

一种方法是我应该创建 15 个 VBScript 文件和 15 个 Excel 文件，其中包含每个源和目标文件夹的代码，我认为这不是有效的方法。我已经尝试了很多在下面提到的代码中添加多个源和目标文件夹选项，但我没有成功，任何人都可以帮助我，我将不胜感激。

下面提到的代码是VBscript

Dim oExcel, strWB, nameWB, wb

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

nameWB = Left(strWB, InStr(StrReverse(strWB), "\") - 1)

nameWB = Right(strWB, Len(nameWB))

Set objExcel = GetObject(,"Excel.Application")

Set wb = objExcel.Workbooks(nameWB)

if wb is nothing then wbscript.quit 'the necessary workbook is not open...

dim strComputer, strDirToMonitor, strTime, objWMIService, colMonitoredEvents, objEventObject, MyFile

strComputer = "."

'# WMI needs two backslashes (\\) as path separator and each of it should be excaped.

'# So, you must use 4 backslashes (\\\\) as path separator!

strDirToMonitor = "E:\\\\Delta\\\\Source" 'use here your path

'# Monitor Above every 10 secs...

strTime = "10"

Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

Set colMonitoredEvents = objWMIService.ExecNotificationQuery _

    ("SELECT * FROM __InstanceOperationEvent WITHIN " & strTime & " WHERE " _

        & "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _

            & "TargetInstance.GroupComponent= " _

                & "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")
 

Do While True

    Set objEventObject = colMonitoredEvents.NextEvent()

    Select Case objEventObject.Path_.Class
        Case "__InstanceCreationEvent"

            ' msgbox "OK"

            'MsgBox "A new file was just created: " & _
            
            MyFile = StrReverse(objEventObject.TargetInstance.PartComponent)

            '// Get the string to the left of the first \ and reverse it

            MyFile = (StrReverse(Left(MyFile, InStr(MyFile, "\") - 1)))

            MyFile = Mid(MyFile, 1, Len(MyFile) - 1)

             'send the information to the waiting workbook:

             objExcel.Application.Run "'" & strWB & "'!GetMonitorInformation", Array(MyFile,Now)

    End Select

Loop

并且为此目的的第二个代码应复制到标准模块中：

Option Explicit

Private Const ourScript As String = "FolderMonitor.vbs"

Private Const fromPath As String = "E:\Delta\Source\"

Sub startMonitoring()

    Dim strVBSPath As String

    strVBSPath = ThisWorkbook.Path & "\VBScript\" & ourScript

    TerminateMonintoringScript 'to terminate monitoring script, if running..
    
    Shell "cmd.exe /c """ & strVBSPath & """", 0

End Sub

Sub TerminateMonintoringScript()

    Dim objWMIService As Object, colItems As Object, objItem As Object, Msg 
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
            '// msg Contains the path of the exercutable script and the script name
            On Error Resume Next
              Msg = objItem.CommandLine 'for the case of null
            On Error GoTo 0
            '// If wbscript.exe runs the monitoring script:
            If InStr(1, Msg, ourScript) > 0 Then
                Debug.Print "Terminate Wscript process..."
                objItem.Terminate 'terminate process
            End If
        End If
    Next
    
    Set objWMIService = Nothing: Set colItems = Nothing
End Sub

Sub GetMonitorInformation(arr As Variant)

    'call DoSomething Sub after  2 hours (now IT WILL RUN AFTER 1 MINUTE, for testing reasons...)

    'for running after 2 hours you should change "00:01:00" in "02:00:00":

    arr(0) = Replace(arr(0), "'", "''") 'escape simple quote (') character'

    Application.OnTime CDate(arr(1)) + TimeValue("00:01:00"), "'DoSomething """ & CStr(arr(0)) & """'"

    Debug.Print "start " & Now 'just for testing (wait a minute...)
                                                    'finaly, this line should be commented.

End Sub

Sub DoSomething(strFileName As String)

     Const toPath As String = "E:\Delta\Destination\"

     If Dir(toPath & strFileName) = "" Then

            Name fromPath & strFileName As toPath & strFileName

            Debug.Print strFileName & " moved from " & fromPath & " to " & toPath 'just for testing...

     Else
            MsgBox "File """ & toPath & strFileName & """ already exists in this location..."
     End If
End Sub

您可以在链接Previous Query 上查看之前的查询

Answer 1

请使用下一个场景。它假定您将在现有 Excel 工作表中填写必要的路径。由于它将根据单元格选择采取必要的路径，因此有必要将讨论中的工作表命名为“文件夹”。在 A:A 列中，您应该填写“源”文件夹路径（以反斜杠“”结尾），在 B:B 中填写“目标”文件夹路径（也以反斜杠结尾）。

1. 建议的解决方案会根据您在 A:A 列中的选择采取必要的路径。 'Destination' 路径是根据选择行提取的。

2. 请用下一个替换现有字符串，调整两个必要的路径：

   Dim oExcel, strWB, nameWB, wb
   
   strWB = "C:Teste VBA ExcelFolder monitor.xlsm" 'use here your workbook path!!!
   nameWB = Left(strWB, InStr(StrReverse(strWB), "") - 1)
   nameWB = Right(strWB, Len(nameWB))
   
   Set objExcel = GetObject(,"Excel.Application")
   Set wb = objExcel.Workbooks(nameWB)
   if wb is nothing then wbscript.quit 'the necessary workbook is not open...
   
   dim strComputer, strDirToMonitor, strTime, objWMIService, colMonitoredEvents, objEventObject, MyFile
   strComputer = "."
   '# WMI needs two backslashes (\) as path separator and each of it should be excaped.
   '# So, you must use 4 backslashes (\\) as path separator!
   strDirToMonitor = "C:\\test\\test" 'use here your path !!!
   
   '# Monitor Above every 10 secs...
   strTime = "10"
   
   Set objWMIService = GetObject("winmgmts:\" & strComputer & "
   ootcimv2")
   
   Set colMonitoredEvents = objWMIService.ExecNotificationQuery _
       ("SELECT * FROM __InstanceOperationEvent WITHIN " & strTime & " WHERE " _
           & "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
               & "TargetInstance.GroupComponent= " _
                   & "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")' and " _
                  ' & "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")
    
   
   Do While True
       Set objEventObject = colMonitoredEvents.NextEvent()
       Select Case objEventObject.Path_.Class
           Case "__InstanceCreationEvent"
               MyFile = StrReverse(objEventObject.TargetInstance.PartComponent)
               ' Get the string to the left of the first  and reverse it
               MyFile = (StrReverse(Left(MyFile, InStr(MyFile, "") - 1)))
               MyFile = Mid(MyFile, 1, Len(MyFile) - 1)
   
                'send the information to the waiting workbook:
                objExcel.Application.Run "'" & strWB & "'!GetMonitorInformation", Array(MyFile, Now, strDirToMonitor)
       End Select
   Loop
   

   改编后的脚本还将源路径发送到等待的工作簿......

   3. TerminateMonintoringScript Sub 保持原样。

   4. 请在使用的标准模块中复制下一个改编代码而不是现有代码（包括TerminateMonintoringScript，甚至未修改）：

   Option Explicit
   
   Private Const ourScript As String = "FolderMonitor.vbs"
   Private fromPath As String, toPath As String
   
   Sub startMonitoring()
       Dim strVBSPath As String, actCell As Range, strTxt As String, pos As Long, endP As Long, oldPath As String
       
       Set actCell = ActiveCell
       If actCell.Parent.Name <> "Folders" Then MsgBox "Wrong activated sheet...": Exit Sub
       fromPath = actCell.Value
       If actCell.Column <> 1 Or Dir(fromPath, vbDirectory) = "" Then Exit Sub   'not a valid path in the selected cell
       
        strVBSPath = ThisWorkbook.Path & "VBScript" & ourScript
       'change the script necessary "strDirToMonitor" variable path, if the case:__________________________
       strTxt = ReadFile(strVBSPath)
       
       pos = InStr(strTxt, Replace(fromPath, "", "\\"))
       If pos = 0 Then  'if not the correct path already exists
           pos = InStr(strTxt, "strDirToMonitor = """)          'start position of the existing path
           endP = InStr(strTxt, """ 'use here your path")    'end position of the existing path
           'extract existing path:
           oldPath = Mid(strTxt, pos + Len("strDirToMonitor = """), endP - (pos + Len("strDirToMonitor = """)))
           strTxt = Replace(strTxt, oldPath, _
                            Replace(Left(fromPath, Len(fromPath) - 1), "", "\\")) 'replacing existing with the new one
          
           'drop back the updated string in the vbs file:
           Dim iFileNum As Long: iFileNum = FreeFile
           Open strVBSPath For Output As iFileNum
               Print #iFileNum, strTxt
           Close iFileNum
       End If
       '__________________________________________________________________________________________________
      
       TerminateMonintoringScript 'to terminate monitoring script, if running...
       
        Application.Wait Now + TimeValue("00:00:02") 'to be sure that the next line will load the updated file...
       
       Shell "cmd.exe /c """ & strVBSPath & """", 0 'run the VBScript
   End Sub
   
   
   Function ReadFile(strFile As String) As String 'function to read the vbscript string content
     Dim iTxtFile As Integer
     
     iTxtFile = FreeFile
     Open strFile For Input As iTxtFile
        ReadFile = Input(LOF(iTxtFile), iTxtFile)
     Close iTxtFile
   End Function
   
   Sub TerminateMonintoringScript()
       Dim objWMIService As Object, colItems As Object, objItem As Object, Msg As String
         
       Set objWMIService = GetObject("winmgmts:\" & "." & "
   ootCIMV2")
       Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", 48)
   
       For Each objItem In colItems
           If objItem.Caption = "wscript.exe" Then
               '// msg Contains the path of the exercutable script and the script name
               On Error Resume Next
                 Msg = objItem.CommandLine 'for the case of null
               On Error GoTo 0
               '// If wbscript.exe runs the monitoring script:
               If InStr(1, Msg, ourScript) > 0 Then
                   Debug.Print "Terminate Wscript process..."
                   objItem.Terminate 'terminate process
               End If
           End If
       Next
       
       Set objWMIService = Nothing: Set colItems = Nothing
   End Sub
   
   Sub GetMonitorInformation(arr As Variant)
       'call DoSomething Sub after  2 hours (now IT WILL RUN AFTER 1 MINUTE, for testing reasons...)
       'for running after 2 hours you should change "00:01:00" in "02:00:00":
       arr(0) = Replace(arr(0), "'", "''") 'escape simple quote (') character'
       fromPath = Replace(arr(2), "\\", "")
       Dim rngFrom As Range: Set rngFrom = ThisWorkbook.Sheets("Folders").Range("A:A").Find(what:=fromPath)
       toPath = rngFrom.Offset(, 1).Value
       Application.OnTime CDate(arr(1)) + TimeValue("00:00:30"), "'DoSomething """ & fromPath & "" & CStr(arr(0)) & """, """ & toPath & CStr(arr(0)) & """'"
       Debug.Print Now; " start " & arr(0) & fromPath & "" & CStr(arr(0))  'just for testing (wait a minute...)
                                                       'finaly, this line should be commented.
   End Sub
   
   Sub DoSomething(sourceFileName As String, destFilename As String)
        If Dir(destFilename) = "" Then
               Name sourceFileName As destFilename
               Debug.Print sourceFileName & " moved to " & destFilename 'just for testing...
        Else
               Debug.Print "File """ & destFilename & """ already exists in this location..."
        End If
   End Sub
   
   
   Sub DoSomething_(strFileName As String) 'cancelled
        If Dir(toPath & strFileName) = "" Then
               Name fromPath & strFileName As toPath & strFileName
               Debug.Print strFileName & " moved from " & fromPath & " to " & toPath 'just for testing...
        Else
               MsgBox "File """ & toPath & strFileName & """ already exists in this location..."
        End If
   End Sub
   

   因此，您只需将现有的 VBA 代码替换为上述修改后的代码，将“源”/“目标”路径放置在 Excel 工作表之一的 A:B 列中，将其命名为“文件夹”。

   选择在 A 列中：A一个“源”单元格并运行startMonitoring。

   玩文件创建并检查它们从新“源”到新“目标”的移动......

   但您必须了解，只有 WMI 类的会话才能在特定时刻运行.这意味着您不能同时监控多个文件夹...

   我仍在记录有关使用对多个文件夹通用的查询的可能性。但是直到现在我才看到这样的方法，这可能是不可能的......