Код:

Option Explicit
 
Const ForReading = 1, ForWriting = 2, ForAppending = 8
 
Dim MySource, MyTarget, MyZipName, MyHex, MyBinary, i
Dim oShell, oApp, oFolder, oCTF, oFile
Dim oFileSys
 
MySource = "Что"
MyTarget = "Куда.zip"
 
MyHex = Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
 
For i = 0 To UBound(MyHex)
MyBinary = MyBinary & Chr(MyHex(i))
Next
 
Set oShell = CreateObject("WScript.Shell")
Set oFileSys = CreateObject("Scripting.FileSystemObject")
 
 
Set oCTF = oFileSys.CreateTextFile(MyTarget, True)
oCTF.Write MyBinary
oCTF.Close
Set oCTF = Nothing
 
Set oApp = CreateObject("Shell.Application")
 
Set oFolder = oApp.NameSpace(MySource)
If Not oFolder Is Nothing Then
oApp.NameSpace(MyTarget).CopyHere oFolder.Items
End If
 
wScript.Sleep(5000)
 
 
Set oFile = Nothing
On Error Resume Next
Do While (oFile Is Nothing)
 
Set oFile = oFileSys.OpenTextFile(MyTarget, ForAppending, False)
If Err.number <> 0 then
Err.Clear
wScript.Sleep 3000
End If
Loop
 
Set oFile=Nothing
Set oFileSys=Nothing