Advertisement
Guest User

Untitled

a guest
Sep 10th, 2018
211
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Option Explicit
  2.  
  3. 'API function declaration for both 32 and 64bit Excel.
  4. #If VBA7 Then
  5.     Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
  6.                                     (ByVal pCaller As Long, _
  7.                                     ByVal szURL As String, _
  8.                                     ByVal szFileName As String, _
  9.                                     ByVal dwReserved As Long, _
  10.                                     ByVal lpfnCB As Long) As Long
  11. #Else
  12.     Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
  13.                             (ByVal pCaller As Long, _
  14.                             ByVal szURL As String, _
  15.                             ByVal szFileName As String, _
  16.                             ByVal dwReserved As Long, _
  17.                             ByVal lpfnCB As Long) As Long
  18. #End If
  19.  
  20. Sub DownloadFiles()
  21.                    
  22.     '--------------------------------------------------------------------------------------------------
  23.    'The macro loops through all the URLs (column C) and downloads the files at the specified folder.
  24.    'The given file names (column D) are used to create the full path of the files.
  25.    'If the file is downloaded successfully an OK will appear in column E (otherwise an ERROR value).
  26.    'The code is based on API function URLDownloadToFile, which actually does all the work.
  27.            
  28.     'Written By:    Christos Samaras
  29.    'Date:          28/05/2014
  30.    'Last Update:   06/06/2015
  31.    'E-mail:        xristos.samaras@gmail.com
  32.    'Site:          http://www.myengineeringworld.net
  33.    '--------------------------------------------------------------------------------------------------
  34.    
  35.     'Declaring the necessary variables.
  36.    Dim sh                  As Worksheet
  37.     Dim DownloadFolder      As String
  38.     Dim LastRow             As Long
  39.     Dim SpecialChar()       As String
  40.     Dim SpecialCharFound    As Double
  41.     Dim FilePath            As String
  42.     Dim i                   As Long
  43.     Dim j                   As Integer
  44.     Dim Result              As Long
  45.     Dim CountErrors         As Long
  46.    
  47.     'Disable screen flickering.
  48.    Application.ScreenUpdating = False
  49.    
  50.     'Set the worksheet object to the desired sheet.
  51.    Set sh = Sheets("Main")
  52.    
  53.     'An array with special characters that cannot be used for naming a file.
  54.    SpecialChar() = Split("\ / : * ? " & Chr$(34) & " < > |", " ")
  55.    
  56.     'Find the last row.
  57.     With sh
  58.         .Activate
  59.         LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
  60.     End With
  61.    
  62.     'Check if the download folder exists.
  63.    DownloadFolder = sh.Range("B4")
  64.     On Error Resume Next
  65.     If Dir(DownloadFolder, vbDirectory) = vbNullString Then
  66.         MsgBox "The folder's path is incorrect!", vbCritical, "Folder's Path Error"
  67.         sh.Range("B4").Select
  68.         Exit Sub
  69.     End If
  70.     On Error GoTo 0
  71.                
  72.     'Check if there is at least one URL.
  73.    If LastRow < 8 Then
  74.         MsgBox "You did't enter a single URL!", vbCritical, "No URL Error"
  75.         sh.Range("C8").Select
  76.         Exit Sub
  77.     End If
  78.    
  79.     'Clear the results column.
  80.    sh.Range("E8:E" & LastRow).ClearContents
  81.    
  82.     'Add the backslash if doesn't exist.
  83.    If Right(DownloadFolder, 1) <> "\" Then
  84.         DownloadFolder = DownloadFolder & "\"
  85.     End If
  86.  
  87.     'Counting the number of files that will not be downloaded.
  88.    CountErrors = 0
  89.    
  90.     'Save the internet files at the specified folder of your hard disk.
  91.    On Error Resume Next
  92.     For i = 8 To LastRow
  93.    
  94.         'Use the given file name.
  95.        If Not sh.Cells(i, 4) = vbNullString Then
  96.            
  97.             'Get the given file name.
  98.            FilePath = sh.Cells(i, 4)
  99.            
  100.             'Check if the file path contains a special/illegal character.
  101.            For j = LBound(SpecialChar) To UBound(SpecialChar)
  102.                 SpecialCharFound = InStr(1, FilePath, SpecialChar(j), vbTextCompare)
  103.                 'If an illegal character is found substitute it with a "-" character.
  104.                If SpecialCharFound > 0 Then
  105.                     FilePath = WorksheetFunction.Substitute(FilePath, SpecialChar(j), "-")
  106.                 End If
  107.             Next j
  108.            
  109.             'Create the final file path.
  110.            FilePath = DownloadFolder & FilePath
  111.            
  112.             'Check if the file path exceeds the maximum allowable characters.
  113.            If Len(FilePath) > 255 Then
  114.                 sh.Cells(i, 5) = "ERROR: Filename too long"
  115.                 CountErrors = CountErrors + 1
  116.             End If
  117.                
  118.         Else
  119.             'Empty file name.
  120.            sh.Cells(i, 5) = "ERROR: Empty file name"
  121.             CountErrors = CountErrors + 1
  122.         End If
  123.        
  124.         'If the file path is valid, save the file into the selected folder.
  125.        If UCase(sh.Cells(i, 5)) <> "ERROR" Then
  126.        
  127.             'Try to download and save the file.
  128.            Result = URLDownloadToFile(0, Scrape(sh.Cells(i, 3)), FilePath, 0, 0)
  129.            
  130.             'Check if the file downloaded successfully and exists.
  131.            If Result = 0 And Not Dir(FilePath, vbDirectory) = vbNullString Then
  132.                 'Success!
  133.                sh.Cells(i, 5) = "OK"
  134.             Else
  135.                 'Error!
  136.                sh.Cells(i, 5) = "ERROR ON DOWNLOAD"
  137.                 CountErrors = CountErrors + 1
  138.             End If
  139.            
  140.         End If
  141.        
  142.     Next i
  143.     On Error GoTo 0
  144.    
  145.     'Enable the screen.
  146.    Application.ScreenUpdating = True
  147.    
  148.     'Inform the user that macro finished successfully or with errors.
  149.    If CountErrors = 0 Then
  150.         'Success!
  151.        If LastRow - 7 = 1 Then
  152.             MsgBox "The file was successfully downloaded!", vbInformation, "Done"
  153.         Else
  154.             MsgBox LastRow - 7 & " files were successfully downloaded!", vbInformation, "Done"
  155.         End If
  156.     Else
  157.         'Error!
  158.        If CountErrors = 1 Then
  159.             MsgBox "There was an error with one of the files!", vbCritical, "Error"
  160.         Else
  161.             MsgBox "There was an error with " & CountErrors & " files!", vbCritical, "Error"
  162.         End If
  163.     End If
  164.    
  165. End Sub
  166.  
  167. Function Scrape(URL As String) As String
  168.   MsgBox "URL scraping started ", vbInformation, "Info"
  169.   Dim Browser As Object
  170.  
  171.   Set Browser = CreateObject("InternetExplorer.Application")
  172.   MsgBox "IE object set ", vbInformation, "Info"
  173.    
  174.   Browser.Visible = False
  175.   MsgBox "Options set; init navigation", vbInformation, "Info"
  176.   Browser.navigate URL
  177.   MsgBox "Navigation set, loading page", vbInformation, "Info"
  178.  
  179.   Do While Browser.Busy And Not Browser.readyState = READYSTATE_COMPLETE
  180.       DoEvents
  181.   Loop
  182.   MsgBox "Loading complete, init scrape ", vbInformation, "Info"
  183.   Scrape = Browser.Document.getElementById("receipt").getElementByTagName("a").href
  184.   MsgBox "URL scraped: " & Scrape & " ", vbInformation, "Info"
  185. End Function
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement