Хранить ссылки в памяти компьютера вместо таблицы Excel

Question

Я пытаюсь создать веб-сканер или веб-сканер для загрузки файлов PDF с веб-сайта. Я хотел бы загрузить все файлы PDF на C:\temp\. У меня есть ссылки на подстраницы на листе Excel A1:A17 в настоящее время.

Они перенаправлены на лист Excel с этим кодом:

Sub GetAllLinks()

Dim internet As InternetExplorer
Dim internetdata As HTMLDocument
Dim internetlink As Object
Dim internetinnerlink As Object

Set internet = CreateObject("InternetExplorer.Application")

internet.Visible = False

internet.navigate ("https://www.nordicwater.com/products/waste-water/")

    Do While internet.Busy
      DoEvents
    Loop
    Do Until internet.readyState = READYSTATE_COMPLETE

    DoEvents

    Loop

        Set internetdata = internet.document

        Set internetlink = internetdata.getElementsByTagName("a")

        i = 1

        For Each internetinnerlink In internetlink


            If Left$(internetinnerlink, 36) = "https://www.nordicwater.com/product/" Then

            ActiveSheet.Cells(i, 1) = internetinnerlink.href

            i = i + 1

            Else
            End If


Next internetinnerlink

End Sub 

Код для загрузки файла:

Sub DownloadFiles()

    Dim xHttp: Set xHttp = CreateObject("Microsoft.XMLHTTP")
    Dim bStrm
    Dim hDoc As MSHTML.HTMLDocument
    Dim hAnchor As MSHTML.HTMLAnchorElement
    Dim sPath As String
    Dim i As Long
    Dim wholeURL
    Dim link
    Dim range

    range = ThisWorkbook.Worksheets("Sheet1").range("A1:A17")

    wholeURL = "URL URL URL"

    sPath = "C:\temp\"

    For Each link In range

    'Get the directory listing
    xHttp.Open "GET", link
    xHttp.send

    'Wait for the page to load
    Do Until xHttp.readyState = 4
        DoEvents
    Loop

    'Put the page in an HTML document
    Set hDoc = New MSHTML.HTMLDocument
    hDoc.body.innerHTML = xHttp.responseText

    'Loop through the hyperlinks on the directory listing
    For i = 0 To hDoc.getElementsByTagName("a").Length - 1
        Set hAnchor = hDoc.getElementsByTagName("a").Item(i)

        'test the pathname to see if it matches your pattern
        If hAnchor.pathname Like "*.pdf" Then

                Debug.Print wholeURL & hAnchor.pathname

                xHttp.Open "GET", wholeURL & hAnchor.pathname, False
                xHttp.send

                Set bStrm = CreateObject("Adodb.Stream")

                With bStrm
                    .Type = 1 '//binary
                    .Open
                    .write xHttp.responseBody
                    .SaveToFile sPath & getName(wholeURL & hAnchor.pathname), 2 '//overwrite
                End With

                Set bStrm = Nothing

        End If

    Next i

    Next

End Sub

Функция для получения имени файла из URL:

Function getName(pf)
getName = Split(pf, "/")(UBound(Split(pf, "/")))
End Function

wholeURL = "URL URL URL":

A1: A17:

и т. Д.

Как соединить эти коды вместе, чтобы не было необходимости использовать Excel Worksheetв качестве базы данных ссылок и хранить ссылки в памяти компьютера вместо?

---

РЕДАКТИРОВАТЬ:

Sub DownloadFiles()
    Dim xHttp       As Object: Set xHttp = CreateObject("Microsoft.XMLHTTP")
    Dim hDoc        As MSHTML.HTMLDocument
    Dim Anchors     As Object
    Dim Anchor      As Variant
    Dim sPath       As String
    Dim wholeURL    As String

    Dim internet As InternetExplorer
    Dim internetdata As HTMLDocument
    Dim internetlink As Object
    Dim internetinnerlink As Object
    Dim arrLinks As Variant
    Dim sLink As String
    Dim iLinkCount As Integer
    Dim iCounter As Integer
    Dim sLinks As String

    Set internet = CreateObject("InternetExplorer.Application")
    internet.Visible = False
    internet.navigate ("https://www.nordicwater.com/products/waste-water/")

        Do While internet.Busy
          DoEvents
        Loop
        Do Until internet.readyState = READYSTATE_COMPLETE
            DoEvents
        Loop

        Set internetdata = internet.document
        Set internetlink = internetdata.getElementsByTagName("a")

        i = 1

        For Each internetinnerlink In internetlink
            If Left$(internetinnerlink, 36) = "https://www.nordicwater.com/product/" Then

                sLinks = sLinks & internetinnerlink.href & vbCrLf
                i = i + 1

            Else
            End If

    ThisWorkbook.Worksheets("Sheet1").range("B1").Value = sLinks

    Next internetinnerlink

    wholeURL = "https://www.nordicwater.com/"
    sPath = "C:\temp\"

    arrLinks = Split(p_sLinks, vbCrLf)
    iLinkCount = UBound(arrLinks) + 1

    For iCounter = 1 To iLinkCount
    sLink = arrLinks(iCounter - 1)
        'Get the directory listing
        xHttp.Open "GET", sLink
        xHttp.send

        'Wait for the page to load
        Do Until xHttp.readyState = 4
            DoEvents
        Loop

        'Put the page in an HTML document
        Set hDoc = New MSHTML.HTMLDocument
        hDoc.body.innerHTML = xHttp.responseText

        'Loop through the hyperlinks on the directory listing
        Set Anchors = hDoc.getElementsByTagName("a")

        For Each Anchor In Anchors

            'test the pathname to see if it matches your pattern
            If Anchor.pathname Like "*.pdf" Then

                xHttp.Open "GET", wholeURL & Anchor.pathname, False
                xHttp.send

                With CreateObject("Adodb.Stream")
                    .Type = 1
                    .Open
                    .write xHttp.responseBody
                    .SaveToFile sPath & getName(wholeURL & Anchor.pathname), 2 '//overwrite
                End With

            End If

        Next

    Next

End Sub
Function getName(pf As String) As String
    getName = Split(pf, "/")(UBound(Split(pf, "/")))
End Function

Answer 1

Вы можете сохранить все ссылки в строке, разделив каждую из них на vbCrLf, а затем использовать Split(yourstring, vbCrLf), чтобы получить массив ссылок. Таким образом, вам не нужно запускать это в Excel или, по крайней мере, вам не нужно использовать ячейки Excel.

Для этого создайте строковую переменную, например, sLinks. Затем в первом цикле замените

ActiveSheet.Cells(i, 1) = internetinnerlink.href

на

sLinks = sLinks & internetinnerlink.href & vbCrLf

Как только это будет сделано, вы устранили хранениессылки в Excel. Затем вы можете передать эту строку в качестве параметра в ваш DownloadFiles sub:

Sub DownloadFiles(p_sLinks)
    Dim arrLinks As Variant
    Dim sLink As String
    Dim iLinkCount As Integer
    Dim iCounter As Integer

    arrLinks = Split(p_sLinks, vbCrLf)
    iLinkCount = UBound(arrLinks) + 1

    For iCounter = 1 to iLinkCount
        sLink = arrLinks(iCounter - 1)
        ' Process sLink here
    Next

End Sub

Вы можете объединить этот код с вашим существующим подпрограммой DownloadFiles, заменив цикл For Each link In range на For iCounter = 1 to iLinkCount, поместивкод из вашего цикла внутри этого нового цикла и использование sLink в качестве ссылки на процесс вместо чтения его из Excel.

Вы можете разбить часть своего кода на подпрограммы, чтобы упростить чтение и устранение неполадок:

Sub DownloadFile(p_sURL, p_sLocalPath)
    Dim xHttp As Object: Set xHttp = CreateObject("Microsoft.XMLHTTP")

    xHttp.Open "GET", p_sURL, False
    xHttp.send

    With CreateObject("Adodb.Stream")
        .Type = 1
        .Open
        .write xHttp.responseBody
        .SaveToFile p_sLocalPath & getName(p_sURL), 2 ' //overwrite
    End With

End Sub

Answer 2

В коде было несколько ошибок, которые я исправил ниже. Вам необходимо создать новый объект ADODB.Stream или убедиться, что вы закрыли предыдущий объект. Кроме того, вы должны строго вводить переменные везде, где это возможно. Я убрал это в нескольких местах.

Function getName(pf As String) As String
    getName = Split(pf, "/")(UBound(Split(pf, "/")))
End Function


Sub DownloadFiles()
    Dim xHttp       As Object: Set xHttp = CreateObject("Microsoft.XMLHTTP")
    Dim hDoc        As MSHTML.HTMLDocument
    Dim Anchors     As Object
    Dim Anchor      As Variant
    Dim sPath       As String
    Dim wholeURL    As String
    Dim link        As range
    Dim range       As range

    Set range = ThisWorkbook.Worksheets("Sheet1").range("A1:A5")
    wholeURL = "https://www.nordicwater.com/"
    sPath = "C:\temp\"

    For Each link In range
        'Get the directory listing
        xHttp.Open "GET", link
        xHttp.send

        'Wait for the page to load
        Do Until xHttp.readyState = 4
            DoEvents
        Loop

        'Put the page in an HTML document
        Set hDoc = New MSHTML.HTMLDocument
        hDoc.body.innerHTML = xHttp.responseText

        'Loop through the hyperlinks on the directory listing
        Set Anchors = hDoc.getElementsByTagName("a")

        For Each Anchor In Anchors

            'test the pathname to see if it matches your pattern
            If Anchor.pathname Like "*.pdf" Then

                xHttp.Open "GET", wholeURL & Anchor.pathname, False
                xHttp.send

                With CreateObject("Adodb.Stream")
                    .Type = 1
                    .Open
                    .Write xHttp.responseBody
                    .SaveToFile sPath & getName(wholeURL & Anchor.pathname), 2 '//overwrite
                End With

            End If

        Next

    Next

End Sub