to add two hours of timer to move file based on date modified-CodePudding

Some of VBA Experts have helped me a lot and have fixed the code for me which moves one file one at a time but it first moves the oldest file in the folder. However here i have a complex situation which for now not resolving. i.e. I would like to add a timer of two hours i.e. the file should move after two hour.

e.g. If a file named "North_West data" whose modified time is 6:40 PM i would like the code to move it exactly after two hours. Similarly at the next run the next file which has to be moved has filed modified time e.g. 6:50 PM so the VBA code should actually move it exactly after two hours. this means each file should have automatic two hours delay timer in it, i hope i am able to clarify the query.

Function OldestFile(strFold As String) As String
    Dim FSO As Object, Folder As Object, File As Object, oldF As String
    Dim lastFile As Date: lastFile = Now
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strFold)

    For Each File In Folder.Files
        If File.DateLastModified < lastFile Then
            lastFile = File.DateLastModified: oldF = File.Name
        End If
    Next
    OldestFile = oldF
End Function

Sub MoveOldestFile()
    Dim FromPath As String, ToPath As String, fileName As String

    FromPath = "E:\Source\"
    ToPath = "E:\Destination\"

    fileName = OldestFile(FromPath)

    If Dir(ToPath & fileName) = "" Then
        Name FromPath & fileName As ToPath & fileName
    Else
        MsgBox "File """ & fileName & """ already moved..."
    End If
End Sub

You can check the previously resolved query here

Previous query

CodePudding user response：

Please, try the next way. Basically, it uses a VBScript able to catch file creation event, which sends the created file name and the moment of creation to a workbook which should be open all the time.

Create a VBScript and name it "FolderMonitor.vbs". To do that, please copy the next code in an empty Notepad window:

Dim oExcel, strWB, nameWB, wb

strWB = "C:\Teste VBA Excel\Folder monitor.xlsm" 'use here the path of the waiting workbook!
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) & "'")
 

Do While True
    Set objEventObject = colMonitoredEvents.NextEvent()
    Select Case objEventObject.Path_.Class
        Case "__InstanceCreationEvent"
            ' msgbox "OK"
            'MsgBox "A new file was just created: " & _
                'objEventObject.TargetInstance.PartComponent
            
            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 save it as stated above. But take care to not save it as "FolderMonitor.vbs.txt". In order to avoid that, when saving you should change 'Save as typefrom defaultText documents (.txt)toAll files (.*)`!

In order to make the following code working as it is, you should create a folder named "VBScript" in the folder where the workbook running the code exists!

Copy the next code in a standard module of a xlsm workbook. In order to be called by the above script, as it is, you should name it "Folder monitor.xlsm":

Option Explicit

Private Const ourScript As String = "FolderMonitor.vbs"
Private Const fromPath As String = "E:\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 "OK"
                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":
    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:\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

a. You firstly should run "startMonitoring" Sub. It can be called from the Workbook_Open event.

b. Copy files in the monitored folder and check if they are copied as it should. Note that the code as it is move it after a minute. It is commented to exactly show what and how it can be changed...