使用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