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