Unzip the zip folders and rename the .gif files

[ygsunilkumar]

Hi,

I have zip files located in c:\temp\ as shown below

a.zip
b.zip
c.zip

In each zip file two files will be present that is .html and .gif file and named as

a.html and sgplot.gif
b.html and sgplot.gif
c.html and sgplot.gif

Now my requirement is to unzip all the zip file to folder as
a
b
c
and rename the sgplot.gif file to a.gif, b.gif and c.gif. Basically it has to rename as .html file name to .gif.

Please help me in achieving through excel macro

Thanks in Advance

[ygsunilkumar]

Hi,

Anyone please help me?

Thanks in Advance.

[mancubus]

hi.
try this.


Sub Unzip_n_RenGif()
'http://www.vbaexpress.com/forum/showthread.php?t=41265
'adopted: http://www.rondebruin.nl/windowsxpunzip.htm

Dim fso As Object, oApp As Object
Dim fName As Variant, FileNameFolder As Variant, fileNameInZip As Variant
Dim fPath As String, OldName As String, NewName As String
Dim i As Long

fPath = "C:\MyDocs\" 'change to suit
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
FileNameFolder = fPath & "UnzipFolder" & "\" 'change to suit
MkDir FileNameFolder

Set oApp = CreateObject("Shell.Application")

fName = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=True)
If IsArray(fName) = False Then Exit Sub

For i = LBound(fName) To UBound(fName)
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(fName(i)).items
For Each fileNameInZip In oApp.Namespace(fName(i)).items
If LCase(fileNameInZip) Like LCase("*.html") Then
OldName = FileNameFolder & "sgplot.gif"
NewName = FileNameFolder & Replace(fileNameInZip, "html", "gif")
Name OldName As NewName
End If
Next
Next

On Error Resume Next
Set fso = CreateObject("scripting.filesystemobject")
fso.DeleteFolder Environ("Temp") & "\Temporary Directory*", True

End Sub

[ygsunilkumar]

Thank you very much for the code mancubus.

In the below code, it will prompt for each zip file but my requirement is suppose in "C:\mydocs\" folder if there n number of zip files then it has to unzip and rename the .gif files all the zip files.

Can you please help me?

Thanks in Advance.

[mancubus]

you're wellcome.

no. the user is asked once to select all or desired zip files in a folder.

[mancubus]

ok.
you dont have to select files with below procedure...


Sub Unzip_n_RenGif()
'http://www.vbaexpress.com/forum/showthread.php?t=41265
'adopted: http://www.rondebruin.nl/windowsxpunzip.htm
'UDF: http://spreadsheetpage.com/index.php/tip/getting_a_list_of_file_names_using_vba/

Dim fso As Object, oApp As Object
Dim fName As Variant, FileNameFolder As Variant, fileNameInZip As Variant
Dim fPath As String, OldName As String, NewName As String
Dim i As Long

fPath = "C:\MyDocs\" 'change to suit
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
FileNameFolder = fPath & "UnzipFolder" & "\" 'change to suit
MkDir FileNameFolder

Set oApp = CreateObject("Shell.Application")

fPath = fPath & "*.zip"
fName = GetFileList(fPath)
If IsArray(fName) = False Then Exit Sub

For i = LBound(fName) To UBound(fName)
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(fName(i)).items
For Each fileNameInZip In oApp.Namespace(fName(i)).items
If LCase(fileNameInZip) Like LCase("*.html") Then
OldName = FileNameFolder & "sgplot.gif"
NewName = FileNameFolder & Replace(fileNameInZip, "html", "gif")
Name OldName As NewName
End If
Next
Next

On Error Resume Next
Set fso = CreateObject("scripting.filesystemobject")
fso.DeleteFolder Environ("Temp") & "\Temporary Directory*", True

End Sub


Function GetFileList(FileSpec As String) As Variant
'http://spreadsheetpage.com/index.php/tip/getting_a_list_of_file_names_using_vba/
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False

Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String

On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound

' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop

GetFileList = FileArray

Exit Function

' Error handler
NoFilesFound:
GetFileList = False

End Function

[ygsunilkumar]

Thanks for the code. I am getting below error when it reaches the line
"oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(fName(i)).items".

Please help me?

Run-time error '91':
Object variable or With block variable not set

[mancubus]

i can guess: copyhere requires zip files be opened first. (GetOpenFileName method)

and the UDF makes an array of file names in the folder.

so try first procedure.

if someone else provides a workaround, that will be good.

[ygsunilkumar]

Hi,

Anyone please help me, it's very urgent.

Thanks in Advance.