Excel快遞單號查詢工具以及源碼

Function kdcx(kd, orderid)Dim Err, url, kdtime, link, Errcode, StatusSelect Case kd  '此處支持的快遞公司很多的    Case "申通"        kd = "shentong"    Case "圓通"        kd = "yuantong"    Case "優(yōu)速"        kd = "yousu"    Case "龍邦"        kd = "longbang"    Case "城市"        kd = "cs"    Case Else        MsgBox "暫時不支持此快遞，可以聯(lián)系管理員添加！"        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") '讀取頁面上指定區(qū)域    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 "查詢數(shù)據(jù)還未準備就緒。狀態(tài)：" & objDom.ReadyState & "。"End IfSet http = NothingSet objDom = NothingSelect Case Errcode    Case "0000"        Err = "無錯誤"    Case "0001"        Err = "傳輸參數(shù)格式有誤"    Case "0002"        Err = "用戶編號(uid)無效"    Case "0003"        Err = "用戶被禁用"    Case "0004"        Err = "授權key無效"    Case "0005"        Err = "快遞代號(id)無效"    Case "0006"        Err = "訪問次數(shù)達到最大額度"    Case "0007"        Err = "查詢服務器返回錯誤"    Case Else        Err = "查詢出現(xiàn)未知錯誤"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 = "快遞狀態(tài)未知情況"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() '創(chuàng)建工具欄和菜單并設置屬性的子程序    Call deletebutton    '調(diào)用刪除工具欄和菜單的子程序    Set Obj_Toolbar = Application.CommandBars.Add("快遞查詢") '新建工具欄，“快遞查詢”代表工具欄的名稱        Set Obj_Toolbar_button = Obj_Toolbar.Controls.Add(Type:=msoControlButton, ID:=1) '新建工具欄按鈕    With Obj_Toolbar_button '設置按鈕的屬性      .Caption = "查詢快遞狀態(tài)"      .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 = "快遞狀態(tài)"        .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 "查詢已經(jīng)完畢！"End Sub

能支持國內(nèi)多家快遞公司快遞單號查詢，順豐快遞、圓通快遞、申通快遞、ems等都支持。key可以到快遞單號查詢網(wǎng)www.aikuaidi.cn上面申請。

調(diào)用參數(shù)：