用天眼查查询企业信息（含token和_utm值算法）

Sub Main()
    ‘根据企业在天眼查内的ID来查询企业信息
    ‘原创：wcymiss
    
    Dim strText As String
    Dim objHttp As Object
    Dim strURL As String
    Dim ID As String
    Dim sgArr() As String
    Dim strToken As String
    Dim strUtm As String
    Dim strV As String
    Dim strCode As String
    Dim Index As Integer
    
    ID = "812498657"
    Set objHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    strURL = "http://www.tianyancha.com/tongji/" & ID & ".json"
    With objHttp
        .Open "GET", strURL, False
        .setRequestHeader "Accept", "application/json, text/plain, */*"
        .Send
        strText = .responsetext
    End With
    strCode = Split(Split(strText, ",""v"":""")(1), """")(0)
    strV = StringFromCode(strCode)
    strToken = Split(Split(strV, "‘token=")(1), ";")(0)
    strCode = Split(Split(strV, "return‘")(1), "‘")(0)

    strURL = "http://static.tianyancha.com/wap/resources/scripts/app-ce05b92dbf.js"
    With objHttp
        .Open "GET", strURL, False
        .Send
        strText = .responsetext
    End With
    sgArr = GetSoGou(strText)
    Index = Asc(Left(ID, 1)) Mod 10
    strUtm = GetUtm(sgArr, Index, strCode)

‘    Debug.Print strToken
‘    Debug.Print strUtm

    strURL = "http://www.tianyancha.com/company/" & ID & ".json"
    With objHttp
        .Open "GET", strURL, False
        .setRequestHeader "Accept", "application/json, text/plain, */*"
        .setRequestHeader "Cookie", "token=" & strToken & ";_utm=" & strUtm
        .Send
        strText = .responsetext
    End With
    
    Set objHttp = Nothing
    Debug.Print strText
End Sub

Private Function GetSoGou(strText As String) As String()
    Dim arr() As String
    Dim i As Integer
    Dim objReg As Object
    Dim sgArr(0 To 9) As String
    Dim Index As Integer
    
    Set objReg = CreateObject("VBScript.Regexp")
    objReg.Global = True
    
    arr = Split(strText, "appendChlid(")
    For i = 1 To UBound(arr)
        arr(i) = Split(Split(arr(i), ">")(1), "<")(0)
    Next
    objReg.Pattern = "&[^;]*;"
    For i = 1 To UBound(arr)
        arr(i) = objReg.Replace(arr(i), "")
    Next
    objReg.Pattern = "[^0-9a-z-]"
    For i = 1 To UBound(arr)
        arr(i) = objReg.Replace(arr(i), "")
    Next
    Set objReg = Nothing
    
    For i = 1 To UBound(arr)
        If Len(arr(i)) > 1 Then
            Index = Left(arr(i), 1)
            sgArr(Index) = sgArr(Index) & Mid(arr(i), 2)
        End If
    Next
    GetSoGou = sgArr
End Function

Private Function GetUtm(sgArr() As String, Index As Integer, strCode As String) As String
    Dim i As Integer
    Dim arr() As String
    arr = Split(strCode, ",")
    For i = 0 To UBound(arr)
        GetUtm = GetUtm & Mid(sgArr(Index), arr(i) + 1, 1)
    Next
End Function

Private Function StringFromCode(strCode As String) As String
    Dim i As Integer
    Dim arr() As String
    arr = Split(strCode, ",")
    For i = 0 To UBound(arr)
        StringFromCode = StringFromCode & Chr(arr(i))
    Next
End Function