Use Excel VBA to unzip files - excel

Question

I found this code on another stack overflow post and it works well but the code prompts the user to select the file, can it be changed so that it automatically unzips all the files in the chosen directory?
Unzip folder with files to the chosen location
Sub Unzip()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Destination folder
DefPath = "C:\test\" ' Change to your path / variable
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameFolder = DefPath
' 'Delete all the files in the folder DefPath first if you want
' On Error Resume Next
' Kill DefPath & "*.*"
' On Error GoTo 0
'Extract the files into the Destination folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
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
Now with an added loop as brax is great to point out that I can use this but still doesn't solve the issue of the user being prompted for which file to open
Sub Unzip5()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim StrFile As String
StrFile = Dir("Z:\G Thang\Excel & VBA\Extract\*.zip")
Do While Len(StrFile) > 0
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Destination folder
DefPath = "Z:\G Thang\Excel & VBA\Extract\" ' Change to your path / variable
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameFolder = DefPath
' 'Delete all the files in the folder DefPath first if you want
' On Error Resume Next
' Kill DefPath & "*.*"
' On Error GoTo 0
'Extract the files into the Destination folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
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
Loop
End Sub
ok, I'm getting it! But my new code loops through the same file and keeps unzipping that one, maybe I can move it into another directory when I've finished unzipping it and then move onto the next one, i'll post the code below.
Sub Unzip99File()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim StrFile As String
StrFile = Dir("Z:\G Thang\Excel & VBA\Extract\*.zip")
'Fname = ("*.zip")
Do While Len(StrFile) > 0
Fname = ("*.zip")
If Fname = False Then 'Fname
'Do nothing
Else
'Destination folder
DefPath = "Z:\G Thang\Excel & VBA\Extract\" ' Change to your path / variable
' If Right(DefPath, 1) <> "\" Then
' DefPath = DefPath & "\"
' End If
FileNameFolder = DefPath
' 'Delete all the files in the folder DefPath first if you want
' On Error Resume Next
' Kill DefPath & "*.*"
' On Error GoTo 0
'Extract the files into the Destination folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(DefPath & StrFile).items
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
Loop
End Sub