Advertisement
Guest User

Untitled

a guest
Sep 10th, 2018
106
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.  
  65.     On Error Resume Next
  66.     If Dir(DownloadFolder, vbDirectory) = vbNullString Then
  67.         MsgBox "The folder's path is incorrect!", vbCritical, "Folder's Path Error"
  68.         sh.Range("B4").Select
  69.         Exit Sub
  70.     End If
  71.     On Error GoTo 0
  72.                
  73.     'Check if there is at least one URL.
  74.    If LastRow < 8 Then
  75.         MsgBox "You did't enter a single URL!", vbCritical, "No URL Error"
  76.         sh.Range("C8").Select
  77.         Exit Sub
  78.     End If
  79.    
  80.     'Clear the results column.
  81.    sh.Range("E8:E" & LastRow).ClearContents
  82.    
  83.     'Add the backslash if doesn't exist.
  84.    If Right(DownloadFolder, 1) <> "\" Then
  85.         DownloadFolder = DownloadFolder & "\"
  86.     End If
  87.  
  88.     'Counting the number of files that will not be downloaded.
  89.    CountErrors = 0
  90.    
  91.     'Save the internet files at the specified folder of your hard disk.
  92.    On Error GoTo ErrorHandler
  93.     For i = 8 To LastRow
  94.    
  95.         'Use the given file name.
  96.        If Not sh.Cells(i, 4) = vbNullString Then
  97.            
  98.             'Get the given file name.
  99.            FilePath = sh.Cells(i, 4)
  100.            
  101.             'Check if the file path contains a special/illegal character.
  102.            For j = LBound(SpecialChar) To UBound(SpecialChar)
  103.                 SpecialCharFound = InStr(1, FilePath, SpecialChar(j), vbTextCompare)
  104.                 'If an illegal character is found substitute it with a "-" character.
  105.                If SpecialCharFound > 0 Then
  106.                     FilePath = WorksheetFunction.Substitute(FilePath, SpecialChar(j), "-")
  107.                 End If
  108.             Next j
  109.            
  110.             'Create the final file path.
  111.            FilePath = DownloadFolder & FilePath
  112.            
  113.             'Check if the file path exceeds the maximum allowable characters.
  114.            If Len(FilePath) > 255 Then
  115.                 sh.Cells(i, 5) = "ERROR: Filename too long"
  116.                 CountErrors = CountErrors + 1
  117.             End If
  118.                
  119.         Else
  120.             'Empty file name.
  121.            sh.Cells(i, 5) = "ERROR: Empty file name"
  122.             CountErrors = CountErrors + 1
  123.         End If
  124.        
  125.         'If the file path is valid, save the file into the selected folder.
  126.        If UCase(sh.Cells(i, 5)) <> "ERROR" Then
  127.        
  128.             'Try to download and save the file.
  129.            Result = URLDownloadToFile(0, Scrape(sh.Cells(i, 3)), FilePath, 0, 0)
  130.            
  131.             'Check if the file downloaded successfully and exists.
  132.            If Result = 0 And Not Dir(FilePath, vbDirectory) = vbNullString Then
  133.                 'Success!
  134.                sh.Cells(i, 5) = "OK"
  135.             Else
  136.                 'Error!
  137.                sh.Cells(i, 5) = "ERROR ON DOWNLOAD"
  138.                 CountErrors = CountErrors + 1
  139.             End If
  140.            
  141.         End If
  142.  
  143.  ErrorHandler:
  144.     If Err.Number <> 0 Then
  145.         Msg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
  146.         MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
  147.     End If
  148.     Resume Next
  149.        
  150.     Next i
  151.     On Error GoTo 0
  152.    
  153.     'Enable the screen.
  154.    Application.ScreenUpdating = True
  155.    
  156.     'Inform the user that macro finished successfully or with errors.
  157.    If CountErrors = 0 Then
  158.         'Success!
  159.        If LastRow - 7 = 1 Then
  160.             MsgBox "The file was successfully downloaded!", vbInformation, "Done"
  161.         Else
  162.             MsgBox LastRow - 7 & " files were successfully downloaded!", vbInformation, "Done"
  163.         End If
  164.     Else
  165.         'Error!
  166.        If CountErrors = 1 Then
  167.             MsgBox "There was an error with one of the files!", vbCritical, "Error"
  168.         Else
  169.             MsgBox "There was an error with " & CountErrors & " files!", vbCritical, "Error"
  170.         End If
  171.     End If
  172.    
  173. End Sub
  174.  
  175. Function Scrape(URL As String) As String
  176.   MsgBox "URL scraping started ", vbInformation, "Info"
  177.   Dim Browser As Object
  178.  
  179.   Set Browser = CreateObject("InternetExplorer.Application")
  180.   MsgBox "IE object set ", vbInformation, "Info"
  181.    
  182.   Browser.Visible = False
  183.   MsgBox "Options set; init navigation", vbInformation, "Info"
  184.   Browser.navigate URL
  185.   MsgBox "Navigation set, loading page", vbInformation, "Info"
  186.  
  187.   Do While Browser.Busy And Not Browser.readyState = READYSTATE_COMPLETE
  188.       DoEvents
  189.   Loop
  190.   MsgBox "Loading complete, init scrape ", vbInformation, "Info"
  191.   Dim receipt = getElement
  192.   Scrape = Browser.Document.getElementById("receipt").getElementByTagName("a").href
  193.   MsgBox "URL scraped: " & Scrape & " ", vbInformation, "Info"
  194. End Function
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement