Отправка HTTP-запроса с использованием библиотеки MS XML, 6.0 с динамическим/частично известным URL-циклом

• Порядковый номер в URL-адресе не всегда состоит из 5 цифр. например.

https://www.statmuse.com/nba/player/lebron-james-1780

• Для каждого запроса POST время ответа удаленного сервера для кодов состояния 200 (ОК) или 502 (Плохой шлюз) различается. В моем тестировании это обычно занимает от полсекунды до одной секунды. Проверка 90 000 URL-адресов с помощью этого метода нецелесообразна.

• Действительно, попытка проверки большого количества URL-адресов может создать значительную нагрузку на серверы веб-сайта. Фактически, это можно интерпретировать как форму незначительной DDoS-атаки (распределенный отказ в обслуживании).

• Приведенный ниже код имитирует search на https://www.statmuse.com/ с использованием Internet Explorer, который, хотя и немного устарел, но все же выполняет свою работу. Selenium WebDriver может быть лучшей альтернативой.

Sub Demo()
    Debug.Print GetURL("martin perez")
    Debug.Print GetURL("lebron james")
End Sub
Function GetURL(ByVal sFullName As String) As String
    Dim IE As Object
    Dim doc As Object
    ' Initialize Internet Explorer
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = False
    ' Navigate to the webpage
    IE.Navigate "https://www.statmuse.com/ask?q = " & Replace(sFullName, " ", "-")
    ' Wait for IE to finish loading the page
    Do While IE.Busy Or IE.readyState <> 4
        DoEvents
    Loop
    ' Get the document object
    Set doc = IE.Document
    ' Get the HTML content of the webpage
    'Dim htmlContent As String:  htmlContent = doc.DocumentElement.outerHTML
    Dim oLink As Object
    Set oLink = doc.getElementsByTagName("link")(0)
    ' Extract the href attribute value from the link tag
    If Not oLink Is Nothing Then
        GetURL = oLink.getAttribute("href")
    Else
        GetURL = ""
    End If
    ' Close IE
    IE.Quit
    Set IE = Nothing
End Function

Вывод в немедленном окне:

https://www.statmuse.com/mlb/player/mart%C3%ADn-p%C3%A9rez-46483
https://www.statmuse.com/nba/player/lebron-james-1780

Просто получите URL-адрес напрямую с помощью:

Function GetPlayerLogURLs(ByRef playerName As Variant) As Collection
    Dim httpRequest As MSXML2.XMLHTTP60: Set httpRequest = New MSXML2.XMLHTTP60
    Const baseURL As String = "https://www.statmuse.com"
    '
    httpRequest.Open "POST", baseURL & "/ask", False
    httpRequest.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    httpRequest.send "question%5Bquery%5D = " _
                   & LCase$(Replace(playerName, " ", "+")) _
                   & "&question%5Bpreferred_domain%5D=&question%5Bconversation_token%5D = "
    '
    Dim response As String: response = httpRequest.responseText
    Dim i As Long
    Dim j As Long
    Dim res As New Collection
    Dim temp As String
    '
    i = InStr(1, response, "/game-log""")
    If i = 0 Then
        i = InStr(1, response, """/mlb/player/")
        On Error Resume Next
        Do While i > 0
            j = InStr(i + 1, response, """")
            If j > 0 Then
                temp = baseURL & Mid$(response, i + 1, j - i - 1) & "/game-log"
                res.Add temp, temp
            End If
            i = InStr(j + 1, response, """/mlb/player/")
        Loop
        On Error GoTo 0
    Else
        j = InStrRev(response, """", i)
        If j > 0 Then res.Add baseURL & Mid$(response, j + 1, i - j + 8)
    End If
    Set GetPlayerLogURLs = res
End Function

а затем просто используйте его вот так:

Sub TestPlayerURLs()
    Dim v As Variant
    Dim w As Variant
    Dim coll As Collection
    '
    For Each v In Array("Martin Perez", "Derrick White", "Logan Allen", "This name doesn't exist")
        Debug.Print "Player name: " & v
        Set coll = GetPlayerLogURLs(v)
        Debug.Print "Results found: " & coll.Count
        For Each w In coll
            Debug.Print w
        Next w
        Debug.Print
    Next v
End Sub