蓝天、html2013、ccwan大师看到进来看看 xmlhttp法不能翻页或IE法不能获取完整源代码

VBA万岁 · 发表于 2015-4-15 10:52

本帖最后由 VBA万岁于 2015-4-15 10:55 编辑

bailanhong 发表于 2015-4-14 22:08
非常感谢！！！

以下代码可在第一种IE法的基础上实现带图片及链接的取数：

Sub IE获取摄影数据1()
Dim shp As Shape, r0 As Long, p%, i%, j%, r, t
Set My = ActiveSheet
For Each shp In My.Shapes
If Left(shp.Name, 6) <> "Button" Then shp.Delete
Next
Cells.Clear
On Error Resume Next
With CreateObject("internetexplorer.application")
.Visible = True
.Navigate "http://www.cfh.ac.cn/Album/ShowAlbum.aspx?albumid=4b7af393-99db-4461-a7c5-daa98b9384e5&Username=arisaema&AspxAutoDetectCookieSupport=1"
Do Until .ReadyState = 4
DoEvents
Loop
'For p = 1 To Val(Split(Split(.Document.All.tags("span")("ctl00_ContentPlaceHolder_body_labPageMsg").innertext, "/")(1), "页")(0))
For p = 1 To 2
r0 = IIf(p = 1, 0, ActiveSheet.UsedRange.Rows.Count)
Set r = .Document.All.tags("table")(1).Rows
For i = 0 To r.Length - 1
For j = 0 To r(i).Cells.Length - 1
With Cells(r0 + i + 1, j + 1)
.Value = Chr(10) & Chr(10) & r(i).Cells(j).innertext
ActiveSheet.Hyperlinks.Add Anchor:=Cells(r0 + i + 1, j + 1), Address:=Replace(r(i).Cells(j).All.tags("a")(1).href, "about:", "http://www.cfh.ac.cn")
.Select
ActiveSheet.Shapes.AddShape(msoShapeRectangle, .Left, .Top, .Width / 2, .Height / 2).Select
Selection.ShapeRange.Fill.UserPicture Replace(r(i).Cells(j).All.tags("img")(0).src, "about:", "http://www.cfh.ac.cn")
Selection.ShapeRange.Line.Visible = False
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=Replace(r(i).Cells(j).All.tags("a")(0).href, "about:", "http://www.cfh.ac.cn")
End With
Next j
Next i
'If p = Val(Split(Split(.Document.All.tags("span")("ctl00_ContentPlaceHolder_body_labPageMsg").innertext, "/")(1), "页")(0)) Then Exit Sub
If p = 2 Then Exit Sub
.Document.All.tags("input")("ctl00$ContentPlaceHolder_body$ImgBtnNext").Click
Do Until .ReadyState = 4
DoEvents
Loop
t = Timer
Do Until Timer > t + 10
Loop
Next p
End With
End Sub

复制代码

VBA万岁 · 发表于 2015-4-15 10:59

VBA万岁发表于 2015-4-15 10:52
以下代码可在第一种IE法的基础上实现带图片及链接的取数：

附件：

松江钟贾山摄影取数.zip (1.2 MB, 下载次数: 8)

VBA万岁 · 发表于 2015-4-15 14:14

liucqa 发表于 2015-4-10 23:35
用fiddler抓包看一下post

在论及含有ViewState的帖子中，似乎只有你的网抓教程（二），我这里测试相关代码，到目前为止，最成功的也是你在教程（二）中所列举的那个经典的实例（查看专业资质排名）。
可在本帖楼主所指的网站中，抓包得到的PostData数据中，除了ViewState、EventValidation两个变量外，还有ctl00%24ContentPlaceHolder_body%24ImgBtnGoPage.x及ctl00%24ContentPlaceHolder_body%24ImgBtnGoPage.y两个变量，而且这个变量（x、y)似乎无法通过某一算法得出，也无法在responsetext数据中找到。试着任意设置两个数值，结果屡试不爽——提取多页数据始终为第一页数据的多次重复。
所以，不知学导能否指点一下。

VBA万岁 · 发表于 2015-4-15 14:16

VBA万岁发表于 2015-4-15 14:14
在论及含有ViewState的帖子中，似乎只有你的网抓教程（二），我这里测试相关代码，到目前为止，最成功的也 ...

我这里套用教程（二）示例的代码（运行不成功）如下：

Sub MSXML2查看专业资质排名()
Dim strAllItemName, aryIndex, html
Cells.Clear
On Error Resume Next
Set html = CreateObject("htmlfile")
Url = "http://www.cfh.ac.cn/Album/ShowAlbum.aspx?albumid=4b7af393-99db-4461-a7c5-daa98b9384e5&Username=arisaema&AspxAutoDetectCookieSupport=1"
With CreateObject("msxml2.xmlhttp")
.Open "GET", Url, False
.send
viewstate = Split(Split(.responsetext, "__VIEWSTATE"" value=""", -1, vbTextCompare)(1), """", -1, vbTextCompare)(0) '取得VIEWSTATE的Post参数，去掉“, -1, vbTextCompare”也可
EventValidation = Split(Split(.responsetext, "__EVENTVALIDATION"" value=""", -1, vbTextCompare)(1), """", -1, vbTextCompare)(0) '取得EVENTVALIDATION的Post参数
n = Val(Split(Split(.responsetext, "总共")(1), "张")(0))
p0 = Val(Split(Split(.responsetext, "当前是第1/")(1), "页")(0))
End With
For p = 1 To 2
With CreateObject("msxml2.xmlhttp")
PostData = "__VIEWSTATE=" & EncodePostdata(viewstate) & _
"&__EVENTVALIDATION=" & EncodePostdata(EventValidation) & _
"&ctl00%24HiddenField_MasterUserName=" & _
"&ctl00%24HiddenField_VisitorUserName=" & _
"&ctl00%24CurrAlbumID=" & _
"&ctl00%24ContentPlaceHolder_body%24CurrentAlbumId=4b7af393-99db-4461-a7c5-daa98b9384e5" & _
"&ctl00%24ContentPlaceHolder_body%24TotalPhotos=" & n & _
"&ctl00%24ContentPlaceHolder_body%24TotalPages=" & p0 & _
"&ctl00%24ContentPlaceHolder_body%24CurrentPage=1" & _
"&AlbumRefUrl=" & _
"&ctl00%24ContentPlaceHolder_body%24TxtPageSn=" & p & _
"&ctl00%24ContentPlaceHolder_body%24ImgBtnGoPage.x=22" & _
"&ctl00%24ContentPlaceHolder_body%24ImgBtnGoPage.y=8"
.Open "POST", Url, False
.setRequestHeader "Referer", Url '提交来源
.setRequestHeader "If-Modified-Since", "0"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" 'POST提交必备
.setRequestHeader "Content-Length", Len(PostData) 'POST提交的长度信息
.setRequestHeader "Connection", "Keep-Alive"
.send (PostData) ' 如果操作系统为XP，只有打上括号才能提交。（猜测可能和Unicode编码有关）
html.body.innerhtml = .responsetext
Set tb = html.all.tags("tr")
For a = 2 To tb.Length
For b = 0 To tb(a).Cells.Length - 1
Cells((p - 1) * 10 + a - 1, b + 1) = tb(a).Cells(b).innertext
Next
Next
viewstate = Split(Split(.responsetext, "__VIEWSTATE"" value=""")(1), """")(0) '获取VIEWSTATE参数
EventValidation = Split(Split(.responsetext, "__EVENTVALIDATION"" value=""")(1), """")(0) '获取EVENTVALIDATION参数
End With
Next p
End Sub
Function EncodePostdata(szInput)
Dim i As Long
Dim x() As Byte
Dim szRet As String
szRet = ""
x = StrConv(szInput, vbFromUnicode)
For i = LBound(x) To UBound(x)
If x(i) >= 48 And x(i) <= 57 Or x(i) >= 65 And x(i) <= 90 Or x(i) >= 97 And x(i) <= 122 Then
szRet = szRet & Chr(x(i))
Else
szRet = szRet & "%" & Hex(x(i))
End If
Next
EncodePostdata = szRet
End Function

复制代码

浮华、缠绕指尖 · 发表于 2015-4-15 14:47

VBA万岁发表于 2015-4-15 14:14
在论及含有ViewState的帖子中，似乎只有你的网抓教程（二），我这里测试相关代码，到目前为止，最成功的也 ...

其实吧，这东西就是入门级的网抓而已，根本就不涉及什么算法，比如JS之类的
记得吴姐说过，只要不涉及加密的，都是可以直接藐视
对于这个，你可以仔细参考一下 http://club.excelhome.net/forum. ... 388&pid=8134043这里面的代码

浮华、缠绕指尖 · 发表于 2015-4-15 14:47

VBA万岁发表于 2015-4-15 14:14
在论及含有ViewState的帖子中，似乎只有你的网抓教程（二），我这里测试相关代码，到目前为止，最成功的也 ...

其实吧，这东西就是入门级的网抓而已，根本就不涉及什么算法，比如JS之类的
记得吴姐说过，只要不涉及加密的，都是可以直接藐视
对于这个，你可以仔细参考一下 http://club.excelhome.net/forum. ... 388&pid=8134043这里面的代码

VBA万岁 · 发表于 2015-4-15 16:05

本帖最后由 VBA万岁于 2015-4-15 16:14 编辑

浮华、缠绕指尖发表于 2015-4-15 14:47
其实吧，这东西就是入门级的网抓而已，根本就不涉及什么算法，比如JS之类的
记得吴姐说过，只要不涉及加 ...

不敢苟同，也不敢藐视，只因功底尚浅。
——仔细读过你在那个帖子中所写的代码，仍不见有所启发。所以，还是希望Super能写一个完整的代码以供我等入门级会员学习提高一下。

bailanhong · 发表于 2015-4-15 23:24

再次感谢各位大师的帮助！！

VBA万岁 · 发表于 2015-4-16 17:32

VBA万岁发表于 2015-4-15 16:05
不敢苟同，也不敢藐视，只因功底尚浅。
——仔细读过你在那个帖子中所写的代码，仍不见有所启发。所以 ...

期待有高人续帖......

onlycxb · 发表于 2015-4-17 09:28

'更正，再发一次

Sub Macro2()
Cells.Clear
Dim xml As Object, ViewState As String, S As String, url As String
Dim Pc As Object, i, j, m
Dim html As Object, db As Object, p, TotalPages, TotalPhotos
Dim EventValidation As String

url = "http://www.cfh.ac.cn/Album/ShowAlbum.aspx?albumid=4b7af393-99db-4461-a7c5-daa98b9384e5&Username=arisaema"
Set xml = CreateObject("msxml2.xmlhttp")
m = 0
Do
      p = p + 1
      With xml
         .Open "GET", url, False
         .Send
         '获取ViewState\EventValidation
         ViewState = encodeURI(Split(Split(.responsetext, "VIEWSTATE"" value=""")(1), """ />")(0))
         EventValidation = encodeURI(Split(Split(.responsetext, "__EVENTVALIDATION"" value=""")(1), """ />")(0))
         '获取 TotalPhotos、TotalPages
         TotalPages = CInt(Split(Split(Split(.responsetext, "当前是第")(1), "/")(1), "页")(0))
         TotalPhotos = Split(Split(.responsetext, "总共")(1), "张")(0)
         S = "__VIEWSTATE=" & ViewState
         S = S + "&__EVENTVALIDATION=" & EventValidation
         S = S + "&ctl00%24ContentPlaceHolder_body%24CurrentAlbumId=4b7af393-99db-4461-a7c5-daa98b9384e5"
         S = S + "&ctl00%24ContentPlaceHolder_body%24TotalPhotos=" & TotalPhotos
         S = S + "&ctl00%24ContentPlaceHolder_body%24TotalPages=" & TotalPages
         S = S + "&ctl00%24ContentPlaceHolder_body%24ImgBtnGoPage.x=24"
         S = S + "&ctl00%24ContentPlaceHolder_body%24ImgBtnGoPage.y=9"
         S = S + "&ctl00%24ContentPlaceHolder_body%24TxtPageSn=" & p

         .Open "POST", url, False
         .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
         .Send (S)
         S = .responsetext
      End With
      Set html = CreateObject("htmlfile")
      html.body.innerHTML = S
      Set db = html.all.tags("table")(1)
      For i = 0 To db.Rows.Length - 1
         m = m + 1
         For j = 0 To db.Rows(i).Cells.Length - 2
            Cells(m, j + 1) = Replace(db.Rows(i).Cells(j).innertext, Chr(10), "")
         Next j
      Next i
Loop Until p = TotalPages
End Sub
Function encodeURI(ByVal strText As String) As String
With CreateObject("msscriptcontrol.scriptcontrol")
      .Language = "JavaScript"
      encodeURI = .Eval("encodeURIComponent('" & strText & "');")
End With
End Function

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

[求助] 蓝天、html2013、ccwan大师看到进来看看 xmlhttp法不能翻页或IE法不能获取完整源代码

点评

评分