物流抓取神器制作请大神解决

huzhiqiang13

Private Sub 批量获取1()
On Error GoTo aa
Dim url2$, htmlcode2$
Dim rowa2!, rowb!, i!, j!, ms!

Set OH = CreateObject("Msxml2.ServerXMLHTTP")
dengluming = Sheet2.Cells(1, 2)
denglumima = Sheet2.Cells(2, 2)
fp = Sheet2.Cells(3, 2)


'登录-----------------------------------------------------------
OH.Open "post", "http://ssa.jd.com/sso/login", False
OH.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
Data = "fp=" & fp & "&username=" & dengluming & "&password=" & denglumima & ""
OH.send (Data)



rowa2 = [A65536].End(3).Row
v = "共计查询" & rowa2 - 2
v1 = v & "单，预计耗时"
v3 = v1 & Round(rowa2 / 2 / 60, 0) & "分钟，温馨提示：查询期间EXECL会失去响应，请提前保存好数据。"
'Select Case MsgBox(v2, 52, "警告")
'Case 6
   
   For i = 3 To rowa2
    t = Timer
    Do While Timer - 0.0000001 < t '防止服务器堵塞
       Debug.Print
    Loop
   
    If Cells(i, 1) = "" Then GoTo aa
   
    OH.Open "post", "http://waybill.jd.com/waybill/trackInfoByCode", False
    OH.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    Data = "code=" & Cells(i, 1)
    OH.send (Data)
    htmlcode2 = OH.responsetext



    'htmlcode2 = getHTML(Cells(i, 1)) '得到点击查询后返回的源代码
    Dim s12 As String, s2 As String, s3 As String
    Dim s4 As String, arr2, arr1, lon
    Dim b As Integer, c As Integer
        c = 6
        s12 = getstr(htmlcode2, "<td>", "</td>", 2)
        arr2 = Split(s12, "分隔符")
       lon = UBound(arr2) ' - LBound(arr)  '获取数组大小
'        For b = 1 To lon / 8
'
'            If Replace(arr2(lon - b - 1 + 0), "<td>", "") = "150" Then
'              c = 1
'              Exit For
'            End If
'
'        Next b
      
        If lon < 1 Then GoTo aa
        
        If lon > 4 Then    '避免没变量下标越界
          Cells(i, 2) = Replace(arr2(lon - 4), "<td>", "") '获取有无完成结果
          Cells(i, 3) = Replace(arr2(lon - 3), "<td>", "") '获取有无完成结果
          Cells(i, 4) = Replace(arr2(lon - 2), "<td>", "") '获取有无完成结果
          Cells(i, 5) = Replace(arr2(lon - 1), "<td>", "")  '获取有无完成结果
          Cells(i, 6) = Replace(arr2(lon - 0), "<td>", "")  '获取有无完成结果
          Else
          GoTo aa
          End If
          If lon > 10 Then
         
      
          Cells(i, 7) = Replace(arr2(lon - 9), "<td>", "")  '获取有无完成结果
          Cells(i, 8) = Replace(arr2(lon - 8), "<td>", "") '获取有无完成结果
          Cells(i, 9) = Replace(arr2(lon - 7), "<td>", "") '获取有无完成结果
          Cells(i, 10) = Replace(arr2(lon - 6), "<td>", "") '获取有无完成结果
          Cells(i, 11) = Replace(arr2(lon - 5), "<td>", "")   '获取有无完成结果
             Else
          GoTo aa
         End If
         If lon > 15 Then
          Cells(i, 12) = Replace(arr2(lon - 14), "<td>", "") '获取有无完成结果
          Cells(i, 13) = Replace(arr2(lon - 13), "<td>", "") '获取有无完成结果
          Cells(i, 14) = Replace(arr2(lon - 12), "<td>", "") '获取有无完成结果
          Cells(i, 15) = Replace(arr2(lon - 11), "<td>", "") '获取有无完成结果
          Cells(i, 16) = Replace(arr2(lon - 10), "<td>", "") '获取有无完成结果
             Else
          GoTo aa
         End If
        Cells(i, 17) = Replace(arr2(1), "<td>", "") '获取有无完成结果
        Cells(i, 18) = Replace(arr2(3), "<td>", "") '获取有无完成结果
        Cells(i, 19) = Replace(arr2(5), "<td>", "") '获取有无完成结果
        Cells(i, 20) = Replace(arr2(6), "<td>", "") '获取有无完成结果
        Cells(i, 21) = Replace(arr2(8), "<td>", "") '获取有无完成结果
        Cells(i, 22) = Replace(arr2(10), "<td>", "") '获取有无完成结果
        Cells(i, 23) = Replace(arr2(11), "<td>", "") '获取有无完成结果
        Cells(i, 24) = Replace(arr2(13), "<td>", "") '获取有无完成结果
        Cells(i, 25) = Replace(arr2(15), "<td>", "") '获取有无完成结果
         
         
aa:
         
          prgramBarShow.Show 0
         
          If i > 30 Then
          Application.ScreenUpdating = False
          End If
         
          prgramBarShow.lblprogress.Width = prgramBarShow.lblBack.Width * i / rowa2
          prgramBarShow.percert.Caption = Format(Round(i / rowa2 * 100, 2), "0") & "%"
          prgramBarShow.Repaint
          If i / rowa2 = 1 Then
           Unload prgramBarShow
           End If

      

  Next i
'End Select
DoEvents



End Sub



Function getstr(sr As String, startstr As String, endstr As String, k As Integer)
'Dim regx As New RegExp ,这个函数 ， 是取 开头和结尾之间的  字符
'截取  XX开头  XX 结尾 之间的  字符
Dim mat
Dim m
Set regex = CreateObject("VBScript.RegExp")
With regex
    .Global = True
    .Pattern = "(?=" & startstr & ")[\s\S]*?(?=" & endstr & ")"
     If .test(sr) = False Then
       getstr = "none"
    Else
        If k = 1 Then
            Set mat = .Execute(sr)
            If mat.Count = 1 Then
                getstr = .Execute(sr)(0)
            Else
            For Each m In mat
                If InStr(m, "徐州") > 0 Then getstr = m
            Next
            End If
        ElseIf k = 2 Then
            Set mat = .Execute(sr)
            For Each m In mat
                sr1 = sr1 & m & "分隔符"
            Next
            getstr = Left(sr1, Len(sr1) - 3)
             Set objXML = Nothing
        End If
    End If
End With
End Function
Function getHTML(sdata)
Dim objXML, url, url1, url2
Set objXML = CreateObject("Msxml2.ServerXMLHTTP")
With objXML
    .Open "post", "http://waybill.jd.com/waybill/trackInfoByCode", 0
    .SetRequestHeader "Content-Length", Len(sdata)
    .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    url = "code=" & sdata
    url1 = ""
    url2 = url & url1
    .SetRequestHeader "cookie", ""
    .send url2
   
getHTML = .responsetext
End With
Set objXML = Nothing
End Function

Private Sub 整理格式1()
Sheets("查询界面").Range("A3:B65536").ClearContents
Sheets("查询界面").Range("C3:Y65536").ClearContents

End Sub

约定的童话

你这是请教了个寂寞啊

huzhiqiang13

哈哈，能操作吗

高个子

这代码有什么问题？