代码(代码的第一部分是VBScript)和代码的第二部分是(在Excel VBA中)将文件从一个源文件夹移动到一个目标文件夹，延迟两小时(即每个文件到达源文件夹将在延迟两小时后上传)。
但是我有15个源文件夹和15个目标文件夹。
一种方法是创建15个VBScript文件和15个Excel文件，其中包含每个源和目标文件夹的代码，我认为效率不高。
我试图在下面的代码中添加多个源和目标文件夹选项。
下面的代码是VBscriptDim oExcel, strWB, nameWB, wb
strWB = "E:DeltaFolder 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 & "rootcimv2")
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:DeltaSource"
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:\" & "." & "rootCIMV2")
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:DeltaDestination"
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
前查询
请使用下一个场景。它假设您将在现有的Excel工作表中填充必要的路径。由于它将根据单元格选择采取必要的路径，因此有必要将所讨论的工作表命名为"文件夹"。在A列A中，您应该填写"源"文件夹路径(以反斜杠""结尾)，在B列B中，填写"目标"文件夹路径(也以反斜杠结尾)。
-
建议的解决方案根据您在A:A列中的选择采取必要的路径。'Destination'路径是根据选择行提取的。
-
请将现有字符串替换为下一个字符串，适应两个必要的路径:
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 & "rootcimv2")
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
改编后的脚本还将源路径发送到等待工作簿…
TerminateMonintoringScriptSub保持原样请在使用的标准模块(包括
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:\" & "." & "rootCIMV2")
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中，该表格将命名为"文件夹"。
Selectin column A:Aa"源"单元格并运行startMonitoring。
播放文件创建并检查它们从新的'源'移动到新的'目标'…
但是你必须明白只有一个会话的WMI类可以运行在一个特定的时刻。这意味着您不能同时监视多个文件夹…
我仍然在记录关于使用查询的可能性，能够对多个文件夹通用。但我从来没有看到过这样的方法，直到现在，这可能是不可能的…