VBA code to download zip and extract csv file from it and save with specified name

[playtime007]

I am having a simple application in excel to download all zip urls in column "C" column "C" has urls and column "Q" has names Every url has 1 zip file and every zip has 1 csv in it. What I want to do is to 1. unzip the CSV files and save them with names as mentioned in column "Q" 2. Kill all the zip 3. CSV file must be overwritten as I will be doing this task on daily basis so when the next day or next time I perform the task it must overwrite the previous file

Sub Download_All()
Dim lr As Long
Dim fileurl As String, filename As String
Dim r As Long
lr = Sheets("Downloads").Range("C" & Rows.Count).End(xlUp).Row
For r = 5 To lr
    fileurl = Sheets("Downloads").Range("C" & r).Value


    If InStr(1, fileurl, ".zip") <> 0 Then
        filepath = "C:\MyDownloads\"

    End If
            Dim Obj1 As Object
    Set Obj1 = CreateObject("Microsoft.XMLHTTP")
    Obj1.Open "GET", fileurl, False
    Obj1.send
    If Obj1.Status = 200 Then
        Set Obj2 = CreateObject("ADODB.Stream")
        Obj2.Open
        Obj2.Type = 1
        Obj2.Write Obj1.responseBody
        Obj2.SaveToFile (filepath & getfilename(fileurl)), 2 ' 1 = no overwrite, 2 = overwrite

        Obj2.Close
    End If
    Next r
End Sub

Function getfilename(filepath As String)
    Dim v_string() As String
    v_string = Split(filepath, "/")
    getfilename = v_string(UBound(v_string))
End Function

 

[Yongle]

UNTESTED
I think this should work

I have assumed that the files are unzipped to the same folder
If they are to be unzipped to different folder then replace filepath with the correct folder path and end the path with "\"

Insert
Call UnzipFileRename(filepath & GetFileName(fileurl), filepath, Sheets("Downloads").Range("Q" & r).Value & ".csv")
Below
Obj2.SaveToFile (filepath & getfilename(fileurl)), 2 ' 1 = no overwrite, 2 = overwrite


Place code in same module as Download_All

Private Sub UnzipFileRename(zipFullName As Variant, unzipPath As Variant, newName As String)
    Dim ShellApp As Object, oldFullName As String, newfullname As String, n As Variant
    Set ShellApp = CreateObject("Shell.Application")
'get file name
    For Each n In ShellApp.Namespace(zipFullName).Items
        a = a + 1
        oldFullName = unzipPath & n.Name
        newfullname = unzipPath & newName
        If a = 1 Then Exit For
    Next n
'delete previous version to avoid any issues
    DeleteFile oldFullName
    DeleteFile newfullname
'unzip the file
    ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items
'rename the file
    Name oldFullName As newfullname
'delete zip file
    DeleteFile CStr(zipFullName)
End Sub

Private Sub DeleteFile(PathAndName As String)
    On Error Resume Next
    Kill PathAndName
    On Error GoTo 0
End Sub

 

[playtime007]

THANKS MATE YOU SAVED MY LIFE.

Can u pls add the codes to send message Box with File Name = Download status Like below
suppose there are 3 file to be download and 1 failed it should look like

File Name = Downloaded
File Name = Downloaded
File Name =Download Failed

 

[Yongle]

EDIT - IGNORE THIS POST- I will post simpler code in a few minutes


1. assumed that
- the code fails at ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items - is this correct ?
- and that fileurl is the required name in message box - is this correct ?

2. Procedure DeleteFile - does not change

3. In Download_All

- Amend this line to include msg
Dim fileurl As String, filename As String , msg As String

- Delete the line I gave you last time and replace with ...
msg = msg & vbCr & UnzipFileRename(fileurl, filepath & GetFileName(fileurl), filepath, Sheets("Downloads").Range("Q" & r).Value & ".csv")

- Insert this line above End Sub
MsgBox msg, vbOKOnly, "Results"

4. Delete sub UnzipFileRename - it is now a function returning required string for each file
- replace with this

Private Function UnzipFileRename(FileName As String, zipFullName As Variant, unzipPath As Variant, newName As String) As String
    Dim ShellApp As Object, oldfullName As String, newfullName As String, n As Variant, a As Integer, d As String
    Set ShellApp = CreateObject("Shell.Application")
'get file name
    For Each n In ShellApp.Namespace(zipFullName).Items
        a = a + 1
        oldfullName = unzipPath & n.Name
        newfullName = unzipPath & newName
        If a = 1 Then Exit For
    Next n
'delete previous version to avoid any issues
    DeleteFile oldfullName
    DeleteFile newfullName
'unzip the file
    On Error Resume Next
    ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items
    If Err.Number = 0 Then d = " downloaded" Else d = " download failed"
    On Error GoTo 0
'rename the file
    Name oldfullName As newfullName
'delete zip file
    DeleteFile CStr(zipFullName)
    UnzipFileRename = FileName & d
End Function

 

[Yongle]

It was pointless passing the name variable simply to pass it back again, hence amended code

1. assumed that
- the code fails at ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items - is this correct ?
- and that fileurl is the required name in message box - is this correct ?

2. Procedure DeleteFile - does not change

3. In Download_All

- Amend this line to include msg
Dim fileurl As String, filename As String , msg As String

- Delete the line I gave you last time and replace with ...
msg = msg & vbCr & fileurl & UnzipFileRename(filepath & GetFileName(fileurl), filepath, Sheets("Downloads").Range("Q" & r).Value & ".csv")

- Insert this line above End Sub
MsgBox msg, vbOKOnly, "Results"

4. Delete sub UnzipFileRename - it is now a function returning required string for each file
- replace with this

Private Function UnzipFileRename(zipFullName As Variant, unzipPath As Variant, newName As String) As String
    Dim ShellApp As Object, oldfullName As String, newfullName As String, n As Variant, a As Integer, d As String
    Set ShellApp = CreateObject("Shell.Application")
'get file name
    For Each n In ShellApp.Namespace(zipFullName).Items
        a = a + 1
        oldfullName = unzipPath & n.Name
        newfullName = unzipPath & newName
        If a = 1 Then Exit For
    Next n
'delete previous version to avoid any issues
    DeleteFile oldfullName
    DeleteFile newfullName
'unzip the file
    On Error Resume Next
    ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items
    If Err.Number = 0 Then d = " downloaded" Else d = " download failed"
    On Error GoTo 0
'rename the file
    Name oldfullName As newfullName
'delete zip file
    DeleteFile CStr(zipFullName)
    UnzipFileRename = d
End Function

 

[playtime007]

Hi Mate,

I tried, the message is returning only for successful downloads.
The message contains only File_Name_1 = Downloaded, File_Name_2 = Downloaded But, there is no information about 3rd file for download Failed

 

[Yongle]

UNTESTED

After this line
ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items

Add this line
Debug.Print Err.Number , CStr(zipFullName)

Debug.Print writes to Immediate Window
{CTRL} g displays Immediate Window (when in VBA editor)

Run again
Look at Immediate Window
Is every filename written to Immediate Window ?
Which error is VBA returning when a file fails to download ?

If every line begins with a zero, then VBA is not returning an error and we must find a differerent method to return download success
- this should be possible by comparing the list in column Q with the names of csv files in folder (some will be missing)

 

[Yongle]

Does the code stop running when a file fails to download or does the code keep running ?
If the code stops running - where does it stop - which line is highlighted ?

 

[playtime007]

Hi,
Modified as you said.
Nothing Changed

Immediate window also has only Successful downloaded information of 2files.

The codes stop nowhere, I put the wrong url on No.1 to check whether it stops at start but, it skipped the wrong url and downloaded next 2 with status message "Downloaded" as before

<< unavailable video removed >>

 

[Yongle]

If you delete these lines does the code still loop through EVERY file ?
On Error Resume Next
ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items
If Err.Number = 0 Then d = " downloaded" Else d = " download failed"
On Error GoTo 0