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

Function kdcx(kd, orderid)
Dim Err, url, kdtime, link, Errcode, Status

Select Case kd  '此处支持的快递公司很多的
    Case "申通"
        kd = "shentong"
    Case "圆通"
        kd = "yuantong"
    Case "优速"
        kd = "yousu"
    Case "龙邦"
        kd = "longbang"
    Case "城市"
        kd = "cs"
    Case Else
        MsgBox "暂时不支持此快递，可以联系管理员添加！"
        kdcx = "暂时不支持此快递"
        Exit Function
End Select

Set http = CreateObject("Microsoft.XMLHTTP")
url = "http://www.aikuaidi.cn/rest/?key=xxxx&order=" & orderid & "&id=" & kd & "&ord=desc&show=xml"

http.Open "get", url, False
http.send
WebContent = http.responsetext
'MsgBox WebContent

Set objDom = CreateObject("Microsoft.XMLDom")
objDom.async = False
objDom.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
    Next
Else
    MsgBox "查询数据还未准备就绪。状态：" & objDom.ReadyState & "。"
End If
Set http = Nothing
Set objDom = Nothing

Select 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 Select

Select 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 Select

kdcx = Status
End Function

Sub deletebutton() '删除工具栏和菜单的子程序
Dim tempbar As CommandBar '定义临时工具栏变量
On Error Resume Next '该语句用于忽略错误
Application.CommandBars("Menu Bar").Reset '重新设置Word XP的主菜单，即删除新建的菜单
For Each tempbar In Application.CommandBars '通过“For Each…Next”语句遍历Word XP所有的工具栏
If tempbar.Name = "快递查询" Then '如名称和新建的工具栏相同
tempbar.Visible = False '设置为不可视
tempbar.Delete '删除该工具栏
End If
Next
End Sub

Sub 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 With

End Sub

Private 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上面申请。

调用参数：

参数名称	类型	是否必需	描述
key	string	是	授权密钥，点击此处 [ 快递API接口申请入口 ] 即可申请
order	string	是	快递单号，请注意区分大小写
id	string	是	快递代号，如：圆通（yuantong）、申通（shentong），点击此处 [ 查看完整快递代号 ]
ord	string	可选	排序规则：  asc：按时间旧到新排序，  desc：按时间新到旧排序，  不传默认值：asc
show	string	可选	返回类型：  json：返回json字符串，  xml：返回xml字符串，  html：返回html字符串，  不传默认值：json