CODEWITHSUNDEEP
vbaexcelzip
Ashok
Ashok

Reputation: 394

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

Upvotes: 1

Views: 2109

Answers (1)

Siddharth Rout
Siddharth Rout

Reputation: 149325

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

Upvotes: 1

Related Questions