Consulting

Results 1 to 8 of 8

Thread: Solved: Unzip Problem using Ron de Bruin's code

  1. #1
    VBAX Regular
    Joined
    Mar 2009
    Posts
    37
    Location

    Solved: Unzip Problem using Ron de Bruin's code

    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 ????
    [vba] 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
    [/vba]

  2. #2
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    Maybe a loop and a case statement for each file. Something like this (untested). HTH. Dave
    [vba]
    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

    [/vba]

  3. #3
    VBAX Regular
    Joined
    Mar 2009
    Posts
    37
    Location
    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.

    [VBA]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
    [/VBA]


    It's this bit where i have prob with

    [VBA] Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
    MultiSelect:=True)[/VBA]



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

  4. #4
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    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

  5. #5
    VBAX Regular
    Joined
    Mar 2009
    Posts
    37
    Location
    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.

  6. #6
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    This seems to work. HTH. Dave
    [VBA]
    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
    [/VBA]

  7. #7
    VBAX Regular
    Joined
    Mar 2009
    Posts
    37
    Location
    thanks a lot dave

  8. #8
    VBAX Newbie
    Joined
    Oct 2015
    Posts
    2
    Location
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •