Excel获取手机归属地自定义VB方法
https://www.52pojie.cn/thread-1228207-1-1.html
之前发的对json处理有问题，没区分32位、64位excel，老帖子已经不能编辑新发一个说明
[Visual Basic] 纯文本查看 复制代码
Public Function GetMobileLocation(pohoenumber As String)
Dim Url As String
Url = "http://cx.shouji.360.cn/phonearea.php?number=" + pohoenumber
If pohoenumber <> "" Then
Dim xml_http As Object
Set xml_http = CreateObject("Microsoft.XMLHTTP")
xml_http.Open "get", Url, True
xml_http.sEnd
Do Until xml_http.ReadyState = 4
DoEvents
Loop
Dim bodyData
bodyData = xml_http.responseText
Dim lastData
lastData = Replace(bodyData, "data", "objectdata")
' Set Json = CreateObject("MSScriptControl.ScriptControl"): Json.Language = "JScript" '用于32位Excel
Set Json = CreateObjectx86("MSScriptControl.ScriptControl"): Json.Language = "JScript" '用于64位Excel
Set Obj = Json.eval("eval(" & lastData & ")")
GetMobileLocation = Array(Obj.objectdata.province, Obj.objectdata.city, Obj.objectdata.sp)
' GetMobileLocation = Obj.objectdata.province
Set xml_http = Nothing
Else
GetMobileLocation = Array("--", "--")
End If
End Function
Function CreateObjectx86(Optional sProgID, Optional bClose = False)
Static oWnd As Object
Dim bRunning As Boolean
#If Win64 Then
bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
If bClose Then
If bRunning Then oWnd.Close
Exit Function
End If
If Not bRunning Then
Set oWnd = CreateWindow()
oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
End If
Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
#Else
Set CreateObjectx86 = CreateObject("MSScriptControl.ScriptControl")
#End If
End Function
Function CreateWindow()
Dim sSignature, oShellWnd, oProc
On Error Resume Next
sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
Do
For Each oShellWnd In CreateObject("Shell.Application").Windows
Set CreateWindow = oShellWnd.GetProperty(sSignature)
If Err.Number = 0 Then Exit Function
Err.Clear
Next
Loop
End Function
获取手机归属地1.zip
(56.13 KB, 下载次数: 187)
| 
[复制链接]
发表于 2022-9-8 15:36
