Excel获取手机归属地自定义VB方法

无象心 发表于 2022-9-8 15:36

Excel获取手机归属地自定义VB方法
https://www.52pojie.cn/thread-1228207-1-1.html
之前发的对json处理有问题，没区分32位、64位excel，老帖子已经不能编辑新发一个说明

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

孤狼微博 发表于 2022-9-9 12:07

白洁发表于 2022-9-9 09:19
CD1E-A8AD-8A1C-9721-4DA4
http://www.cjhf.net/
麻烦请给一个注册码，谢谢。

0180-2664-797D-3304-A6C8

白洁发表于 2022-9-9 09:19

孤狼微博发表于 2022-9-8 18:41
现在有携转了

CD1E-A8AD-8A1C-9721-4DA4
http://www.cjhf.net/
麻烦请给一个注册码，谢谢。

孤狼微博 发表于 2022-9-8 18:41

现在有携转了

likaiaixuexi 发表于 2022-9-8 19:20

这个好用了，是办公的好帮手

01z8z0 发表于 2022-9-8 19:51

感谢分享

xiaoc255 发表于 2022-9-8 20:17

感谢分享:victory:

nanhai31 发表于 2022-9-8 21:15

感谢分享

CXC303 发表于 2022-9-8 21:36

感谢分享

acfz 发表于 2022-9-8 21:43

好用了感谢楼主

页: [1] 2

吾爱破解 - 52pojie.cn's Archiver

Excel获取手机归属地自定义VB方法