將模塊的輸出連接到另一個并回圈此邏輯以獲取值串列-有解無憂

我試圖在 vba 中連接 2 個模塊，以便第一個模塊 (geturl) 的輸出饋入另一個模塊 (getdata)。

獲取 Url 以在線查找 A 列中輸入的物質的檔案 URL，例如，Acetone或者可以使用 B 列中的 CAS 編號（見下圖）。注意：目前只在 A1 或 B1 中查找物質資訊。

Public Function GetUrl() As String
    
    Const Url = "https://echa.europa.eu/information-on-chemicals/registered-substances?p_p_id=dissregisteredsubstances_WAR_dissregsubsportlet&p_p_lifecycle=1&p_p_state=normal&p_p_mode=view&_dissregisteredsubstances_WAR_dissregsubsportlet_javax.portlet.action=dissRegisteredSubstancesAction"
    
    Set oHtml = New HTMLDocument
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    Set MyDict = CreateObject("Scripting.Dictionary")
    
    SubstanceName = Cells(1, 1)
    CASNumber = Cells(1, 2)
        
    MyDict("_dissregisteredsubstances_WAR_dissregsubsportlet_disreg_name") = SubstanceName
    MyDict("_dissregisteredsubstances_WAR_dissregsubsportlet_disreg_cas-number") = CASNumber
    MyDict("_disssimplesearchhomepage_WAR_disssearchportlet_disclaimer") = "true"
    MyDict("_disssimplesearchhomepage_WAR_disssearchportlet_disclaimerCheckbox") = "on"
    
    payload = vbNullString
        
    For Each DictKey In MyDict
        payload = IIf(Len(DictKey) = 0, WorksheetFunction.EncodeURL(DictKey) & "=" & WorksheetFunction.EncodeURL(MyDict(DictKey)), _
                      payload & "&" & WorksheetFunction.EncodeURL(DictKey) & "=" & WorksheetFunction.EncodeURL(MyDict(DictKey)))
    Next DictKey
        
    With oHttp
        .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)
        oHtml.body.innerHTML = .responseText
    End With
        
    
    GetUrl = oHtml.querySelector(".details").getAttribute("href")
    
    Debug.Print oHtml.querySelector(".substanceNameLink ").innerText
    Debug.Print oHtml.querySelector(".details").getAttribute("href")
  
End Function

如果運行這應該回傳 Acetone https://echa.europa.eu/registration-dossier/-/registered-dossier/15460

Get Data 使用來自 geturl 的 Url 來回傳“DNEL”值：

Sub GetData()
        
'Start ECHA Search via XML HTTP Request

Dim XMLReq As New MSXML2.XMLHTTP60
Dim HTMLDoc As New MSHTML.HTMLDocument


Dim Route(1 To 3) As String

Route(1) = "sGeneralPopulationHazardViaInhalationRoute"
Route(2) = "sGeneralPopulationHazardViaDermalRoute"
Route(3) = "sGeneralPopulationHazardViaOralRoute"


XMLReq.Open "Get", GetUrl & "/7/1", False
XMLReq.send
 
If XMLReq.Status <> 200 Then
        
    MsgBox "Problem" & vbNewLine & XMLReq.Status & " - " & XMLReq.statusText
    Exit Sub

    End If
 
HTMLDoc.body.innerHTML = XMLReq.responseText

'Loops through each element

For c = 1 To UBound(Route, 1)

Set Info = HTMLDoc.getElementById(Route(c))
Debug.Print Info.innerText

Set Info = HTMLDoc.getElementById(Route(c)).NextSibling.NextSibling.NextSibling
Set Data = Info.getElementsByTagName("dd")(0)
Debug.Print Data.innerText

Set Data = Info.getElementsByTagName("dd")(1)
Debug.Print Data.innerText

'Cells(r, c   2) = Data.innerText

Next c

End Sub

對于 Cell(1,1) 中的丙酮，這應該回傳：

Acetone 
https://echa.europa.eu/registration-dossier/-/registered-dossier/15460
General Population - Hazard via inhalation route
DNEL (Derived No Effect Level)
200 mg/m3
General Population - Hazard via dermal route
DNEL (Derived No Effect Level)
62 mg/kg bw/day
General Population - Hazard via oral route
DNEL (Derived No Effect Level)
62 mg/kg bw/day

然而，我不只是依賴單元格 A1，而是希望每個單元格的整個代碼回圈都包含在列 A/列 B 中的物質。因此，在這種情況下，找到了 Acetone 的 URL，然后提取了相應的資料，然后同樣發生在Oxydipropanol.

將模塊的輸出連接到另一個并回圈此邏輯以獲取值串列

Note in this image Substances can be looked up online using either the substance name, CAS number in columnB, or a combination of both.

Trying to connect the two modules, zo far I have only been able to get the geturl module to cycle through for each substance. I have also tried to combine both into 1 module but cant figure out how to correctly nest the for loops.

A quick google search states that you cant nest functions in vba. This makes me wonder if what I'm doing is even the right way to approach this. But I've seen similar things achieved In the past so I'm sure it's possible.

Note: If testing please use the example substances for testing. Using a random chemical say Benzene may result in an error as the tox profile for this substance doesn't exist. I still need to implement handling errors but this can be ignored for now.

我會在此處更新您取得的任何進一步進展，謝謝。

uj5u.com熱心網友回復：

這對我有用：

Sub PopulateExposures()
    Dim url, rw As Range
    
    Set rw = Sheets("data").Range("A1:E1") 'first row with inputs
    Do While Application.CountA(rw) > 0
        url = SubstanceUrl(rw.Cells(1).Value, rw.Cells(2).Value) 'get the URL
        rw.Cells(3).Resize(1, 3).Value = ExposureData(url) 'get exposure data (as array) and add to row
        Set rw = rw.Offset(1, 0) 'next substance
    Loop

End Sub

Public Function SubstanceUrl(SubstanceName, CASNumber) As String
    
    Const url = "https://echa.europa.eu/information-on-chemicals/registered-substances?" & _
                "p_p_id=dissregisteredsubstances_WAR_dissregsubsportlet&p_p_lifecycle=1&" & _
                "p_p_state=normal&p_p_mode=view&" & _
                "__dissregisteredsubstances_WAR_dissregsubsportlet_javax.portlet.action=dissRegisteredSubstancesAction"
    
    Dim oHTML, oHttp, MyDict, payload, DictKey, sep
    
    Set oHTML = New HTMLDocument
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    Set MyDict = CreateObject("Scripting.Dictionary")
    
    MyDict("_dissregisteredsubstances_WAR_dissregsubsportlet_disreg_name") = SubstanceName
    MyDict("_dissregisteredsubstances_WAR_dissregsubsportlet_disreg_cas-number") = CASNumber
    MyDict("_disssimplesearchhomepage_WAR_disssearchportlet_disclaimer") = "true"
    MyDict("_disssimplesearchhomepage_WAR_disssearchportlet_disclaimerCheckbox") = "on"
    
    payload = ""
    For Each DictKey In MyDict
        payload = payload & sep & DictKey & "=" & WorksheetFunction.EncodeURL(MyDict(DictKey))
        sep = "&"
    Next DictKey
        
    With oHttp
        .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
        oHTML.body.innerHTML = .responseText
    End With
    SubstanceUrl = oHTML.querySelector(".details").getAttribute("href")
End Function

Function ExposureData(urlToGet)
    
    Dim XMLReq As New MSXML2.XMLHTTP60
    Dim HTMLDoc As HTMLDocument
    Dim Route(1 To 3) As String, Results(1 To 3) As String, c, Info, Data
    
    Route(1) = "sGeneralPopulationHazardViaInhalationRoute"
    Route(2) = "sGeneralPopulationHazardViaDermalRoute"
    Route(3) = "sGeneralPopulationHazardViaOralRoute"
    
    XMLReq.Open "Get", urlToGet & "/7/1", False
    XMLReq.send
     
    If XMLReq.Status <> 200 Then
        Results(1) = "Problem" & vbNewLine & XMLReq.Status & " - " & XMLReq.statusText
    Else
        Set HTMLDoc = New HTMLDocument
        HTMLDoc.body.innerHTML = XMLReq.responseText
        For c = 1 To UBound(Route, 1)
            Set Info = HTMLDoc.getElementById(Route(c)).NextSibling.NextSibling.NextSibling
            Results(c) = Info.getElementsByTagName("dd")(1).innerText
        Next c
    End If
    ExposureData = Results
End Function

轉載請註明出處，本文鏈接：https://www.uj5u.com/qukuanlian/375349.html

標籤：擅长 vba 循环网页抓取

上一篇：如何在Golang中替換字串？

下一篇：用戶定義的帶有COUNTIFS的間接函式