EXCEL VBA使用xmlhttp组件批量查询跟踪快递签收情况及签收时间

对物流或者电商行业，或者前台文员来说，经常需要跟踪寄出的快件到达情况，如果一个个去手动查询，非常麻烦，这里提供一个VBA可以快速批量查询，使用了KUAIDI100的查询接口
Cells(j, 7) 代表你要查询的快递单号所在的列为第7列，也就是G列，这里根据你的实际情况批量修改下宏里的这个设置，Cells(j, 9)是用来写入签收状态的列，这里9是I列；Cells(j, 11) 是写入签收时间的列这里是第11列也就是K列，Cells(j, 6)是VBA用来写入查到的你快递单号所属的快递公司名称，也就是F列，Range("k:k")是设置K列的时间格式

注意因为是使用别人网站的接口，因此如果一次性查询过多可能会被封IP，就是好几个小时内，再也查不到任何状态，因此最好一次性别查超过一百个，最好是限制在一次性查20个左右比较保险




Sub kuaidi()
    On Error Resume Next
    Dim xmlhttp As Object, str1$, str2$, str3$, str4$
    Dim i%, j%
    On Error Resume Next
    lstro = Cells(Rows.Count, 4).End(xlUp).Row
    s = Application.InputBox("请你输入你想查询的开始行号" & Chr(13) & Chr(13) & "查询前请先保存订单表，防止出现未响应而意外关闭未保存" & Chr(13) & Chr(13) & "为避免快递100查询限制，每次查询不要超过100个，2小时内不能频繁查询", "输入开始行号", 2, Type:=1)
    If s = False Then Exit Sub
    If s > lstro Then MsgBox "开始行号不能大于表格中已使用的总行数!": Exit Sub
    t = Application.InputBox("请你输入你想查询的结束行号" & Chr(13) & Chr(13) & "为避免快递100查询限制，每次查询不要超过100个，2小时内不能频繁查询", "输入结束行号", lstro, Type:=1)
    If t = False Then Exit Sub
    If t < s Then MsgBox "结束行号不能小行开始行号！": Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
   
    Set xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    With xmlhttp
     For j = s To t
      If Cells(j, 7) <> "" And Cells(j, 9) <> "已签收" Then
        .Open "POST", "http://www.kuaidi100.com/autonumber/autoComNum?text=" & Trim(Cells(j, 7).Value)
        .send    'post请求，目的是获得快递公司名称
        str4 = .responsetext
        str1 = Split(Split(str4, "comCode"":""")(2), """")(0)
       
        .Open "GET", "http://www.kuaidi100.com/query?type=" & str1 & "&postid=" & Trim(Cells(j, 7).Value)
        .setrequestheader "X-Requested-With", "XMLHttpRequest"
        .setrequestheader "Referer", "http://www.kuaidi100.com/"
        .send
     
        str2 = .responsetext  '取得物流数据
       
        If InStr(str2, "参数异常") Then   '如果参数异常，尝试更换快递接口查询
            str1 = Split(Split(str4, "comCode"":""")(3), """")(0)
       
            .Open "GET", "http://www.kuaidi100.com/query?type=" & str1 & "&postid=" & Trim(Cells(j, 7).Value)
            .setrequestheader "X-Requested-With", "XMLHttpRequest"
            .setrequestheader "Referer", "http://www.kuaidi100.com/"
            .send
     
            str2 = .responsetext
            If InStr(str2, "参数异常") Then
                Cells(j, 6) = ch(Split(Split(str4, "comCode"":""")(2), """")(0))
                Cells(j, 9) = "暂无记录"
                GoTo L  '如果第二次未查到信息则跳过
            End If
        End If
        str3 = Split(Split(str2, "{""time"":""")(1), """,""context"":""")(0) & "  " & Split(Split(str2, """context"":""")(1), """,""ftime"":""")(0)
        If InStr(str3, "签收") Then
            Cells(j, 9) = "已签收"
            Cells(j, 11) = Left(str3, 19)
        ElseIf InStr(str2, "已收") And InStr(str2, "派件") = 0 Then Cells(j, 9) = "在途中"
        ElseIf InStr(str2, "已揽收") And InStr(str2, "派件") = 0 Then Cells(j, 9) = "在途中"
        ElseIf InStr(str2, "揽件") And InStr(str2, "派件") = 0 Then Cells(j, 9) = "在途中"
        ElseIf InStr(str2, "派件") Then Cells(j, 9) = "派送中"
        End If
        If Cells(j, 6) = "" And ch(str1) = "" Then
            Cells(j, 6) = str1
        ElseIf Cells(j, 6) = "" And ch(str1) <> "" Then Cells(j, 6) = ch(str1)
       End If
      End If
L:    str1 = "": str2 = "": str3 = "": str4 = ""
     Next
    End With
    Range("k:k").NumberFormatLocal = "yyyy-m-d hh:mm:ss"
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub


Function ch(ByVal str As String)
    Select Case str
        Case "zhongtong"
            ch = "中通快递"
        Case "huitongkuaidi"
            ch = "汇通快递"
        Case "yunda"
            ch = "韵达快递"
        Case "yuantong"
            ch = "圆通快递"
        Case "shunfeng"
            ch = "顺丰快递"
        Case "shentong"
            ch = "申通快递"
        Case "guotong"
            ch = "国通快递"
        Case "tiantian"
            ch = "天天快递"
        Case "lianhaowuliu"
            ch = "联昊快递"
        Case "quanfengkuaidi"
            ch = "全峰快递"
        Case Else
            ch = ""
    End Select
End Function