Home > OS >  To move files from multiple source folders to multiple destination folders based on two hour delay
To move files from multiple source folders to multiple destination folders based on two hour delay

Time:11-10

Yesterday we have finalized and tested the code (the first part of the code is VBScript) and the second part of the code is (in Excel VBA) to move file from one source folder to one destination folder successfully based on two hour delay (i.e. each file which will come to source folder will upload 2 hour delay), however the situation is that i have actually 15 source folders and 15 destination folders.

One method is that i should create 15 VBScript files and 15 Excel files that contains the code for each source and destination folder which i believe is not efficient way. I have tried a lot to add multiple source and destination folder options in the below mentioned code(s) but i am not successful, can anyone help me, i will be thankful.

the below mentioned code is 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

and the second code for this purpose should be copied in a standard module:

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

you can see the previous query here on the link Previous Query

CodePudding user response:

Please, use the next scenario. It assumes that you will fill the necessary path in an existing Excel sheet. Since, it will take the necessary paths based on a cell selection, it is necessary to name the sheet in discussion as "Folders". In Column A:A you should fill the 'Source' folder path (ending in backslash "") and in B:B, the 'Destination' folder path (also ending in backslash).

  1. The proposed solution takes the necessary paths based on your selection in A:A column. The 'Destination' path is extracted based on the selection row.

  2. Please, replace the existing string with the next one, adapting the two necessary paths:

Dim oExcel, strWB, nameWB, wb

strWB = "C:\Teste VBA Excel\Folder 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 & "\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) & "'")' 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

The adapted script sends also the source path to the waiting workbook...

  1. TerminateMonintoringScript Sub remains exactly as it is.

  2. Please, copy the next adapted code instead of existing one, in the used standard module (TerminateMonintoringScript included, even not modified):

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:\\" & "." & "\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'
    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

So, you only need to replace the existing VBA code with the above adapted one, to place the 'source'/'destination' paths in columns A:B of one of Excel sheets, which to be named "Folders".

Select in column A:A a 'Source' cell and run startMonitoring.

Play with files creation and check their moving from the new 'source' to the new 'destination'...

But you have to understand that only a session of the WMI class can run at a specific moment. This means that you cannot simultaneously monitor more then one folder...

I am still documenting regarding the possibility to use a query able to be common for multiple folders. But never see such an approach till now and it may not be possible...

  •  Tags:  
  • vba
  • Related