添加兩個小時的計時器以根據修改日期移動檔案-有解無憂

一些 VBA 專家幫助了我很多，并為我修復了代碼，它一次移動一個檔案，但它首先移動檔案夾中最舊的檔案。但是，這里我有一個復雜的情況，目前無法解決。即我想添加一個兩個小時的計時器，即檔案應該在兩個小時后移動。

例如，如果一個名為“North_West data”的檔案的修改時間是下午 6:40，我希望代碼在兩個小時后準確地移動它。同樣，在下一次運行時，下一個必須移動的檔案已提交修改時間，例如下午 6:50，因此 VBA 代碼實際上應該在兩小時后移動它。這意味著每個檔案都應該有兩個小時的自動延遲計時器，我希望我能夠澄清查詢。

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

您可以在此處查看先前已解決的查詢

上一個查詢

uj5u.com熱心網友回復：

請嘗試下一個方法。基本上，它使用能夠捕獲檔案創建事件的 VBScript，它將創建的檔案名和創建時刻發送到應該一直打開的作業簿。

創建一個 VBScript 并將其命名為“FolderMonitor.vbs”。為此，請在空白記事本視窗中復制下一個代碼：

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

并按上述方式保存。但請注意不要將其保存為“FolderMonitor.vbs.txt”。為了避免這種情況，保存時應更改“另存為from default文本檔案（.txt）to所有檔案（ .*）”！

為了使以下代碼按原樣作業，您應該在運行代碼的作業簿所在的檔案夾中創建一個名為“VBScript”的檔案夾！

復制xlsm作業簿標準模塊中的下一個代碼。為了被上面的腳本呼叫，你應該把它命名為“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

一個。您首先應該運行 "startMonitoring" Sub。它可以從Workbook_Open事件中呼叫。

灣。復制受監視檔案夾中的檔案并檢查它們是否按應有的方式復制。請注意，代碼會在一分鐘后移動。它被評論以準確地顯示它可以改變什么以及如何改變......

轉載請註明出處，本文鏈接：https://www.uj5u.com/qiye/528675.html

標籤：vba

上一篇：如何使用VBA在PowerPoint中重命名分組中的形狀

下一篇：一次選擇一個檔案并移動