Блог

Я пытаюсь подключить 2 модуля в vba таким образом, чтобы вывод первого модуля (geturl) передавался в другой (getdata).

Получить Url-адрес для поиска URL-адреса досье в Интернете для веществ, введенных в колонку A, например Acetone , или в качестве альтернативы можно использовать номер CAS в колонке B (см. Изображение ниже). Примечание: в настоящее время только ищет информацию о веществе в A1 или B1.

 Public Function GetUrl() As String    Const Url = "https://echa.europa.eu/information-on-chemicals/registered-substances?p_p_id=dissregisteredsubstances_WAR_dissregsubsportletamp;p_p_lifecycle=1amp;p_p_state=normalamp;p_p_mode=viewamp;_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) amp; "=" amp; WorksheetFunction.EncodeURL(MyDict(DictKey)), _  payload amp; "amp;" amp; WorksheetFunction.EncodeURL(DictKey) amp; "=" amp; 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 использует Url-адрес из geturl для возврата значений «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 amp; "/7/1", False XMLReq.send   If XMLReq.Status lt;gt; 200 Then    MsgBox "Problem" amp; vbNewLine amp; XMLReq.Status amp; " - " amp; 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  

For Acetone in Cell(1,1) This should Return:

 Acetone  https://echa.europa.eu/registration-dossier/-/registered-dossier/15460 General Population - Hazard via inhalation route DNEL (Derived No Effect Level) 200 mg/m³ 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, я хочу иметь полный цикл кода для каждой ячейки с веществом в столбце/столбце B. Таким образом, в этом случае URL-адрес для ацетона найден, и затем извлекаются соответствующие данные, после чего происходит то же Oxydipropanol самое .

Примечание.На этом изображении вещества можно искать в Интернете, используя либо название вещества, номер CAS в столбце B, либо комбинацию того и другого.

Пытаясь соединить два модуля, я пока смог заставить модуль geturl работать только для каждого вещества. Я также попытался объединить оба в 1 модуль, но не могу понять, как правильно вложить циклы for.

Быстрый поиск в Google показывает, что вы не можете вложить функции в vba. Это заставляет меня задуматься, является ли то, что я делаю, правильным подходом к этому. Но я видел, как подобные вещи достигались в прошлом, так что я уверен, что это возможно.

Примечание: При тестировании, пожалуйста, используйте для тестирования примеры веществ. Использование случайного химического вещества, например бензола, может привести к ошибке, поскольку токсикологического профиля для этого вещества не существует. Мне все еще нужно реализовать обработку ошибок, но пока это можно игнорировать.

Я буду информировать вас здесь о любом дальнейшем прогрессе, достигнутом, спасибо.

Это сработало для меня:

 Sub PopulateExposures()  Dim url, rw As Range    Set rw = Sheets("data").Range("A1:E1") 'first row with inputs  Do While Application.CountA(rw) gt; 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?" amp; _  "p_p_id=dissregisteredsubstances_WAR_dissregsubsportletamp;p_p_lifecycle=1amp;" amp; _  "p_p_state=normalamp;p_p_mode=viewamp;" amp; _  "__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 amp; sep amp; DictKey amp; "=" amp; WorksheetFunction.EncodeURL(MyDict(DictKey))  sep = "amp;"  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, dds  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 amp; "/7/1", False  XMLReq.send    If XMLReq.Status lt;gt; 200 Then  Results(1) = "Problem" amp; vbNewLine amp; XMLReq.Status amp; " - " amp; 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))  If Not Info Is Nothing Then  Set Info = Info.NextSibling.NextSibling.NextSibling  Set dds = Info.getElementsByTagName("dd")  If dds.Length gt; 1 Then  Results(c) = dds(1).innerText  Else  Results(c) = "hazard unknown"  End If  Else  Results(c) = "no info"  End If  Next c  End If  ExposureData = Results End Function