PDA

View Full Version : Solved: Unzip Problem using Ron de Bruin's code



mugcy
06-08-2009, 06:58 PM
: pray2: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
06-09-2009, 06:50 AM
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
06-10-2009, 07:35 PM
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
06-11-2009, 05:40 AM
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
06-11-2009, 04:03 PM
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
06-16-2009, 06:49 AM
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
06-30-2009, 04:39 AM
thanks a lot dave

Daniel_D
10-10-2015, 12:23 PM
Been browsing for days for a solution to unzipping email attachments, Thank you Dave! :bow:

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.