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

2016年9月30日11:18:05 1 6,249 views
198元黄金VIP包含 站内所有资源免费+VBA175+基础408+代码助手VIP+Q群答疑+
点我打赏升级VIP 教程淘宝购买链接 加微信EXCEL880A 课领取所有教程7天免费试学 教程所有目录excel880.com/mulu

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

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

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

Excel批量查询手机号码归属地及运营商(自定义VBA函数)

    使用方法:

    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

  • 微信扫码免费学习
  • 免费学习48小时
  • weinxin
  • 我的微信公众号
  • EXCEL880
  • weinxin

评论已关闭!

目前评论:1   其中:访客  0   博主  1

    • excel880 Admin

      不知为何这个api现在失效了 现在用不了的不要着急 等我换个查询地址再重新上传文件