Excel VBA使用MSXML爬取网站遇脚本隐藏邮箱的解决求助

你当前使用的MSXML请求仅能获取静态HTML源码，无法执行页面内嵌的JavaScript代码，而站点的邮箱是通过emrp()JS函数动态解密后插入DOM的，所以无法直接从静态源码中提取到明文邮箱。

提供两种实现方案，可根据需求选择：

方案1：使用InternetExplorer控件执行JS获取渲染后内容 #

无需分析解密逻辑，直接调用IE内核渲染完整页面后提取邮箱，兼容性好。
使用前需要在VBA编辑器的「工具-引用」中勾选Microsoft Internet Controls和Microsoft HTML Object Library

Sub construction_uk_contact_ie()
    Dim IE As SHDocVw.InternetExplorer
    Dim HTMLDoc As MSHTML.HTMLDocument
    Dim url As String
    Dim info As Object
    
    url = Selection.Value
    Set IE = New SHDocVw.InternetExplorer
    IE.Visible = False ' 调试可设为True查看加载过程，正式使用设为False
    IE.Navigate url
    
    ' 等待页面加载完成
    Do While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE
        DoEvents
    Loop
    
    Set HTMLDoc = IE.Document
    Set infos = HTMLDoc.getElementsByClassName("compInfoSection")
    
    For Each info In infos
        If info.getElementsByTagName("div")(0).innerText = "Email" Then
            ' 直接提取渲染完成后的a标签邮箱文本
            ActiveCell.Offset(0, 1).Value = info.getElementsByTagName("a")(0).innerText
        End If
    Next
    
    IE.Quit
    Set IE = Nothing
    Set HTMLDoc = Nothing
End Sub

方案2：直接解密emrp()函数加密字符串（速度更快，无需启动浏览器） #

经分析站点emrp()函数的解密逻辑固定为：

• 将传入的第一个加密字符串每个字符的ASCII码减1
• 将字符串中的A替换为@
• 将字符串中的/替换为.
  可以直接从静态源码中提取加密参数自行解密，性能远高于调用浏览器：

Sub construction_uk_contact_decrypt()
    Dim IE As MSXML2.XMLHTTP60
    Dim HTMLDoc As MSHTML.HTMLDocument
    Dim url As String
    Dim scriptText As String
    Dim encryptStr As String
    Dim decryptStr As String
    Dim i As Long
    
    url = Selection.Value
    Set IE = New MSXML2.XMLHTTP60
    IE.Open "GET", url, False
    IE.Send
    While IE.ReadyState <> 4
        DoEvents
    Wend
    
    Set HTMLDoc = New MSHTML.HTMLDocument
    HTMLDoc.body.innerHTML = IE.responseText
    
    ' 提取Email区块的加密参数
    Set infos = HTMLDoc.getElementsByClassName("compInfoSection")
    For Each info In infos
        If info.getElementsByTagName("div")(0).innerText = "Email" Then
            scriptText = info.getElementsByTagName("script")(0).innerText
            ' 截取emrp函数的第一个加密入参
            encryptStr = Split(Split(scriptText, "emrp('")(1), "',")(0)
            ' 按规则解密
            decryptStr = ""
            For i = 1 To Len(encryptStr)
                decryptStr = decryptStr & Chr(Asc(Mid(encryptStr, i, 1)) - 1)
            Next
            ' 替换特殊符号得到最终邮箱
            decryptStr = Replace(Replace(decryptStr, "A", "@"), "/", ".")
            ActiveCell.Offset(0, 1).Value = decryptStr
        End If
    Next
    
    Set IE = Nothing
    Set HTMLDoc = Nothing
End Sub

内容的提问来源于stack exchange，提问作者jatin verma