将引用的 URL 连接到 XML HTTP 请求中

Question

下面的sn-p代码向下面的站点发送一个XML请求

Sub GetContents()
   
            Dim XMLReq As New MSXML2.XMLHTTP60
            
            XMLReq.Open "Get", "https://echa.europa.eu/brief-profile/-/briefprofile/100.028.723", False
            XMLReq.send

End Sub

我有另一个子例程 GetURL() 在这种情况下打印出所需的 URL：https://echa.europa.eu/brief-profile/-/briefprofile/100.028.723

我怎样才能本质上将 GetURL() 的输出连接到 BstrUrl 中？即

XMLReq.Open "Get", "x", False 其中 x 是 GetURL() 的输出

尽管进行了各种尝试，但仍不接受该语法作为 URL。

Answer 1

假设您是从之前的问题中组合的，那么您需要确保编写一个返回 url 的函数（正如 Tim Williams 所指出的那样）。我将对此进行扩展，因为我认为您需要考虑添加一个测试以确保请求成功，有结果，并将searchKeyWord 作为参数传递，以使您的函数更可重用。同样，您可以将 xmlhttp 对象传递给函数，以避免不断创建和销毁它们。

避免自动实例化，因为您可能会得到意想不到的结果和匈牙利风格的表示法。就个人而言，我也避免使用这些类型的字符，因为它们更难阅读。

vbNullString 将提供比= "" 更快的分配。

我还会使用更短、更快、更可靠的 css 模式来检索 url，基于类和两个元素的父子关系。

---

Public Sub GetContents()
    Dim searchKeyWord As String, xmlReq As MSXML2.XMLHTTP60, html As MSHTML.HTMLDocument, url As String
    
    searchKeyWord = "Acetone"
    Set xmlReq = New MSXML2.XMLHTTP60
    
    url = GetUrl(searchKeyWord, xmlReq)
    
    Set html = New MSHTML.HTMLDocument
    
    If url <> "N/A" Then
    
        With xmlReq
            .Open "GET", url, False
            .send
            If .Status = 200 Then
                html.body.innerHTML = .responseText
                Debug.Print html.querySelector("title").innerText
            End If
        End With
       
    End If
    
End Sub


Public Function GetUrl(ByVal searchKeyWord As String, ByVal http As MSXML2.XMLHTTP60) As String
 
    Const url = "https://echa.europa.eu/search-for-chemicals?p_auth=5ayUnMyz&p_p_id=disssimplesearch_WAR_disssearchportlet&p_p_lifecycle=1&p_p_state=normal&p_p_col_id=_118_INSTANCE_UFgbrDo05Elj__column-1&p_p_col_count=1&_disssimplesearch_WAR_disssearchportlet_javax.portlet.action=doSearchAction&_disssimplesearch_WAR_disssearchportlet_backURL=https%3A%2F%2Fecha.europa.eu%2Finformation-on-chemicals%3Fp_p_id%3Ddisssimplesearchhomepage_WAR_disssearchportlet%26p_p_lifecycle%3D0%26p_p_state%3Dnormal%26p_p_mode%3Dview%26p_p_col_id%3D_118_INSTANCE_UFgbrDo05Elj__column-1%26p_p_col_count%3D1%26_disssimplesearchhomepage_WAR_disssearchportlet_sessionCriteriaId%3D"
    Dim html As MSHTML.HTMLDocument, dict As Object, i As Long, r As Long
    Dim dictKey As Variant, payload$, ws As Worksheet
    
    Set html = New MSHTML.HTMLDocument
    Set dict = CreateObject("Scripting.Dictionary")
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    dict("_disssimplesearchhomepage_WAR_disssearchportlet_formDate") = "1621017052777" 'timestamp
    dict("_disssimplesearch_WAR_disssearchportlet_searchOccurred") = "true"
    dict("_disssimplesearch_WAR_disssearchportlet_sskeywordKey") = searchKeyWord
    dict("_disssimplesearchhomepage_WAR_disssearchportlet_disclaimer") = "true"
    dict("_disssimplesearchhomepage_WAR_disssearchportlet_disclaimerCheckbox") = "on"

    payload = vbNullString
    
    For Each dictKey In dict
        payload = IIf(Len(dictKey) = 0, WorksheetFunction.EncodeURL(dictKey) & "=" & WorksheetFunction.EncodeURL(dict(dictKey)), _
                      payload & "&" & WorksheetFunction.EncodeURL(dictKey) & "=" & WorksheetFunction.EncodeURL(dict(dictKey)))
    Next dictKey
    
    With http
        .Open "POST", url, False
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/84.0.4147.135 Safari/537.36"
        .setRequestHeader "Content-type", "application/x-www-form-urlencoded"
        .send (payload)
        If .Status = 200 Then
            html.body.innerHTML = .responseText
        Else
            GetUrl = "N/A"
            Exit Function
        End If
    End With
    
    Dim result As Boolean
    
    result = html.querySelectorAll(".lfr-search-container  .substanceNameLink").Length > 0
    
    GetUrl = IIf(result, html.querySelector(".lfr-search-container  .substanceNameLink").href, "N/A")
End Function

Answer 2

如果GetURL 是一个返回字符串的函数，那么这应该可以工作：

Sub GetContents()
   
    Dim XMLReq As New MSXML2.XMLHTTP60
    Dim url

    url = GetURL()

    XMLReq.Open "Get", url, False
    XMLReq.send

End Sub