有人在群里问手机号怎么批量查归属地，第一感觉是百度一下，结果还真没找到好用的，既然如此，我就自己写一个吧！首先找了几个webapi，找到这个挺好用的http://life.tenpay.com/cgi-bin/mobile/MobileQueryAttribution.cgi?chgmobile=13905221984，就用vba写了个自定义函数，测试下感觉还是挺好用，速度也挺快

源文件下载链接请头条或者公众号私信回复63005即可

API网站已失效 需要定制Excel版手机号查询工具的 请加qq80871835 报价300起 非诚勿扰

使用方法：

1.在本表中直接在A1列输入手机号即可

2.要在其他表中，alt+f11打开vbe编辑器，复制模块中代码,在你的新表中建立模块，粘贴代码即可

3.函数参数说明

‍GetPhoneInfo(号码,参数)

号码---即单个手机号

参数(1,2,3,4)：1-城市，2-省，3-运营商,    4-全部‍

代码

Dim ObjXML As Object

Function GetPhoneInfo(number, Optional para As Byte = 1)

'获取手机号对应的基本信息 默认为城市

'para:1-城市，2-省，3-运营商,4,全部

Dim s As String

s = GetBody("http://v.showji.com/Locating/showji.com2016234999234.aspx?

output=json&callback=querycallback&m=" & number)

Select Case para

Case 1

GetPhoneInfo = HtmlFilter(s, "City"":""", """")

Case 2

GetPhoneInfo = HtmlFilter(s, "Province"":""", """")

Case 3

GetPhoneInfo = HtmlFilter(s, "TO"":""", """")

Case 4

GetPhoneInfo = HtmlFilter(s, "City"":""", """") & "," &

HtmlFilter(s, "Province"":""", """") & "," & HtmlFilter(s, "TO"":""", """")

End Select

GetPhoneInfo = Replace(GetPhoneInfo, " ", "")

End Function

Private Sub Test()

Dim i&, j&, k&, arr, brr

url = "http://v.showji.com/Locating/showji.com2016234999234.aspx?

output=json&callback=querycallback&m=15098051755"

Debug.Print GetBody(url)

End Sub

'''如果出现乱码，UTF-8可改为GB2312

Public Function GetBody(ByVal url$, Optional ByVal Coding$ = "utf-8")

On Error Resume Next

Set ObjXML = CreateObject("Microsoft.XMLHTTP")

With ObjXML

.Open "Get", url, False, "", ""

'.setRequestHeader "If-Modified-Since", "0"

'.setRequestHeader "User-Agent", _

".Mozilla/5.0 (Windows NT 6.1; WOW64; rv:47.0) Gecko/20100101 Firefox/47.0"

.Send

GetBody = .ResponseBody

End With

GetBody = BytesToBstr(GetBody, Coding)

Set ObjXML = Nothing

End Function

Public Function BytesToBstr(strBody, CodeBase)

Dim ObjStream

Set ObjStream = CreateObject("Adodb.Stream")

With ObjStream

.Type = 1: .Mode = 3: .Open:

.Write strBody: .Position = 0: .Type = 2: .Charset = CodeBase

BytesToBstr = .ReadText: .Close

End With

Set ObjStream = Nothing

End Function

Public Function HtmlFilter(ByVal htmlText$, ByVal Label1$, ByVal label2$)

'返回html字符串lable1和最近的lable2标签中的数据

Dim pStart As Long, pStop As Long

pStart = InStr(htmlText, Label1) + Len(Label1)

If pStart <> 0 Then

pStop = InStr(pStart, htmlText, label2)

HtmlFilter = Mid(htmlText, pStart, pStop - pStart)

End If

End Function

QQ80871835