Unzip - multiple zips

[JohnUK]

Hi,
I have this brilliant piece of code that I picked up from Ron de Bruin web
site, that unzips a file and saves as unzipped.
Sub Unzip()
Dim oApp As Object
Dim fname
Dim FileNameFolder
Dim DefPath As String
fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip),
*.zip", _
MultiSelect:=True)
' I changed the MultiSelect:=False to True hoping it would work
If fname = False Then
Else
sPath = Application.DefaultFilePath & "\Schedules\Unzipped"
DefPath = sPath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameFolder = DefPath
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(fname).items
MsgBox "Files can be found here: " & FileNameFolder
Set oApp = Nothing
End If
End Sub
(Slightly changed for my setup) The problem I have is, it only unzips one
file at a time. Is there some way that the code can do a loop of sorts so
that it would pick up all the zipped files within a folder in one go and
unzip?
Again - help much appreciated
Regards
John

 

[Ron de Bruin]

Hi John

Do you want all zip files you select unzipped in the same folder ?

 

[JohnUK]

Wow - that was quick. Thanks for your help Ron.
That would be ideal
John

 

[Ron de Bruin]

Ok test this one for me John

Sub Unzip1_test()
Dim oApp As Object
Dim fname
Dim FileNameFolder
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
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"

'Create normal folder
MkDir FileNameFolder

Set oApp = CreateObject("Shell.Application")

For I = LBound(fname) To UBound(fname)
num = oApp.NameSpace(FileNameFolder).items.Count

'Copy the files in the newly created folder
oApp.NameSpace(FileNameFolder).CopyHere oApp.NameSpace(fname(I)).items

On Error Resume Next
Do Until oApp.NameSpace(FileNameFolder).items.Count = num + oApp.NameSpace(fname(I)).items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0

Next I

MsgBox "You find the files here: " & FileNameFolder
Set oApp = Nothing
End If
End Sub

 

[JohnUK]

Hi Ron,
It does one file and then gets stuck in the loop. The files are:

Generic Schedule Region 61 -306
Generic Schedule Region 62 -306
Generic Schedule Region 63 -306

and so on, if that helps

John

 

[Ron de Bruin]

Hi John

Is it possible that you send me 3 or three zip files private
Easier to test then for me

 

[Ron de Bruin]

2 or 3 <g>

 

[JohnUK]

On its way

John

Hi John

Is it possible that you send me 3 or three zip files private
Easier to test then for me

 

[Ron de Bruin]

Nothing in my mailbox ?

 

[Ron de Bruin]

My test is OK when I duplicate your zip files a few times and select
the zip files with my macro.

Maybe others can test the code also with a few zip files

 

[JohnUK]

Hi Ron,
It worked perfectly.

I am so stupid - I changed the names of the zipped files and not the files
themselves hence the code only opened one file.
Many thanks for your help Ron
All the best
John

 

[Ron de Bruin]

No Problem John

I add the example to my site
http://www.rondebruin.nl/windowsxpzip.htm

Maybe useful for others

Good night