如何使用 VBA 从没有 ID 的 htmldiv 元素中提取字符串

Question

我是 VBA 新手，正在尝试自动化以下操作：

1. 打开网页
2. 在我的excel表格中输入一个字符串到搜索窗口，点击搜索
3. 点击唯一结果
4. 找到并提取与我找到的人相关联的电子邮件地址并复制到 Excel 表中

我已经找到了这个人，但无法获取电子邮件，因为它存储在我无法正确寻址的 htmldiv 元素中。由于没有 ID，我试图以某种方式定位电子邮件地址的存储位置（见附图）。我尝试了不同的方法，但我无法从 Email_search 对象中获取值。其他变量保持为空。将数据存储到 Excel 工作表中可与网页中的其他数据一起使用。

对不起，如果这是微不足道的，但我被困住了，希望你的帮助。出于测试目的，您可以将“input_element.Value”的值替换为“Dipl.-Ing.Univ. Ali Riza Acer”。这是我的代码：

Sub Test1()

    Dim IE As Object
    'Dim doc As HTMLDocument
    Set IE = CreateObject("InternetExplorer.Application")

    IE.Visible = True
    IE.navigate "https://www.bayika.de/de/ingenieursuche/"
    
    Do While IE.Busy
        Application.Wait DateAdd("s", 1, Now)
    Loop
            
    Set doc = IE.document
    
    'Get string from excel and put into search window
       
    Set the_input_elements = IE.document.getElementsByName("suchwort")
        For Each input_element In the_input_elements
        If input_element.getAttribute("name") = "suchwort" Then
        input_element.Value = ThisWorkbook.Sheets("Sortiert").Range("B2").Value
    Exit For
    End If
    Next input_element
    
    
    'Press search button
    
    Set the_input_elements2 = IE.document.getElementsByTagName("button")
    For Each input_element2 In the_input_elements2
        input_element2.Click
    Exit For
    'End If
    Next input_element2
    
    'Wait until webpage has loaded
    
    Do While IE.Busy
        Application.Wait DateAdd("s", 1, Now)
    Loop
    
    'Click the only list entry
    
    Set the_input_elements3 = IE.document.getElementsByClassName("listEntry listEntryClickable listEntryClickableJS")
    For Each input_element3 In the_input_elements3
        input_element3.Click
    Exit For
    Next input_element3

'%%%%%%%%%%%%%% From here the code does not work %%%%%%%%%%%%
    
            'Find email and save - Variant 1: Look for a and target line, doesn't work because it cannot get the value out
                                            
            'Set the_input_elements5 = IE.document.getElementsByTagName("a")(57)
                                                
                                                               
            'ThisWorkbook.Sheets("Sortiert").Range("F2").Value = the_input_elements5
                                                                                  
                                                
     Count = 0

    Set Email_search = IE.document.getElementsByClassName("elementStandard elementContent elementContainerStandard elementContainerStandard_var1 elementContainerStandardColumns elementContainerStandardColumns2 elementContainerStandardColumns_var5050 wglAdjustHeightMax")
                  
        For Each Email_element In Email_search
                  
            Email = Email_search.getElementsByClassName("col col1")
            
            Var = 1
            Count = Count + Var
        
            If InStr(1, Email, "mailto") > 0 Then
                ThisWorkbook.Sheets("Sortiert").Range("F2").Value = Email
                Exit For
            End If
        Next Email_element

End Sub

这是我要提取的网站部分：

来自网页的代码部分

非常感谢！

Answer 1

好的，下面应该可以了。我使用 xmlhttp 请求（最快的方法）而不是 IE。

Sub GetInformation()
    Const baseUrl = "https://www.bayika.de"
    Const URL = "https://www.bayika.de/de/ingenieursuche/suchergebnis.php?"
    
    Dim oHttp As Object, Html As HTMLDocument, sParams As String
    Dim MyDict As Object, DictKey As Variant, oElem As Object
    Dim InnerPageUrl As String, nameToSearch As String
    
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    Set Html = New HTMLDocument
    Set MyDict = CreateObject("Scripting.Dictionary")
    
    nameToSearch = "Dipl.-Ing.Univ. Ali Riza Acer"  'This is the variable holding your search term

    MyDict("suchwort") = nameToSearch
    MyDict("plz_bis") = ""
    MyDict("plz_von") = ""
    
    For Each DictKey In MyDict
        sParams = IIf(Len(DictKey) = 0, WorksheetFunction.encodeURL(DictKey) & "=" & WorksheetFunction.encodeURL(MyDict(DictKey)), _
                        sParams & "&" & WorksheetFunction.encodeURL(DictKey) & "=" & WorksheetFunction.encodeURL(MyDict(DictKey)))
    Next DictKey


    With oHttp
        .Open "GET", URL & sParams, False
        .send
        Html.body.innerHTML = .responseText
    End With
    
    Set oElem = Html.querySelector("#list_ingenieursuche li.listEntry")
    If Not oElem Is Nothing Then
        InnerPageUrl = baseUrl & Split(Split(oElem.getAttribute("onclick"), "href='")(1), "'")(0)

        With oHttp
            .Open "GET", InnerPageUrl, False
            .send
            Html.body.innerHTML = .responseText
        End With
        
        MsgBox Html.querySelector("#blockContentInner a[href*='mailto:']").innerText
    End If
End Sub

参考添加：

Microsoft HTML Object Library

注意：如果由于某种原因WorksheetFunction.encodeURL() 在您端抛出任何错误，可能是由于 excel 版本的变化。顺便说一句，我正在使用 excel 2013。