Question

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

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

^该代码成功遍历文件夹并收集zip文件的名称。但我需要进入文件并遍历结构以进入Media文件夹。

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

使用VBA遍历zip文件

1 个答案: