|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
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
|
|