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