网页批量获取快递单信息：1.有个地方总获取不到？2.运行太慢，请教，万谢！

xmyjk · 发表于 2011-3-11 23:14

找了个unicode转换的，测试下也可以了，楼主如果对xmlhttp感兴趣的话，就再改成你需要的吧。

Sub chaxun()
Dim xmlhttp As Object
Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
xmlhttp.Open "POST", "http://222.73.105.202/kjcx/ajax.php", False
xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xmlhttp.Send "lb=tmfp&txm=1000080690768"
Do Until xmlhttp.ReadyState = 4
DoEvents
Loop
If xmlhttp.Status = 200 Then
Debug.Print xmlhttp.responsetext
Transfer (xmlhttp.responsetext)
Else
reportErr (xmlhttp.Status)
End If
End Sub
Sub reportErr(lStatus As Integer)
Select Case lStatus
Case 400
MsgBox "Bad Request", vbCritical, "连接错误"
Case 401
MsgBox "Unauthorized", vbCritical, "连接错误"
Case 402
MsgBox "Payment Required", vbCritical, "连接错误"
Case 403
MsgBox "Forbidden", vbCritical, "连接错误"
Case 404
MsgBox "Not Found", vbCritical, "连接错误"
Case 407
MsgBox "Proxy Authentication Required", vbCritical, "连接错误"
Case 408
MsgBox "Request Timeout", vbCritical, "连接错误"
Case 503
MsgBox "Service Unavailable", vbCritical, "连接错误"
Case Else
MsgBox "Can not reach by other reason", vbCritical, "连接错误"
End Select
End Sub
Sub Transfer(str1 As String)
Dim i%, y%, arr1(), arr2(), ireg As Object, imch As Object, mch As Object
Set ireg = CreateObject("vbscript.regexp")
ireg.Global = True
ireg.Pattern = "\\u\w{4}"
Set imch = ireg.Execute(str1)
For Each mch In imch
y = y + 1
ReDim Preserve arr1(1 To y)
ReDim Preserve arr2(1 To y)
arr1(y) = ChrW(CLng(Replace(mch.Value, "\u", "&h")))
arr2(y) = mch.Value
Next
For i = 1 To UBound(arr1)
str1 = Replace(str1, arr2(i), arr1(i))
Next
Debug.Print str1
Set ireg = Nothing
End Sub

复制代码

[ 本帖最后由 xmyjk 于 2011-3-11 23:19 编辑 ]

xmyjk · 发表于 2011-3-11 23:24

原得到代码：
{"state":"1","wd":"<span class='wltz'>\u5c71\u4e1c\u804a\u57ce\u516c\u53f8(252000)<\/span>\u5206\u914d\u65f6\u95f42010-07-07","fb":"<span class='wltz'>\u5c71\u4e1c\u804a\u57ce\u516c\u53f8\u8398\u53bf\u5206\u90e8(\u5206\u90e8)(252400)<\/span>\u5206\u914d\u65f6\u95f42010-07-13"}

运行后得：
{"state":"1","wd":"<span class='wltz'>山东聊城公司(252000)<\/span>分配时间2010-07-07","fb":"<span class='wltz'>山东聊城公司莘县分部(分部)(252400)<\/span>分配时间2010-07-13"}

hhh5460 · 发表于 2011-3-12 02:29

拜读，受教了！

6xiao · 发表于 2011-3-12 22:08

多谢大师！能帮我做下吗，我懂得不多，我邮箱：280202351@qq.com

xmyjk · 发表于 2011-3-12 23:21

仅仅针对你查不到的部分做了个工具，excel如附件
代码如下：

Sub chaxun()
Dim xmlhttp As Object
Dim Strtrasf As String, Ydh As String
Dim Nm As Integer, i As Integer
On Error Resume Next
Nm = Application.WorksheetFunction.CountA([A:A])
For i = 1 To Nm - 1
Cells(2, 2).Value = "正在查询第" & i & "个"
Ydh = Cells(i + 1, 1).Value
Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
xmlhttp.Open "POST", "http://222.73.105.202/kjcx/ajax.php", False
xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xmlhttp.Send "lb=tmfp&txm=" & Ydh
Do Until xmlhttp.ReadyState = 4
DoEvents
Loop
If xmlhttp.Status = 200 Then
Strtrasf = Transfer(xmlhttp.responsetext)
Cells(i + 1, 3).Value = Replace(Replace(Split(Filter(Split(Replace(Strtrasf, "'>", "'>["), ","), "[")(0), "[")(1), "<\/span>", ""), Chr(34), "")
Cells(i + 1, 4).Value = Replace(Replace(Split(Filter(Split(Replace(Strtrasf, "'>", "'>["), ","), "[")(1), "[")(1), "<\/span>", ""), Chr(34) & "}", "")
Else
reportErr (xmlhttp.Status)
End If
Set xmlhttp = Nothing
Cells(2, 2).Value = "查询完毕！"
Cells(2, 2).Value = "查询状态提示栏"
Next i
MsgBox "OK"
End Sub
Sub reportErr(lStatus As Integer)
Select Case lStatus
Case 400
MsgBox "Bad Request", vbCritical, "连接错误"
Case 401
MsgBox "Unauthorized", vbCritical, "连接错误"
Case 402
MsgBox "Payment Required", vbCritical, "连接错误"
Case 403
MsgBox "Forbidden", vbCritical, "连接错误"
Case 404
MsgBox "Not Found", vbCritical, "连接错误"
Case 407
MsgBox "Proxy Authentication Required", vbCritical, "连接错误"
Case 408
MsgBox "Request Timeout", vbCritical, "连接错误"
Case 503
MsgBox "Service Unavailable", vbCritical, "连接错误"
Case Else
MsgBox "Can not reach by other reason", vbCritical, "连接错误"
End Select
End Sub
Function Transfer(str1 As String) As String
Dim i%, y%, arr1(), arr2(), ireg As Object, imch As Object, mch As Object
Set ireg = CreateObject("vbscript.regexp")
ireg.Global = True
ireg.Pattern = "\\u\w{4}"
Set imch = ireg.Execute(str1)
For Each mch In imch
y = y + 1
ReDim Preserve arr1(1 To y)
ReDim Preserve arr2(1 To y)
arr1(y) = ChrW(CLng(Replace(mch.Value, "\u", "&h")))
arr2(y) = mch.Value
Next
For i = 1 To UBound(arr1)
str1 = Replace(str1, arr2(i), arr1(i))
Next
Transfer = Trim(str1)
Set ireg = Nothing
End Function

复制代码

6xiao · 发表于 2011-3-13 01:33

非常感谢！！！非常好用！！！

能不能帮我嵌在我的宏里面（单号从A4开始，只需要“分配给的分公司或业务员”填在F列Cells(i + 1, 6).）

Sub 单号_信息_生成()

' 重量=跟踪记录-重量记录最大值

' 目的地=跟踪记录-“派送公司”下方（到达目的地后才能显示）

' 快捷键: Ctrl+Shift+M

' =======================================================================

' 放在最前，获取Excel当前的属性状态，然后将其关闭，关闭一些Excel功能使代码运行更快
screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
calcState = Application.Calculation
eventsState = Application.EnableEvents
displayPageBreakState = ActiveSheet.DisplayPageBreaks '注:这是工作表级的设置
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False '注:这是工作表级的设置

ActiveWorkbook.Unprotect Password:="123456" '工作薄解密
ActiveSheet.Unprotect Password:="770077" '工作表解密

' =======================================================================

'【网页获取】
Dim i As Long
Dim sht As Worksheet
Dim str As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sht = ActiveSheet
Sheets.Add Sheets(1)
With sht
      For i = 4 To .Range("a3003").End(xlUp).Row
         str = "http://222.73.105.202/kjcx/cxend.php?wen=" & .Cells(i, 1)
         Sheets(1).Activate
         With ActiveSheet.QueryTables.Add(Connection:= _
            "URL;" & str, Destination:= _
            Range("A2"))
            .Name = "cxend.php?wen=1000080690768"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlEntirePage
            .WebFormatting = xlWebFormattingNone
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
         End With
'          .Cells(i, "C") = Evaluate("MAX(F:F)")
         .Cells(i, "C") = Evaluate("index(" & Sheets(1).Name & "!F:F,match(,0/" & Sheets(1).Name & "!F1:F100,))") '第一个非0数字
         .Cells(i, "D") = Evaluate("=INDEX(" & Sheets(1).Name & "!F:F,SMALL(IF(ISNUMBER(" & Sheets(1).Name & "!F1:F100)*(" & Sheets(1).Name & "!F1:F100>0),ROW(1:100)),2))") '第二个非0数字
         .Cells(i, "E") = Evaluate("=INDEX(A5:A200,MATCH(""派送公司"",A5:A200,)+1)") '目的地
         .Cells(i, "H") = Evaluate("A16") '开始时间
         .Cells(i, "I") = Evaluate("C16") '开始记录
         .Cells(i, "J") = Evaluate("INDEX(A5:A200,MATCH(""派送公司"",A5:A200,)-8)") '最后时间
         .Cells(i, "K") = Evaluate("INDEX(C5:C200,MATCH(""认领详情"",C5:C200,)-2)") '最后记录

' （这里添加 “分配给的分公司或业务员”代码）

         Sheets(1).UsedRange.Clear
      Next
End With
Sheets(1).Delete
sht.Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

6xiao · 发表于 2011-3-27 16:55

我初学者不会

		自动登录	找回密码
密码			免费注册

[求助] 网页批量获取快递单信息：1.有个地方总获取不到？2.运行太慢，请教，万谢！

回复 12楼 xmyjk 的帖子

回复 12楼 xmyjk 的帖子

回复 15楼 xmyjk 的帖子