Copying Specific File from Zip Files VBA

I am trying to copy specific file from zip files. The following code running succesfully but it not copy the file from zip to Folder.

Any suggestion would be appreciated..

 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:\Template\test\"



            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

1 answer

  • answered 2018-04-17 04:58 Siddharth Rout

    You are facing that problem because CStr(fileNameInZip) is giving you the file name without the extention.

    Replace CStr(fileNameInZip) by GetFilenameFromPath(fileNameInZip.Path)

    and add the below function

    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
    

    Now try it :)

    So your code looks like this

    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:\Template\test\"
    
                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