Create zip error: Namespace method fails on IShellDispatch
Create zip error: Namespace method fails on IShellDispatch
我们已经尝试解决这个问题将近一个星期了，但没有得到任何答复。
问题：创建 zip 文件时，抛出错误 "The method Namespace failed on IShellDispatch6."
到目前为止我们尝试了什么？
我们的代码基于 https://www.rondebruin.nl/win/s7/win001.htm 中的说明。它适用于我们的开发环境，但在少数客户端机器上明显失败。
我们的代码：
Code (vb):
Option Explicit
Public zipfile As Variant ' Care taken that this must be a variant
Private baseDirectory As Variant ' Care taken that this must be a variant
Private FileName As String ' This needn't be a variant - tried and tested.
Private done As Boolean
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
#End If
' Optional folderNumber taken to try create 10 zip files in a loop.
' Read somewhere that shell activities spawn into separate threads.
' A loop can expose any such vulneribility
Public Sub zip(Optional folderNumber As Integer = 0)
Dim oApp
Dim dFolder
Sleep 100
baseDirectory = "C:\Users\Siddhant\AppData\Local\Temp\b w\"
zipfile = "" & baseDirectory & "stestzip" & CStr(folderNumber) & ".zip"
FileName = "" & baseDirectory & "stestzip.txt"
'Set dFolder = CreateObject("WScript.Shell")
Set oApp = CreateObject("Shell.Application")
Debug.Print "Starting zip process at " & CStr(VBA.Timer) & ". First creating zip file."
' Note the round brackets below around zipfile - These evaluate zipfile at run-time.
' These are not for parameter passing but to force evaluation.
NewZip (zipfile)
Debug.Print "Zip created at " & CStr(VBA.Timer)
'On Error GoTo here
' On development machine, following works fine.
' On client machine, call to oApp.Namespace(zipfile) fails
' giving error message described at beginning of this post..
Debug.Print "Critical Error----------------" & CStr(oApp.Namespace(zipfile) Is Nothing)
Dim loopChecker As Integer
loopChecker = 1
' On client machine, code doesn't even reach here.
While oApp.Namespace(zipfile) Is Nothing
' Well this loop simply waits 3 seconds
' in case the spawned thread couldn't create zipfile in time.
Debug.Print "Waiting till zip gets created."
Sleep 100
If loopChecker = 30 Then
Debug.Print "Wated 3 seconds for zip to get created. Can't wait any longer."
GoTo afterloop
End If
loopChecker = loopChecker + 1
Wend
afterloop:
Debug.Print "Now Condition is ---------------" & CStr(oApp.Namespace(zipfile) Is Nothing)
If oApp.Namespace(zipfile) Is Nothing Then
Debug.Print "Couldnot create zip file " & zipfile
Exit Sub
End If
Set dFolder = oApp.Namespace(zipfile)
'MsgBox FileName
Sleep 200
dFolder.CopyHere "" & FileName, 4
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until dFolder.Items.Count = 1
done = False
'Application.Wait (Now + TimeValue("0:00:01"))
Sleep 100 'wait for 1/10 th of second
Loop
done = True
On Error GoTo 0
here:
If Not dFolder Is Nothing Then
Set dFolder = Nothing
End If
If Not oApp Is Nothing Then
Set oApp = Nothing
End If
End Sub
Public Function Success() As Boolean
Success = done
End Function
Public Sub ClearFileSpecs()
FileName = ""
End Sub
Public Sub AddFileSpec(FileLocation As String)
FileName = FileLocation
End Sub
Sub NewZip(sPath)
'Create empty Zip File
If Len(Dir(sPath)) > 0 Then Kill sPath
Debug.Print "Creating zip file"
Open sPath For Output As #1
Debug.Print "Zip file created, writing zip header"
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Debug.Print "zip header written, closing file."
Close #1
Debug.Print "Closing zip file."
End Sub
Function Split97(sStr As Variant, sdelim As String) As Variant
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
Sub testZipping()
Dim i As Integer
For i = 1 To 10
zip i
Next i
MsgBox "Done"
End Sub
Sub tryWait()
Dim i As Integer
For i = 1 To 10
Sleep 2000
Next i
End Sub
顺便说一句，我们还尝试了另一种解决方案来调用 oApp.Namespace((zipfile)) 强制评估 zipfile 变量。许多论坛描述了另一个问题，即文字字符串与 oApp.Namespace("c:\an\example") 一起工作。在此类论坛中，建议使用 2 个圆括号的解决方案。
但是保持 "DIM zipfile As Variant" 和 "oApp.Namespace((zipfile))" 都不起作用。
会不会是客户端机器上的shell32.dll损坏了？请帮忙！如果能提供任何帮助，我将不胜感激！
我也在 http://forum.chandoo.org/threads/create-zip-error-namespace-method-fails-on-ishelldispatch.34010/
上发布了这个问题
我们终于搞定了。当归结为 Namespace() 方法在 IShellDispatch 实例上失败时，必须修复 OS 安装，这解决了问题。此外，我们后来发现依赖基于 Windows Shell 的压缩不够可靠，因为 copyhere() 方法没有 return 任何完成状态。此外，它是异步的，它要求像在 copyhere() 调用之后放置一个循环这样的黑客攻击。这个循环会休眠几毫秒并比较源文件夹和目标文件夹的项目。此 hack 可能会导致实际的 copyhere 操作和比较查询发生冲突。我们终于开始实施基于 ZLib 的 DLL，它可以帮助我们满足压缩和解压缩要求。
我们已经尝试解决这个问题将近一个星期了，但没有得到任何答复。 问题：创建 zip 文件时，抛出错误 "The method Namespace failed on IShellDispatch6." 到目前为止我们尝试了什么？ 我们的代码基于 https://www.rondebruin.nl/win/s7/win001.htm 中的说明。它适用于我们的开发环境，但在少数客户端机器上明显失败。 我们的代码：
Code (vb):
Option Explicit
Public zipfile As Variant ' Care taken that this must be a variant
Private baseDirectory As Variant ' Care taken that this must be a variant
Private FileName As String ' This needn't be a variant - tried and tested.
Private done As Boolean
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
#End If
' Optional folderNumber taken to try create 10 zip files in a loop.
' Read somewhere that shell activities spawn into separate threads.
' A loop can expose any such vulneribility
Public Sub zip(Optional folderNumber As Integer = 0)
Dim oApp
Dim dFolder
Sleep 100
baseDirectory = "C:\Users\Siddhant\AppData\Local\Temp\b w\"
zipfile = "" & baseDirectory & "stestzip" & CStr(folderNumber) & ".zip"
FileName = "" & baseDirectory & "stestzip.txt"
'Set dFolder = CreateObject("WScript.Shell")
Set oApp = CreateObject("Shell.Application")
Debug.Print "Starting zip process at " & CStr(VBA.Timer) & ". First creating zip file."
' Note the round brackets below around zipfile - These evaluate zipfile at run-time.
' These are not for parameter passing but to force evaluation.
NewZip (zipfile)
Debug.Print "Zip created at " & CStr(VBA.Timer)
'On Error GoTo here
' On development machine, following works fine.
' On client machine, call to oApp.Namespace(zipfile) fails
' giving error message described at beginning of this post..
Debug.Print "Critical Error----------------" & CStr(oApp.Namespace(zipfile) Is Nothing)
Dim loopChecker As Integer
loopChecker = 1
' On client machine, code doesn't even reach here.
While oApp.Namespace(zipfile) Is Nothing
' Well this loop simply waits 3 seconds
' in case the spawned thread couldn't create zipfile in time.
Debug.Print "Waiting till zip gets created."
Sleep 100
If loopChecker = 30 Then
Debug.Print "Wated 3 seconds for zip to get created. Can't wait any longer."
GoTo afterloop
End If
loopChecker = loopChecker + 1
Wend
afterloop:
Debug.Print "Now Condition is ---------------" & CStr(oApp.Namespace(zipfile) Is Nothing)
If oApp.Namespace(zipfile) Is Nothing Then
Debug.Print "Couldnot create zip file " & zipfile
Exit Sub
End If
Set dFolder = oApp.Namespace(zipfile)
'MsgBox FileName
Sleep 200
dFolder.CopyHere "" & FileName, 4
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until dFolder.Items.Count = 1
done = False
'Application.Wait (Now + TimeValue("0:00:01"))
Sleep 100 'wait for 1/10 th of second
Loop
done = True
On Error GoTo 0
here:
If Not dFolder Is Nothing Then
Set dFolder = Nothing
End If
If Not oApp Is Nothing Then
Set oApp = Nothing
End If
End Sub
Public Function Success() As Boolean
Success = done
End Function
Public Sub ClearFileSpecs()
FileName = ""
End Sub
Public Sub AddFileSpec(FileLocation As String)
FileName = FileLocation
End Sub
Sub NewZip(sPath)
'Create empty Zip File
If Len(Dir(sPath)) > 0 Then Kill sPath
Debug.Print "Creating zip file"
Open sPath For Output As #1
Debug.Print "Zip file created, writing zip header"
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Debug.Print "zip header written, closing file."
Close #1
Debug.Print "Closing zip file."
End Sub
Function Split97(sStr As Variant, sdelim As String) As Variant
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
Sub testZipping()
Dim i As Integer
For i = 1 To 10
zip i
Next i
MsgBox "Done"
End Sub
Sub tryWait()
Dim i As Integer
For i = 1 To 10
Sleep 2000
Next i
End Sub
顺便说一句，我们还尝试了另一种解决方案来调用 oApp.Namespace((zipfile)) 强制评估 zipfile 变量。许多论坛描述了另一个问题，即文字字符串与 oApp.Namespace("c:\an\example") 一起工作。在此类论坛中，建议使用 2 个圆括号的解决方案。
但是保持 "DIM zipfile As Variant" 和 "oApp.Namespace((zipfile))" 都不起作用。
会不会是客户端机器上的shell32.dll损坏了？请帮忙！如果能提供任何帮助，我将不胜感激！
我也在 http://forum.chandoo.org/threads/create-zip-error-namespace-method-fails-on-ishelldispatch.34010/
上发布了这个问题我们终于搞定了。当归结为 Namespace() 方法在 IShellDispatch 实例上失败时，必须修复 OS 安装，这解决了问题。此外，我们后来发现依赖基于 Windows Shell 的压缩不够可靠，因为 copyhere() 方法没有 return 任何完成状态。此外，它是异步的，它要求像在 copyhere() 调用之后放置一个循环这样的黑客攻击。这个循环会休眠几毫秒并比较源文件夹和目标文件夹的项目。此 hack 可能会导致实际的 copyhere 操作和比较查询发生冲突。我们终于开始实施基于 ZLib 的 DLL，它可以帮助我们满足压缩和解压缩要求。