[megaloman]

Iska, pinguindell, Для себя делаю резюме:

Вариант без стороннего архиватора

Этот вариант не годится для размещения в планировщике, так как обязательно надо отследить завершение архивации. Строка
MsgBox "После окончания процесса записи в архив нажмите ОК"
обязательна.

Код:

FileIn = "Z:\Box_In\С Днем Рождения.ppt"

BoxArc = "Z:\Box_Arc"

With CreateObject("Scripting.FileSystemObject")
    If Not .FileExists(FileIn) Then
        WScript.Echo "!!! File " + FileIn + " not found"
        WScript.Quit 1
    End If

    If Not .FolderExists(BoxArc) Then
        WScript.Echo "!!! Folder " + BoxArc + " not found"
        WScript.Quit 1
    End If
    
    DT = CStr(Year(Date)) + Right("0" + CStr(Month(Date)), 2) + Right("0" + CStr(Day(Date)), 2)
    DT = DT + "-" + Right("0" + CStr(Hour(Time)), 2) + Right("0" + CStr(Minute(Time)), 2) + Right("0" + CStr(Second(Time)), 2)
    
    Zip = BoxArc + "\" + .GetBaseName(FileIn) + "_" + DT + ".zip"
    
    On Error Resume Next
    
    Err.Number = 0
    .CreateTextFile(Zip, True).Write "PK" + Chr(5) + Chr(6) + String(18, vbNullChar)

    If Err.Number <> 0 Then
        WScript.Echo "!!! " + Zip + "  " + Err.Description + "(" + CStr(Err.Number) + ")"
        WScript.Quit 1
    End If

    Err.Number = 0
    Set App = CreateObject("Shell.Application")
    Call App.Namespace(Zip).CopyHere(FileIn)

    If Err.Number <> 0 Then
        WScript.Echo "!!! " + Zip + "  " + Err.Description + "(" + CStr(Err.Number) + ")"
        WScript.Quit 1
    End If
End With
On Error GoTo 0
MsgBox "После окончания процесса записи в архив нажмите ОК" 

Как альтернатива, в предыдущем коде можно вставить заведомо бОльшее время ожидания чем требуется для завершения создания архива. Этот вариант можно поместить в планировщик. Раз архивирование делается с интервалом в часы, то и время ожидания можно поставить большое, например, 300 сек
MsgBox необходимо удалить

Код:

    ..............
    ..............

    Call App.Namespace(Zip).CopyHere(FileIn)

    WScript.Sleep 300 * 1000

    If Err.Number <> 0 Then
        WScript.Echo "!!! " + Zip + "  " + Err.Description + "(" + CStr(Err.Number) + ")"
        WScript.Quit 1
    End If
End With
On Error GoTo 0
' MsgBox "После окончания процесса записи в архив нажмите ОК"

Можно, конечно, попробовать обойтись без Sleep Как вариант, посчитать количество файлов в архиве. Но это скользкий путь, так как при архивации большого файла он помещается в архив не сразу целиком, и преждевременное завершение скрипта приведёт к созданию увечного архива.

Вариант со сторонним архиватором, например, 7Z, запускаемым из-под vbs. Без проблем отработает в назначенных заданиях

Код:

FileIn = "Z:\Box_In\С Днем Рождения.ppt"
BoxArc = "Z:\Box_Arc"

Arc = "C:\Program Files\7-Zip\7z.exe"

DT = CStr(Year(Date)) + Right("0" + CStr(Month(Date)), 2) + Right("0" + CStr(Day(Date)), 2)
DT = DT + "-" + Right("0" + CStr(Hour(Time)), 2) + Right("0" + CStr(Minute(Time)), 2) + Right("0" + CStr(Second(Time)), 2)
    
Zip = BoxArc + "\" + CreateObject("Scripting.FileSystemObject").GetBaseName(FileIn) + "_" + DT + ".zip"
    
Comm = """" + Arc + """ a """ + Zip + """ """ + FileIn + """ -mx5"
    
On Error Resume Next
    R = CreateObject("WScript.Shell").Run(Comm, 0, False)
    
    If Err.Number <> 0 Then
        WScript.Echo "Ошибка при вызове архиватора." + vbCrLf + vbCrLf + Comm + vbCrLf + vbCrLf + "Проверьте наличие файлов по указанным путям" + vbCrLf + Err.Description + "(" + CStr(Err.Number) + ")"
        WScript.Quit 1
    End If
On Error GoTo 0

Поубирал почти все проверки на существование файлов, так как всё равно при исполнении в назначенных заданиях аварийные сообщения никто не увидит. Кстати, а не сделать ли лог-файл этого процесса?