Unzip all files present in a directory.

[abhay_547]

Hi All,

I have the below macro which loops through all files in a directory and then unzips the zip files. I have another macro to download some file from different urls actually a userform which has listbox with all links listed in it and the names of the files to be named post download from those links. I want to identify the zip files and post download unzip and rename them as per the name reflecting in the lisbox and save in the same directory. Actually all those files contain the excel files which I want to rename as per the names reflecting in listbox.

Sub RUNZIPPER()

'Run before you leave and keep excel running in the background
Application.OnTime TimeValue("19:00:00"), "UnZipMe"


End Sub

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:\Users\Graeme\Documents\Alex 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:\Users\Ron\test\"
        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

I have attached my macro file for you reference.

Thanks a lot for your help in advance.