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

bailanhong

onlycxb 发表于 2015-4-12 08:41
拜读吴姐教程吧，教程中已授渔。完整代码就不提供了，仅提示一点,senddata中，包含下述要素：
        "&c ...

吴姐那个是上传文件的，下面有一些函数，不知道那几个是不需要的

bailanhong

VBA万岁 发表于 2015-4-13 15:21
附件：

谢谢大师帮忙！！

onlycxb

bailanhong 发表于 2015-4-12 18:23
麻烦你帮我看看，是不是这种？

再示例一下。自己补充完整

1. Sub Macro1()
   
2.     Dim Viewstate As String, S As String, url As String
   
3.     Dim html As Object, db As Object
   
4.     Dim Eventvalidation As String
   
5.     url = "http://www.cfh.ac.cn/Album/ShowAlbum.aspx?albumid=4b7af393-99db-4461-a7c5-daa98b9384e5&Username=arisaema&AspxAutoDetectCookieSupport=1"
   
6.     With CreateObject("msxml2.xmlhttp")
   
7.         .Open "GET", url, False
   
8.         .send
   
9.         Viewstate = encodeURI(Split(Split(.responsetext, "VIEWSTATE"" value=""")(1), """ />")(0))
   
10.         Eventvalidation = encodeURI(Split(Split(.responsetext, "__EVENTVALIDATION"" value=""")(1), """ />")(0))
    
11.         S = "__VIEWSTATE=" & Viewstate
    
12.         S = S + "&__EVENTVALIDATION=" & Eventvalidation
    
13.         S = S + "&ctl00%24ContentPlaceHolder_body%24CurrentAlbumId=4b7af393-99db-4461-a7c5-daa98b9384e5"
    
14.         S = S + "&ctl00%24ContentPlaceHolder_body%24TotalPhotos=837"
    
15.         S = S + "&ctl00%24ContentPlaceHolder_body%24TotalPages=17"
    
16.         S = S + "&ctl00%24ContentPlaceHolder_body%24CurrentPage=1"
    
17.         S = S + "&ctl00%24ContentPlaceHolder_body%24ImgBtnNext.x=35"
    
18.         S = S + "&ctl00%24ContentPlaceHolder_body%24ImgBtnNext.y=9"
    
19.         .Open "POST", url, False
    
20.         .setrequestheader "Content-Type", "application/x-www-form-urlencoded"
    
21.         .send (S)
    
22.         S = .responsetext
    
23.     End With
    
24.     Set html = CreateObject("htmlfile")
    
25.     html.body.innerhtml = S
    
26.     Set db = html.all.tags("table")(1)
    
27.     Debug.Print db.innertext                  '为节约时间，只在立即窗口输出数据
    
28.    
    
29. End Sub
    
30. Function encodeURI(ByVal strText As String) As String
    
31.     With CreateObject("msscriptcontrol.scriptcontrol")
    
32.         .Language = "JavaScript"
    
33.         encodeURI = .Eval("encodeURIComponent('" & strText & "');")
    
34.     End With
    
35. End Function
    

复制代码

onlycxb

1. Sub Macro1()
   
2.     Dim ViewState As String, S As String, Url As String
   
3.     Dim html As Object, db As Object
   
4.     Dim EventValidation As String
   
5.     Url = "http://www.cfh.ac.cn/Album/ShowAlbum.aspx?albumid=4b7af393-99db-4461-a7c5-daa98b9384e5&Username=arisaema&AspxAutoDetectCookieSupport=1"
   
6.     With CreateObject("msxml2.xmlhttp")
   
7.         .Open "GET", Url, False
   
8.         .send
   
9.         ViewState = encodeURI(Split(Split(.responsetext, "VIEWSTATE"" value=""")(1), """ />")(0))
   
10.         EventValidation = encodeURI(Split(Split(.responsetext, "__EVENTVALIDATION"" value=""")(1), """ />")(0))
    
11.         S = "__VIEWSTATE=" & ViewState
    
12.         S = S + "&__EVENTVALIDATION=" & EventValidation
    
13.         S = S + "&ctl00%24ContentPlaceHolder_body%24CurrentAlbumId=4b7af393-99db-4461-a7c5-daa98b9384e5"
    
14.         S = S + "&ctl00%24ContentPlaceHolder_body%24CurrentPage=1"
    
15.         .Open "POST", Url, False
    
16.         .setrequestheader "Content-Type", "application/x-www-form-urlencoded"
    
17.         .send (S)
    
18.         S = .responsetext
    
19.     End With
    
20.     Set html = CreateObject("htmlfile")
    
21.     html.body.innerhtml = S
    
22.     Set db = html.all.tags("table")(1)
    
23.     Debug.Print db.innertext                            '看立即窗口输出
    
24.    
    
25. End Sub

复制代码

VBA万岁

onlycxb 发表于 2015-4-13 08:06

12、13楼的代码测试并不成功——若取多页数据，则结果均为第1页的数据。

而我用如下代码，结果取多页数据时仍都重复为第一页的数据。看来含有ViewState、EventValidation数据的网页取数对我来说仍然是一个难点，望有高人帮忙指点一二：

1. Sub test()
   
2. Dim html As Object, db As Object
   
3. Cells.Clear
   
4. Url = "http://www.cfh.ac.cn/Album/ShowAlbum.aspx?albumid=4b7af393-99db-4461-a7c5-daa98b9384e5&Username=arisaema&AspxAutoDetectCookieSupport=1"
   
5. With CreateObject("Microsoft.XMLHTTP")
   
6.     .Open "GET", Url, False
   
7.     .send
   
8.     tt = .responseText
   
9.     n = Val(Split(Split(.responseText, "总共")(1), "张")(0))
   
10.     p0 = Val(Split(Split(.responseText, "当前是第1/")(1), "页")(0))
    
11.     ViewState = encodeURI(Split(Split(tt, "__VIEWSTATE"" value=""")(1), """")(0))                           '取得VIEWSTATE的Post参数
    
12.     EventValidation = encodeURI(Split(Split(tt, "__EVENTVALIDATION"" value=""")(1), """")(0))         '取得EVENTVALIDATION的Post参数
    
13.     'For p = 1 To p0
    
14.     For p = 1 To 2
    
15.         PostData = PostData & "__VIEWSTATE=" & ViewState & "&__EVENTVALIDATION=" & EventValidation
    
16.         PostData = PostData & "&ctl00%24HiddenField_MasterUserName="
    
17.         PostData = PostData & "&ctl00%24HiddenField_VisitorUserName="
    
18.         PostData = PostData & "&ctl00%24CurrAlbumID="
    
19.         PostData = PostData & "&ctl00%24ContentPlaceHolder_body%24CurrentAlbumId=4b7af393-99db-4461-a7c5-daa98b9384e5"
    
20.         PostData = PostData & "&ctl00%24ContentPlaceHolder_body%24TotalPhotos=" & n
    
21.         PostData = PostData & "&ctl00%24ContentPlaceHolder_body%24TotalPages=" & p0
    
22.         PostData = PostData & "&ctl00%24ContentPlaceHolder_body%24CurrentPage=" & p
    
23.         PostData = PostData & "&AlbumRefUrl="
    
24.         PostData = PostData & "&ctl00%24ContentPlaceHolder_body%24TxtPageSn="
    
25.         PostData = PostData & "&ctl00%24ContentPlaceHolder_body%24ImgBtnNext.x=33"
    
26.         PostData = PostData & "&ctl00%24ContentPlaceHolder_body%24ImgBtnNext.y=9"
    
27.         .Open "POST", Url, False
    
28.         .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    
29.         .send (PostData)
    
30.         Set html = CreateObject("htmlfile")
    
31.         html.body.innerHTML = .responseText
    
32.         r0 = IIf(p = 1, 0, ActiveSheet.UsedRange.Rows.Count)
    
33.         Set r = html.all.tags("table")(1).Rows
    
34.         For i = 0 To r.Length - 1
    
35.             For j = 0 To r(i).Cells.Length - 1
    
36.                 Cells(r0 + i + 1, j + 1) = r(i).Cells(j).innertext
    
37.             Next j
    
38.         Next i
    
39.         ViewState = encodeURI(Split(Split(.responseText, "__VIEWSTATE"" value=""")(1), """")(0))                           '取得VIEWSTATE的Post参数
    
40.         EventValidation = encodeURI(Split(Split(.responseText, "__EVENTVALIDATION"" value=""")(1), """")(0))         '取得EVENTVALIDATION的Post参数
    
41.     Next p
    
42.     End With
    
43. End Sub
    
44. 
    
45. Function encodeURI(ByVal strText As String) As String
    
46.     With CreateObject("msscriptcontrol.scriptcontrol")
    
47.         .Language = "JavaScript"
    
48.         encodeURI = .Eval("encodeURIComponent('" & strText & "');")
    
49.     End With
    
50. End Function
    

复制代码

VBA万岁

VBA万岁 发表于 2015-4-13 15:14
12、13楼的代码测试并不成功——若取多页数据，则结果均为第1页的数据。

而我用如下代码，结果取多页数 ...

附件：
松江钟贾山取数.zip (596.4 KB, 下载次数: 15)

2015-4-13 15:20 上传

点击文件名下载附件

bailanhong

onlycxb 发表于 2015-4-13 08:06

谢谢大师帮助！！

VBA万岁

bailanhong 发表于 2015-4-13 20:35
谢谢大师帮忙！！

现提供两种IE法（缺点是需加延时，而且获取的数据不稳定）

1. Sub IE获取摄影数据1()
   
2. Cells.Clear
   
3. 'On Error Resume Next
   
4. With CreateObject("internetexplorer.application")
   
5.     .Visible = True
   
6.     .Navigate "http://www.cfh.ac.cn/Album/ShowAlbum.aspx?albumid=4b7af393-99db-4461-a7c5-daa98b9384e5&Username=arisaema&AspxAutoDetectCookieSupport=1"
   
7.     Do Until .ReadyState = 4
   
8.         DoEvents
   
9.     Loop
   
10.     For p = 1 To 2
    
11.         .Document.all.tags("input")("ctl00$ContentPlaceHolder_body$ImgBtnNext").Click
    
12.         Do Until .ReadyState = 4
    
13.             DoEvents
    
14.         Loop
    
15.         t1 = Timer
    
16.         Do Until Timer > t1 + 10
    
17.         Loop
    
18.         r0 = IIf(p = 1, 0, ActiveSheet.UsedRange.Rows.Count)
    
19.         Set r = .Document.all.tags("table")(1).Rows
    
20.         For i = 0 To r.Length - 1
    
21.             For j = 0 To r(i).Cells.Length - 1
    
22.                 Cells(r0 + i + 1, j + 1) = r(i).Cells(j).innertext
    
23.             Next j
    
24.         Next i
    
25.     Next p
    
26. End With
    
27. End Sub

复制代码

VBA万岁

VBA万岁 发表于 2015-4-14 15:45
现提供两种IE法（缺点是需加延时，而且获取的数据不稳定）

1. Sub IE获取摄影数据2()
   
2. On Error Resume Next
   
3. Cells.Clear
   
4. With CreateObject("internetexplorer.application")
   
5.     .Visible = True
   
6.     .Navigate "http://www.cfh.ac.cn/Album/ShowAlbum.aspx?albumid=4b7af393-99db-4461-a7c5-daa98b9384e5&Username=arisaema&AspxAutoDetectCookieSupport=1"
   
7.     Do Until .ReadyState = 4
   
8.         DoEvents
   
9.     Loop
   
10. 
    
11.     Set r = .Document.all.tags("table")(1).Rows
    
12.     For i = 0 To r.Length - 1
    
13.         For j = 0 To r(i).Cells.Length - 1
    
14.             Cells(i + 1, j + 1) = r(i).Cells(j).innertext
    
15.         Next j
    
16.     Next i
    
17.     For k = 2 To 2
    
18.         n = Range("a65536").End(xlUp).Row
    
19.         .Document.all("ctl00$ContentPlaceHolder_body$TxtPageSn").Value = k
    
20.         .Document.all("ctl00$ContentPlaceHolder_body$ImgBtnGoPage").Click
    
21.         Do Until .ReadyState = 4
    
22.             DoEvents
    
23.         Loop
    
24.         t1 = Timer
    
25.         Do Until Timer > t1 + 10
    
26.         Loop
    
27.         Set r = .Document.all.tags("table")(1).Rows
    
28.         For i = 0 To r.Length - 1
    
29.             For j = 0 To r(i).Cells.Length - 1
    
30.                 Cells(i + n + 1, j + 1) = r(i).Cells(j).innertext
    
31.             Next j
    
32.         Next i
    
33.     Next k
    
34. End With
    
35. End Sub

复制代码

bailanhong

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

非常感谢！！！