Downloading code bogging excel

sassriverrat

Well-known Member
Joined
Oct 4, 2018
Messages
655
I have some code that downloads pdf sheets at hte push of a button. The code works like a champ but (I presume because my internet connection is beyond super slow (satellite, 0.34mbps download....), excel goes into a "not responding" mode until the download completes. Is there any way to fix this? Code is attached

Code:
Sub Downloady()Dim URL As String
Dim name As String
Dim tstamp As String
Dim Folder0 As String
Dim Folder1 As String
Dim Folder2 As String
Dim folder3 As String
Dim namer As String
Dim Date0 As String
Dim Date1 As String
Dim Date2 As String
Dim Date3 As String
Dim Divider As String
Dim LocalFilePath As String
Dim OldFinalName As String
Dim TempFolderOLD As String
Dim TempFileNEW As String
Dim DownloadStatus As Long
Dim LastRow As Long
Dim Finalname As String
Dim btn As Shape
Dim MyFSO As Object
'Set MyFSO = New Scripting.FileSystemObject
Set MyFSO = CreateObject("Scripting.FileSystemObject")
Dim RW As Long


'Error Checking
'On Error GoTo Err
    
    
    ' find last row of data in column B on 'Background'
    LastRow = Sheets("Background").Range("B" & Rows.Count).End(xlUp).Row


    ' loop through rows on 'Background'
    
    RW = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row
            
        With Sheets("Background")
            namer = .Range("B" & RW)    'Pub name
            URL = .Range("I" & RW)      'URL to download
            Date0 = .Range("C" & RW)    'Week #
            Date1 = .Range("E" & RW)    'Year #
            Divider = .Range("D" & RW)  '\
            Date2 = .Range("G2")        'base week
            Date3 = .Range("I2")        'base year
        End With
        
        With Sheets("Setup")
            Folder0 = .Range("B5")    'temp folder (desktop)
            Folder1 = .Range("B7")    'permanent folder (desktop)
            Folder2 = .Range("D7")    'permanent folder
            folder3 = .Range("D5")    'temp Folder
            name = .Range("A1")       'company name
        End With
        
        TempFolderOLD = Environ("Userprofile") & "\" & Folder0 & "\" & folder3
        tstamp = Format(Now, "mm-dd-yyyy")
        TempFileNEW = TempFolderOLD & "\" & namer & ".pdf"
        LocalFilePath = Environ("Userprofile") & "\" & Folder1 & "\" & Folder2
        OldFinalName = LocalFilePath & Finalname
        Finalname = namer & ".pdf"
        
        
        'If these criteria are met, let's begin the download tree
        If Date0 <> Date2 Or Date1 <> Date3 Then
    
            'Let's assign everything to the temp folder
            'Begin by clearing any possible undeleted/corrupted files from my "temp" folder
            If MyFSO.FolderExists(TempFolderOLD) Then MyFSO.DeleteFolder (TempFolderOLD)
            'Make a new temp folder
            If Not MyFSO.FolderExists(TempFolderOLD) Then MkDir (TempFolderOLD)
            'Attempt download to the temp folder
            DownloadStatus = URLDownloadToFile(0, URL, TempFileNEW, 0, 0)
            'Check for proper download
            If DownloadStatus = 0 Then
                'Delete the old files
                If MyFSO.FileExists(OldFinalName) Then
                    MyFSO.DeleteFile (OldFinalName)
                    MyFSO.CreateFolder (LocalFilePath)
                End If
                'Save temp files to replace old files
                'TempFileNEW.SaveAs Filename:=LocalFilePath, FileFormat:=xlTypePDF
                If MyFSO.FileExists(OldFinalName) Then MyFSO.DeleteFile (OldFinalName)
                MyFSO.CopyFile Source:=TempFileNEW, Destination:=LocalFilePath & "\"
                'Now delete temp files
                If MyFSO.FolderExists(TempFolderOLD) Then MyFSO.DeleteFolder (TempFolderOLD)
                'Now update excel sheet to show download passed
                MsgBox "File Downloaded. Check in this path: " & LocalFilePath
                
                With Sheets("Background")
                    .Range("F" & RW) = tstamp
                    .Range("G" & RW) = "SAT"
                    .Range("C" & RW) = Format(Now, "ww", vbWednesday)
                    .Range("E" & RW) = Format(Now, "yy")
                    .Range("D" & RW) = "/"
                    'date formating
                    .Range("C" & RW).HorizontalAlignment = xlRight
                    .Range("D" & RW).HorizontalAlignment = xlGeneral
                    .Range("E" & RW).HorizontalAlignment = xlLeft
                End With
                
                'If download failed, update excel to show- old files should NOT have been deleted yet but the temp file should be deleted
            Else:
                MsgBox "Download File Process Failed"
                Sheets("Background").Range("G" & RW) = "FAIL"
                If MyFSO.FileExists(TempFolderOLD) Then
                MyFSO.DeleteFile (TempFolderOLD)
                End If
            End If
            'If the original criteria were met and the download was not necessary, say so
        Else


            MsgBox "The most up to date " & namer & " has been downloaded", vbOKOnly, name
        End If
        
        
'Error checking
'Exit Sub
'Err: MsgBox (RW)


End Sub
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop

Forum statistics

Threads
1,213,521
Messages
6,114,104
Members
448,548
Latest member
harryls

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top