excel快递单号查询工具以及源码

Excel快递单号查询工具以及源码

Function kdcx(kd, orderid)Dim Err, url, kdtime, link, Errcode, StatusSelect Case kd  '此处支持的快递公司很多的    Case "申通"        kd = "shentong"    Case "圆通"        kd = "yuantong"    Case "优速"        kd = "yousu"    Case "龙邦"        kd = "longbang"    Case "城市"        kd = "cs"    Case Else        MsgBox "暂时不支持此快递，可以联系管理员添加！"        kdcx = "暂时不支持此快递"        Exit FunctionEnd SelectSet http = CreateObject("Microsoft.xmlHTTP")url = "http://www.aikuaidi.cn/rest/?key=xxxx&order=" & orderid & "&id=" & kd & "&ord=desc&show=xml"http.Open "get", url, Falsehttp.sendWebContent = http.responsetext'MsgBox WebContentSet objDom = CreateObject("Microsoft.XMLDom")objDom.async = FalSEObjDom.LoadXML (WebContent)If objDom.ReadyState > 2 Then    Set Item = objDom.getElementsByTagName("SyncResponseEntity") '读取页面上指定区域    For i = 0 To (Item.Length - 1)        Status = Item.Item(i).getElementsByTagName("status").Item(0).Text        If Status = 1 Then                kdcx = Status            Exit For        End If        Errcode = Item.Item(i).getElementsByTagName("errcode").Item(0).Text       ' kdtime = Item.Item(i).getElementsByTagName("time").Item(0).Text        'link = Item.Item(i).getElementsByTagName("content").Item(0).Text    NextElse    MsgBox "查询数据还未准备就绪。状态：" & objDom.ReadyState & "。"End IfSet http = NothingSet objDom = NothingSelect Case Errcode    Case "0000"        Err = "无错误"    Case "0001"        Err = "传输参数格式有误"    Case "0002"        Err = "用户编号(uid)无效"    Case "0003"        Err = "用户被禁用"    Case "0004"        Err = "授权key无效"    Case "0005"        Err = "快递代号(id)无效"    Case "0006"        Err = "访问次数达到最大额度"    Case "0007"        Err = "查询服务器返回错误"    Case Else        Err = "查询出现未知错误"End SelectSelect Case Status    Case "-1"        Status = "未更新的单号"    Case "0"        Status = "查询异常"    Case "1"        Status = "暂无记录"    Case "2"        Status = "在途中"    Case "3"        Status = "派送中"    Case "4"        Status = "已签收"    Case "5"        Status = "拒签收"    Case "6"        Status = "疑难件"    Case "7"        Status = "无效单"    Case "8"        Status = "超时单"    Case "9"        Status = "签收失败"    Case Else        Status = "快递状态未知情况"End Selectkdcx = StatusEnd FunctionSub deletebutton() '删除工具栏和菜单的子程序Dim tempbar As CommandBar '定义临时工具栏变量On Error Resume Next '该语句用于忽略错误application.CommandBars("Menu Bar").Reset '重新设置Word XP的主菜单，即删除新建的菜单For Each tempbar In Application.CommandBars '通过“For Each&hellip;Next”语句遍历Word XP所有的工具栏If tempbar.Name = "快递查询" Then '如名称和新建的工具栏相同tempbar.Visible = False '设置为不可视tempbar.Delete '删除该工具栏End IfNextEnd SubSub addbutton() '创建工具栏和菜单并设置属性的子程序    Call deletebutton    '调用删除工具栏和菜单的子程序    Set Obj_Toolbar = Application.CommandBars.Add("快递查询") '新建工具栏，“快递查询”代表工具栏的名称        Set Obj_Toolbar_button = Obj_Toolbar.Controls.Add(Type:=msoControlButton, ID:=1) '新建工具栏按钮    With Obj_Toolbar_button '设置按钮的属性      .Caption = "查询快递状态"      .Style = msoButtonIconAndCaption      .FaceId = 1018      .OnAction = "s123"    End With        With Obj_Toolbar '设置工具栏的属性     .Visible = True '工具栏可视     .Enabled = True '工具栏可用     .Position = msoBarTop '工具栏置顶    End WithEnd SubPRivate Sub s123()   ' Call yyy    lstRo = Cells(Rows.Count, 1).End(xlUp).Row    istart = InputBox("请你输入你想查询的开始行号", "开始行号", "2")    If istart = "" Then Exit Sub    iend = InputBox("请你输入你想查询的结束行号", "结束行号", lstRo)    If iend = "" Then Exit Sub            With Cells(1, 11)        .Value = "快递状态"        .Font.Bold = True        .HorizontalAlignment = xlCenter   '水平居中        .VerticalAlignment = xlCenter   '垂直居中        End With                        For Ro = istart To iend          If Cells(Ro, 9) <> "" And Cells(Ro, 10) <> "" Then            Cells(Ro, 11).Value = kdcx(Cells(Ro, 9), Cells(Ro, 10))          End If        Next Ro    MsgBox "查询已经完毕！"End Sub

能支持国内多家快递公司快递单号查询，顺丰快递、圆通快递、申通快递、ems等都支持。key可以到快递单号查询网www.aikuaidi.cn上面申请。

调用参数：