求大神帮忙改进高考成绩查询代码

yangzehao

是云南省2017年高考成绩的查询，网址http://www.ynzs.cn/2017gkcf/web.html
用来练手
小弟研究了一天，各种学习和改进代码（其实就是把论坛大神们的代码复制粘贴出来学习）
只能做到让VBA自动打开网址，填入考号和密码，然后点击查询按钮出现成绩页面。

后续的提取相应成绩到对应格子就不会做了，求大神指导和改进。。如果可以做成循环就更好了，谢谢

文件在附件里，已经提供了4个尝试用的考号和密码

2489586288

见附件，瞎捣鼓的

yangzehao

非常感谢，但是1楼这个文件执行之后，生成的新工作表中只有格子没有数据，最后的合并步骤会卡住。。。

mxf21cn

Public Sub cx()
    Dim strURL As String
    Dim strData As String
    Dim xmlHttp As Object
   
   
    'Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    Set xmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    With xmlHttp
        
        
        .Open "POST", "http://www.ynzs.cn/2017gkcf/check.php?action=query", False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Referer", "http://www.ynzs.cn/2017gkcf/web.html"
        .setRequestHeader "Cookie", "CNZZDATA5457195=cnzz_eid%3D24226550-1530624128-%26ntime%3D1530714216; PHPSESSID=fpi8fa0srsmp2ecqaarlq6ngs7; UM_distinctid=16460561fb3d-01d889be24bdcf4-1d317173-1fa400-16460561fb474"

        .send "user=252651640&pass=888888"
        
        strData = Replace(Replace(Replace(Split(.responseText, "url")(1), "}", ""), """:", ""), """", "")
        strData = Replace(strData, "\", "")
        
        .Open "GET", strData, False
        .send
      
        Debug.Print .responseText
        'Debug.Print strData
    End With
   
   
   
   
End Sub

能获取网页，但有乱码， 也就没在继续，坐等高手

Kaohsing

mxf21cn 发表于 2018-7-4 23:22
Public Sub cx()
    Dim strURL As String
    Dim strData As String

转个码就可以啦

       Public Sub cx()
    Dim strURL As String
    Dim strData As String
    Dim xmlHttp As Object
    Dim sHtml$
    Set xmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    With xmlHttp
        .Open "POST", "http://www.ynzs.cn/2017gkcf/check.php?action=query", False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Referer", "http://www.ynzs.cn/2017gkcf/web.html"
        .setRequestHeader "Cookie", "CNZZDATA5457195=cnzz_eid%3D24226550-1530624128-%26ntime%3D1530714216; PHPSESSID=fpi8fa0srsmp2ecqaarlq6ngs7; UM_distinctid=16460561fb3d-01d889be24bdcf4-1d317173-1fa400-16460561fb474"
        .send "user=252651640&pass=888888"
        strData = Replace(Replace(Replace(Split(.responseText, "url")(1), "}", ""), """:", ""), """", "")
        strData = Replace(strData, "\", "")
        .Open "GET", strData, False '
        .send
       sHtml = Replace(ByteToStr(.responsebody, "UTF-8"), "&nbsp", "")
    End With
    Dim js As Object
     Set js = CreateObject("MSScriptControl.ScriptControl")
        js.Language = "JavaScript"
        js.AddObject "rg", [A1]:         js.AddObject "r", [b2]
        js.AddCode "function ka(s){  return s.match(/>(.*?)(?=<\/td>)/gm);};"
        js.AddObject "y", js.CodeObject.ka(sHtml)
        Stop
        js.eval ("rg(1,1)='姓名',rg(1,2)='科目',rg(1,3)='科目成绩',rg(1,4)='百分比等级',rg(2,1)=y[6].replace(/>/,'');")
        js.eval ("k=1,l=y.length;for(i=7;i<l;i =i +3){ for (j=0;j<3;j++){rg(k+1,j+2)=y[i+j].replace(/>/,'').replace(/;/,'');};k++;};")
End Sub
Function ByteToStr(arrByte, strCharset As String) As String
    With CreateObject("Adodb.Stream")
        .Type = 1
        .Open
        .write arrByte
        .Position = 0
        .Type = 2
        .Charset = strCharset
        ByteToStr = .Readtext
        .Close
    End With
End Function

mxf21cn

Public Sub 云南省公考成绩查询()
'本程序的难点是真实成绩查询网址的获取
     Dim strURL As String
     Dim strData As String
     Dim xmlHttp As Object
     
     
     'Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
     Set oDoc = CreateObject("htmlfile")
     Set xmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
     
     With xmlHttp
         
        For rowi = 2 To 5
            .Open "POST", "http://www.ynzs.cn/2017gkcf/check.php?action=query", False
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .setRequestHeader "Referer", "http://www.ynzs.cn/2017gkcf/web.html"

            .send "user=" & Cells(rowi, 1) & "&pass=" & Cells(rowi, 2)
         
            strData = Replace(Replace(Replace(Split(.responseText, "url")(1), "}", ""), """:", ""), """", "")
            strData = Replace(strData, "\", "")
         
            .Open "GET", strData, False
            .send
            
            oDoc.body.innerHTML = Replace(ByteToStr(.responsebody, "UTF-8"), "&nbsp;", "")
            Set tr = oDoc.all.tags("Table")(0).Rows
            
            
            Cells(rowi, 4) = tr(1).Cells(0).innerText
            Cells(rowi, 5) = tr(1).Cells(1).innerText
            Cells(rowi, 6) = tr(1).Cells(3).innerText
            Cells(rowi, 7) = tr(2).Cells(1).innerText
            Cells(rowi, 8) = tr(3).Cells(1).innerText
            Cells(rowi, 9) = tr(4).Cells(1).innerText
            Cells(rowi, 10) = tr(5).Cells(1).innerText
            Cells(rowi, 11) = tr(6).Cells(1).innerText
            Cells(rowi, 12) = Split(tr(7).Cells(0).innerText, "：")(1)
     
        Next

     End With

End Sub

Function ByteToStr(arrByte, strCharset As String) As String
     With CreateObject("Adodb.Stream")
         .Type = 1
         .Open
         .write arrByte
         .Position = 0
         .Type = 2
         .Charset = strCharset
         ByteToStr = .Readtext
         .Close
         
     End With
     
End Function