VBA Unzip multiple zipped files

[EMcK01]

Hi,

I am trying to update a script that I found in another post that unzips multiple folders in a loop. Unzip files using excel macro.

The script is this:

Sub UnZipMe()

Dim str_FILENAME As String, str_DIRECTORY As String, str_DESTINATION As String

'Your directory where zip file is kept
str_DIRECTORY = "C:\Test\"

'Loop through all zip files in a given directory
str_FILENAME = Dir(str_DIRECTORY & "*.zip")

Do While Len(str_FILENAME) > 0
    Call Unzip1(str_DIRECTORY & str_FILENAME)
    Debug.Print str_FILENAME
    str_FILENAME = Dir
Loop

End Sub

Sub Unzip1(str_FILENAME As String)
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Dim strDate As String

    'Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=False)
    Fname = str_FILENAME
                                        
                                        
    If Fname = False Then
        'Do nothing
    Else
        'Root folder for the new folder.
        'You can also use
        DefPath = "C:\Test\EXTRACT\"
'        DefPath = Application.DefaultFilePath
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

        'Create the folder name
        strDate = Format(Now, " dd-mm-yy h-mm-ss")
        FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"

        'Make the normal folder in DefPath
        MkDir FileNameFolder

        'Extract the files into the newly created folder
        Set oApp = CreateObject("Shell.Application")

        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).Items

        'If you want to extract only one file you can use this:
        'oApp.Namespace(FileNameFolder).CopyHere _
         'oApp.Namespace(Fname).items.Item("test.txt")

        'MsgBox "You find the files here: " & FileNameFolder
        Debug.Print "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

All is fine with the above code, however when I try and alter it to keep the original folder name as part of the code, it only unzips a single file.

I've only changed the following and can't see why this is causing an issue

'Create the folder name
'        strDate = Format(Now, " dd-mm-yy h-mm-ss")
'        FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
        
        FN = Dir(str_FILENAME)
        FILE = Left(FN, Len(FN) - 4)
        
        FileNameFolder = DefPath & FILE & "\"

Can someone point out where I am going wrong

PS, I'm aware there will be a much more efficient way of getting the only the file name but this appeared to work for me just now.

Thanks

 

[yky]

Did you step through the original code? I think Dir only gives you one file name. It is the following loop that gets all the file names.

 

[EMcK01]

Hi, thanks for your reply.

Yes I had walked through it so wasn't seeing why it was an issue. Removing

FN = Dir(str_FILENAME)

from the code continues the loop so I'll re-look at how I'm generating the original file name.

Thanks

 

[yky]

What is the complete Sub UnZipMe()? Would you post it?

 

[EMcK01]

Both Sub UnZipMe and Sub Unzip1 were posted above, but are noted within the one VBA code.