List content of zip files

[swaggerbox]

How do I list the contents of a zip file in the activesheet (beginning in row7 column A) and not on the immediate window? How do I modify the code so that it loops through all the zip files in a folder?

I'm using Excel 2016.

Sub zpath()
Dim sh, n
Set sh = CreateObject("shell.application")
Set n = sh.Namespace("J:\Report\File1.zip")
recur sh, n
End Sub

Sub recur(sh, n)
Dim i, subn
For Each i In n.items
    If i.isfolder Then
        Set subn = sh.Namespace(i)
        recur sh, subn
        Else
        
        Debug.Print i.Path
        
    End If
Next
End Sub

[YasserKhalil]

Hello
Try this code

Public r As Long


Sub Test()
    Dim strPath As String
    Dim sh, n, x, i


    'Change Path To Suit
    strPath = ThisWorkbook.Path & "\"


    Set sh = CreateObject("Shell.Application")
    x = GetFiles(strPath, "*.zip", True)
    r = 7


    For Each i In x
        Set n = sh.Namespace(i)
        Recur sh, n
    Next i
End Sub


Sub Recur(sh, n)
    Dim i, subn, x As Long, p As Long


    For Each i In n.items
        If i.isfolder Then
            Set subn = sh.Namespace(i)
            Recur sh, subn
        Else
            p = LastPos(i.Path, "\")


            Cells(r, 1) = Mid(i.Path, p + 1)
            r = r + 1
        End If
    Next i
End Sub


Function GetFiles(StartPath As String, FileType As String, SubFolders As Boolean) As Variant
    StartPath = StartPath & IIf(Right(StartPath, 1) = "\", vbNullString, "\")
    GetFiles = Split(Join(Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & StartPath & FileType & """ " & IIf(SubFolders, "/S", vbNullString) & " /B /A:-D").StdOut.ReadAll, vbCrLf), ":"), "#"), "#")
End Function


Function LastPos(strVal As String, strChar As String) As Long
    LastPos = InStrRev(strVal, strChar)
End Function

[swaggerbox]

This is great Yasser! Is it possible to add the zip filename in column B?

[YasserKhalil]

You're welcome
Try this version

Public r As Long


Sub Test()
    Dim strPath As String
    Dim sh, n, x, i


    'Change Path To Suit
    strPath = ThisWorkbook.Path & "\"


    Set sh = CreateObject("Shell.Application")
    x = GetFiles(strPath, "*.zip", True)
    r = 7


    For Each i In x
        Set n = sh.Namespace(i)
        Recur sh, n
    Next i
End Sub


Sub Recur(sh, n)
    Dim i, subn, x As Long, p As Long, y As Long


    For Each i In n.items
        If i.isfolder Then
            Set subn = sh.Namespace(i)
            Recur sh, subn
        Else
            p = LastPos(i.Path, "\")
            Cells(r, 1) = Mid(i.Path, p + 1)
            
            y = LastPos(Replace(i.Path, "\" & Cells(r, 1), ""), "\")
            Cells(r, 2) = Mid(Replace(i.Path, "\" & Cells(r, 1), ""), y + 1)
            r = r + 1
        End If
    Next i
End Sub


Function GetFiles(StartPath As String, FileType As String, SubFolders As Boolean) As Variant
    StartPath = StartPath & IIf(Right(StartPath, 1) = "\", vbNullString, "\")
    GetFiles = Split(Join(Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & StartPath & FileType & """ " & IIf(SubFolders, "/S", vbNullString) & " /B /A:-D").StdOut.ReadAll, vbCrLf), ":"), "#"), "#")
End Function


Function LastPos(strVal As String, strChar As String) As Long
    LastPos = InStrRev(strVal, strChar)
End Function

[swaggerbox]

Thank you again for your help Yasser. Appreciate it.

[YasserKhalil]

You're welcome. Glad I can offer some help for you

[YasserKhalil]

It seems that there is an easier way to get the compressed file name. Here's the same previous version with some changes

Public r As Long


Sub Test()
    Dim strPath As String
    Dim sh, n, x, i


    'Change Path To Suit
    strPath = ThisWorkbook.Path & "\"


    Set sh = CreateObject("Shell.Application")
    x = GetFiles(strPath, "*.zip", True)
    r = 7


    For Each i In x
        Set n = sh.Namespace(i)
        Recur sh, n
    Next i
End Sub


Sub Recur(sh, n)
    Dim i, subn, x As Long, p As Long


    For Each i In n.items
        If i.isfolder Then
            Set subn = sh.Namespace(i)
            Recur sh, subn
        Else
            p = LastPos(i.Path, "\")
            Cells(r, 1) = Mid(i.Path, p + 1)
            
            Cells(r, 2) = n
            r = r + 1
        End If
    Next i
End Sub


Function GetFiles(StartPath As String, FileType As String, SubFolders As Boolean) As Variant
    StartPath = StartPath & IIf(Right(StartPath, 1) = "\", vbNullString, "\")
    GetFiles = Split(Join(Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & StartPath & FileType & """ " & IIf(SubFolders, "/S", vbNullString) & " /B /A:-D").StdOut.ReadAll, vbCrLf), ":"), "#"), "#")
End Function


Function LastPos(strVal As String, strChar As String) As Long
    LastPos = InStrRev(strVal, strChar)
End Function

[swaggerbox]

This is even better Yasser. Thanks a lot!

[YasserKhalil]

You're welcome.
Please mark the thread as solved
Regards