国庆献礼-EXCEL自定义函数获取手机号码归属地及运营商信息

有人在群里问手机号怎么批量查归属地，第一感觉是百度一下，结果还真没找到好用的，既然如此，我就自己写一个吧！首先找了几个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

Excel880工作室为您服务,VBA,函数,网页数据抓取,数据分析,足彩,彩票分析,编程开发,office批量操作,办公自动化

QQ80871835