已知企业ID,查询企业信息。主要是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