VBS. Ошибка - Разрешение отклонено

Question

Имеется скрипт, который выполняет следующее:

При появлении файла с расширением mp4 в папке "iPath", копирует этот файл в папку "oPath"

При появлении файла в папке "iPath" (перед копированием), сразу выскакивает ошибка

Сам скрипт:

Option Explicit: Dim oFSO, SINK, FName
'——————————————————————————————————————
Const Ext   = "mp4"  ' расширение файла
Const iPath = "Q:\GameVideos\Temp\Hunt  Showdown" ' папка временных файлов
Const oPath = "Q:\GameVideos\Temp\TEST" ' папка, куда копировать
'——————————————————————————————————————
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set SINK = WSH.CreateObject("WbemScripting.SWbemSink", "SINK_")
GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")._
ExecNotificationQueryAsync SINK, "SELECT * FROM __InstanceCreationEvent WITHIN 2 WHERE " & _
"Targetinstance ISA 'CIM_DirectoryContainsFile' and TargetInstance.GroupComponent=" &_
"'Win32_Directory.Name=""" & Replace(iPath, "\", "\\\\") & """'"
Do: wsh.Sleep 60000000 :Loop
 
Sub SINK_OnObjectReady(oEvent, oAsyncContext)
  FName = Replace(Split(oEvent.TargetInstance.PartComponent, """")(1), "\\", "\")
  If oFSO.GetExtensionName(FName) = Ext Then oFSO.CopyFile FName, oFSO.BuildPath(oPath, "\"), 1
End Sub

Answer 1

Вариант цикла с задержкой для обработки файла. В данном случае - удаления, так проще осуществить временное блокирование файла. На копировании не тестировал.

iName = "c:\test\iPath\test.mp3"
oName = "c:\test\oPath\"
Set oFSO = CreateObject("Scripting.FileSystemObject")
on error resume Next
do: ' пока файл заблокирован (проигрывается), будет повторяться цикл
    WScript.Echo "Before oFSO..."
    'oFSO.CopyFile iName, oName, True
    oFSO.DeleteFile iName, True
    if err.number=0 then exit Do
    err.clear
    wsh.Sleep 1000
loop
WScript.Echo "Operation completed"

Как-то давно делал ожидание завершения процесса на VBA (распаковка файлов из архива) через WaitForSingleObject. Не очень близко, но сам подход может пригодиться.

Public Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Public Const SYNCHRONIZE = &H100000
Public Const INFINITE = &HFFFFFFFF

Public Function SyncShell(ByVal ProcessID As Long)
    On Error GoTo SyncShell_Error
    ProcessHandle = OpenProcess(SYNCHRONIZE, True, ProcessID)
    WaitForSingleObject ProcessHandle, INFINITE
    SyncShell = True
    Exit Function
SyncShell_Error:
    On Error GoTo 0
    SyncShell = False
    Exit Function
End Function

Sub RARUnPack(Folder As String)
    Dim rslt As Long
    pathtoRAR = "c:\Program Files\WinRAR\WinRAR.exe"

    rslt = Shell(pathtoRAR & " e -inul -o- -y """ & Folder & "\*.rar"" """ & Folder & """", vbNormalFocus)
    c = SyncShell(rslt)
    MyAppActive
End Sub

БЛОГ НА HUSL

VBS. Ошибка - Разрешение отклонено

Ответы (1 шт):