Unzip Problem using Ron de Bruin's code

[mugcy]

I'm thinking about using the following Ron de Bruin's code to unzip a specific file. But in my case I need to extract several zip files in the defined folder to respective folders without prompting to select them. Can someone help me with this please ????

         Sub Unzip2()
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Dim strDate As String
    Dim fileNameInZip As Variant
    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
    MultiSelect:=False)
    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")
        ' Change this "*.txt" to extract the files you want
        For Each fileNameInZip In oApp.Namespace(Fname).items
            If LCase(fileNameInZip) Like LCase("*.txt") Then
                oApp.Namespace(FileNameFolder).CopyHere _
                oApp.Namespace(Fname).items.Item(CStr(fileNameInZip))
            End If
        Next
        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

[Dave]

Maybe a loop and a case statement for each file. Something like this (untested). HTH. Dave

 
Sub Unzippy()
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim Cnt As Integer
    For Cnt = 1 To 5 'adjust to suit
        Select Case Cnt
            Case 1: Fname = "C:\file1.zip": _
                FileNameFolder = "C:\folder1\'adjust to suit"
            Case 2: Fname = "C:\file2.zip": _
                FileNameFolder = "C:\folder2\'adjust to suit"
            'etc.
        End Select
        MkDir FileNameFolder
        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
        Set FSO = Nothing
        Set oApp = Nothing
    Next Cnt
End Sub

[mugcy]

THank you Verymuch for that Dave. Couldn't get to an internet connection to check anything. I've been tinkering with the code and I almost have the final result except for the part where I need to select the files when the Open files dialog comes up.

Sub Unzip4()
    Dim fso As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath, Filespec As String
    Dim strDate As String
    Dim fnm As String
    Dim I As Long
    Dim num As Long
    Dim Zipfilename As String
    Dim DFTFile As Variant
    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
    MultiSelect:=True)
    If IsArray(Fname) = False Then
        ' Do nothing
    Else
        ' create default folder
        DefPath = "C:\Documents and Settings\abc\Desktop\UpZipfiles\"
        Filespec = "C:\Documents and Settings\abc\Desktop\UpZipfiles\*"
        ' Delete all folders in defpath
        DeleteAFolder (Filespec)
        For I = LBound(Fname) To UBound(Fname)
            ' Gets the Folder Name for the new Folder
            fnm = Filename(Fname(I))
            FileNameFolder = DefPath & fnm
            ' Make the normal folder in DefPath
            MkDir FileNameFolder
            ' Gets the fiename(DFT File) that need to be extracted depending on the folder
            DFTFile = DFTfilename(fnm)
            ' Extract the files into the newly created folder
            Set oApp = CreateObject("Shell.Application")
            For Each oAppfile In oApp.Namespace(Fname(I)).items
                Zipfilename = Mainfilename(oAppfile)
                If Zipfilename Like DFTFile Then
                    oApp.Namespace(FileNameFolder).CopyHere (oAppfile)
                End If
            Next
        Next I
        On Error Resume Next
        Set fso = CreateObject("scripting.filesystemobject")
        fso.DeleteFolder Environ("Temp") & "\Temporary Directory*", True
    End If
End Sub

It's this bit where i have prob with

    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=True)

Is there any way to direct the VB code to access all the zip files in the folder?

[Dave]

Not sure that I understand your needs. My current read is that you want to be able to select a folder and then unzip all of the files within the folder to the same folder? There is no prob with the above line of code... it works as it should. Perhaps, something like: For each file in the Folder selected, If Right(filename,3)="zip" then unzip. Here's some more zip stuff. Dave
http://www.vbaexpress.com/forum/showthread.php?t=17357

[mugcy]

Thanks a lot Dave. I'll checkout the link. I don't want to select the folder manually. I want it to be hardcoded so the program can unzip the file without manually selecting the files.

[Dave]

This seems to work. HTH. Dave

 
Sub FolderFiles()
    ' unzip all zipped files in folder
    Dim FolderPath As String, AllZip As String
    FolderPath = "D:\testfolder" 'folder containing zip files
    AllZip = Dir(FolderPath & "\*.zip")
    Do While AllZip <> ""
        Call Unzip(FolderPath & "\", FolderPath & "\" & AllZip)
        AllZip = Dir
    Loop
End Sub
 
Public Function Unzip(DefPath, Fname)
    ' Many thanks to Ron de Bruin for his great code
    ' Unzips A File
    ' Fname must be FULL Path\Filename.zip
    ' DefPath must be valid Path you want to Unzip file TO
    ' You just need to pass 2 strings.
    ' C:\FullPath\Filename.zip - the file to UNZIP
    ' C:\FullPath\ - folder to unzip to
    Dim FSO As Object
    Dim oApp As Object
    Set oApp = CreateObject("Shell.Application")
    oApp.Namespace(DefPath).CopyHere oApp.Namespace(Fname).items
    On Error Resume Next
    Set FSO = CreateObject("scripting.filesystemobject")
    FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    Set FSO = Nothing
    Set oApp = Nothing
End Function

[mugcy]

thanks a lot dave

[Daniel_D]

Been browsing for days for a solution to unzipping email attachments, Thank you Dave!

Also if someone does not need the original zip files in the folder just add the code:

kill fname

...after the "On error resume next" in Dave's email. It will delete each zip file in the folder.