从 zip 文件 VBA 复制特定文件

Question

我正在尝试从zip文件中复制特定文件。以下代码成功运行，但它不会将文件从 zip 复制到文件夹。

任何建议将不胜感激。

 Sub Unzip5()
        Dim FSO As Object
        Dim oApp As Object
        Dim Fname As Variant
        Dim FileNameFolder As Variant
        Dim DefPath As String
        Dim strDate As String
        Dim I As Long
        Dim num As Long
        Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                            MultiSelect:=True)
        If IsArray(Fname) = False Then
            'Do nothing
        Else
            FileNameFolder = "D:Templatetest"

            Set oApp = CreateObject("Shell.Application")
          For I = LBound(Fname) To UBound(Fname)
                num = oApp.Namespace(FileNameFolder).Items.Count
                        For Each fileNameInZip In oApp.Namespace(Fname(I)).Items
                                    If fileNameInZip Like "repo*" Then
                                        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname(I)).Items.Item(CStr(fileNameInZip)) 
'this above line working fine but not copying file from zip
                                        Exit For
                                    End If
                                Next
                'oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname(I)).Items
            Next I
            MsgBox "You find the files here: " & FileNameFolder
            On Error Resume Next
            Set FSO = CreateObject("scripting.filesystemobject")
            FSO.deletefolder Environ("Temp") & "Temporary Directory*", True
        End If
    End Sub

Answer 1

您面临这个问题，因为CStr(fileNameInZip)为您提供了没有扩展名的文件名。

将CStr(fileNameInZip)替换为GetFilenameFromPath(fileNameInZip.Path)

并添加以下函数

Private Function GetFilenameFromPath(ByVal strPath As String) As String
    If Right$(strPath, 1) <> "" And Len(strPath) > 0 Then
        GetFilenameFromPath = _
        GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End If
End Function

现在试试:)

所以你的代码看起来像这样

Sub Unzip5()
        Dim FSO As Object, oApp As Object
        Dim Fname As Variant, FileNameFolder As Variant
        Dim DefPath As String, strDate As String
        Dim I As Long, num As Long
        Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                            MultiSelect:=True)
        If IsArray(Fname) = True Then
            FileNameFolder = "D:Templatetest"
            Set oApp = CreateObject("Shell.Application")
            For I = LBound(Fname) To UBound(Fname)
                num = oApp.Namespace(FileNameFolder).Items.Count
                For Each fileNameInZip In oApp.Namespace(Fname(I)).Items
                    If fileNameInZip Like "repo*" Then
                        oApp.Namespace(FileNameFolder).CopyHere _
                        oApp.Namespace(Fname(I)).Items.Item(GetFilenameFromPath(fileNameInZip.Path))
                        Exit For
                    End If
                Next
            Next I
            MsgBox "You find the files here: " & FileNameFolder
            On Error Resume Next
            Set FSO = CreateObject("scripting.filesystemobject")
            FSO.deletefolder Environ("Temp") & "Temporary Directory*", True
            On Error GoTo 0
        End If
    End Sub
    Private Function GetFilenameFromPath(ByVal strPath As String) As String
        If Right$(strPath, 1) <> "" And Len(strPath) > 0 Then
            GetFilenameFromPath = _
            GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
        End If
    End Function