使用VBA遍历zip文件

我需要使用VBA遍历一个zip文件。 特别是我需要，而不解压缩文件，findxl文件夹，以便find媒体子文件夹。 然后，我需要将图像从媒体子文件夹中复制出来并保存到另一个文件夹中。

Public Sub Extract_Images() Dim fso As FileSystemObject Dim objFile As File Dim myFolder Const zipDir As String = "\\...\ZIP FILES" Const xlFolder As String = "xl" Const mediaFolder As String = "media" Dim picname As String Dim zipname As String Set fso = New FileSystemObject Set myFolder = fso.GetFolder(zipDir) For Each objFile In myFolder.Files zipname = objFile.Name Next objFile End Sub 

^该代码成功地循环通过该文件夹并收集压缩文件的名称。 但是我需要进入文件并遍历结构才能进入媒体文件夹。

Answer 1

大厦closures： https ： //www.rondebruin.nl/win/s7/win002.htm

编辑： – 这显示了如何将提取纳入你的代码。 只需将完整的zippath和位置传递到要提取文件的位置即可。 你可以在你现有的循环内做到这一点。

如果您计划将它们全部提取到相同的位置，则可能需要考虑共享相同名称的媒体文件。

 Sub Tester() ExtractMediaFiles "C:\Users\twilliams\Desktop\tempo.zip", _ "C:\Users\twilliams\Desktop\extracted\" End Sub Sub ExtractMediaFiles(zipFile As Variant, outFolder As Variant) Dim oApp As Object Dim fileNameInZip As Variant, oNS As Object Set oApp = CreateObject("Shell.Application") On Error Resume Next Set oNS = oApp.Namespace(zipFile & "\xl\media") On Error GoTo 0 If Not oNS Is Nothing Then For Each fileNameInZip In oNS.items Debug.Print fileNameInZip oApp.Namespace(outFolder).copyhere oNS.items.Item(CStr(fileNameInZip)) Next Else Debug.Print "No xl\media path for " & zipFile End If End Sub