使用VBA遍历压缩文件

Question

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

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

建设关：https://www.rondebruin.nl/win/s7/win002.htm

编辑： - 这表明你可以如何将提取到您的代码。只需将完整的zip路径和位置传递到要提取文件的位置即可。你可以在你现有的循环中做到这一点。

您可能需要考虑媒体文件共享相同的名称，如果你对他们都提取到同一位置规划...

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