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

onlycxb

'更正，再发一次

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

onlycxb

是不是这个效果

VBA万岁

onlycxb 发表于 2015-4-17 09:40
是不是这个效果

是这种效果。

VBA万岁

onlycxb 发表于 2015-4-17 09:28
'更正，再发一次

Sub Macro2()

终于发现了症结所在——此例我用WinHttp.WinHttpRequest.5.1组件不成功，而在onlycxb大侠的指点下用msxml2.xmlhttp组件方成功取数。不知为何？
再次感谢onlycxb大侠的大力相助！
松江钟贾山摄影取数.zip (1.21 MB, 下载次数: 25)

2015-4-17 12:06 上传

点击文件名下载附件

onlycxb

VBA万岁 发表于 2015-4-17 12:08
终于发现了症结所在——此例我用WinHttp.WinHttpRequest.5.1组件不成功，而在onlycxb大侠的指点下用msxml ...

更换Set Xml = CreateObject("WinHttp.WinHttpRequest.5.1")，效果依然

onlycxb

1. Sub Macro2()
   
2.     Cells.Clear
   
3.     Dim Xml As Object, ViewState As String, S As String, Url As String
   
4.     Dim i, j, m
   
5.     Dim html As Object, Db As Object, P, TotalPages, TotalPhotos
   
6.     Dim EventValidation As String
   
7. 
   
8.     Url = "http://www.cfh.ac.cn/Album/ShowAlbum.aspx?albumid=4b7af393-99db-4461-a7c5-daa98b9384e5&Username=arisaema"
   
9.     Set Xml = CreateObject("WinHttp.WinHttpRequest.5.1")
   
10.     m = 0
    
11.     Do
    
12.         P = P + 1
    
13.         With Xml
    
14.             .Open "GET", Url, False
    
15.             .Send
    
16.             '获取ViewState\EventValidation
    
17.             ViewState = encodeURI(Split(Split(.responsetext, "VIEWSTATE"" value=""")(1), """ />")(0))
    
18.             EventValidation = encodeURI(Split(Split(.responsetext, "__EVENTVALIDATION"" value=""")(1), """ />")(0))
    
19.             '获取 TotalPhotos、TotalPages
    
20.             TotalPages = CInt(Split(Split(Split(.responsetext, "当前是第")(1), "/")(1), "页")(0))
    
21.             TotalPhotos = Split(Split(.responsetext, "总共")(1), "张")(0)
    
22.             S = "__VIEWSTATE=" & ViewState
    
23.             S = S + "&__EVENTVALIDATION=" & EventValidation
    
24.             S = S + "&ctl00%24ContentPlaceHolder_body%24CurrentAlbumId=4b7af393-99db-4461-a7c5-daa98b9384e5"
    
25.             S = S + "&ctl00%24ContentPlaceHolder_body%24TotalPhotos=" & TotalPhotos
    
26.             S = S + "&ctl00%24ContentPlaceHolder_body%24TotalPages=" & TotalPages
    
27.             S = S + "&ctl00%24ContentPlaceHolder_body%24ImgBtnGoPage.x=24"
    
28.             S = S + "&ctl00%24ContentPlaceHolder_body%24ImgBtnGoPage.y=9"
    
29.             S = S + "&ctl00%24ContentPlaceHolder_body%24TxtPageSn=" & P
    
30. 
    
31.             .Open "POST", Url, False
    
32.             .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    
33.             .Send (S)
    
34.             S = .responsetext
    
35.         End With
    
36.         Set html = CreateObject("htmlfile")
    
37.         html.body.innerHTML = S
    
38.         Set Db = html.all.tags("table")(1)
    
39.         For i = 0 To Db.Rows.Length - 1
    
40.             m = m + 1
    
41.             For j = 0 To Db.Rows(i).Cells.Length - 2
    
42.                 Cells(m, j + 1) = Replace(Db.Rows(i).Cells(j).innertext, Chr(10), "")
    
43.             Next j
    
44.         Next i
    
45.     Loop Until P = TotalPages
    
46. End Sub
    
47. 
    
48. Function encodeURI(ByVal strText As String) As String
    
49.     With CreateObject("msscriptcontrol.scriptcontrol")
    
50.         .Language = "JavaScript"
    
51.         encodeURI = .Eval("encodeURIComponent('" & strText & "');")
    
52.     End With
    
53. End Function

复制代码

onlycxb

Sub Macro2_30楼优化后()
    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
    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)

    End With
    Do
        p = p + 1
        With xml
            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

bailanhong

onlycxb 发表于 2015-4-17 09:28
'更正，再发一次

Sub Macro2()

提示错误是怎么回事，没加载完吗？

VBA万岁

onlycxb 发表于 2015-4-17 14:02
更换Set Xml = CreateObject("WinHttp.WinHttpRequest.5.1")，效果依然

现已查明，我用WinHttp.WinHttpRequest.5.1失败是因为url写错所致。