部分省市中高考成绩查询帖汇总

mxf21cn

Kaohsing 发表于 2018-7-9 12:05
只要代码加入容错代码，学习代码的看看思路，实际使用的自然会带入真是的学生信息。

只给代码对于想学习的人是没问题的，但本帖还是希望能帮助一些和本人一样苦逼的同行们，给他们减轻点负担，毕竟还有很多人对代码一窍不通，又有此需求。

592rmb

非常感谢老师的热心帮助和无私分享！

mxf21cn

Public Sub 四川省高考成绩查询()
     
     Dim strURL As String
     Dim strData As String
     Dim xmlHttp As Object
     
     Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
     
     For i = 2 To 20
        
        k1 = Cells(i, 1)    '考生号
        k2 = Cells(i, 2)    '准考证号
        k3 = Cells(i, 3)    '身份证号
     
        strURL = "http://wx.scedu.net/server/scedu_cj_ajax.ashx?action=GetJsResult&ksh=" & k1 & "&zkzh=" & k2 & "&sfzh=" & k3 & "&_=1530541150633"
     
        With xmlHttp
             .Open "GET", strURL, False
            .send
         
            Do While .readystate <> 4
                 DoEvents
            Loop
         
            k = Split(.ResponseText, "th%3E%3Ctd%3E")(10)
            Cells(i, 5) = Split(Split(.ResponseText, "th%3E%3Ctd%3E")(4), "%3C")(0)
            Cells(i, 6) = Split(Split(.ResponseText, "th%3E%3Ctd%3E")(5), "%3C")(0)
            Cells(i, 7) = Split(Split(.ResponseText, "th%3E%3Ctd%3E")(6), "%3C")(0)
            Cells(i, 8) = Split(Split(.ResponseText, "th%3E%3Ctd%3E")(7), "%3C")(0)
            Cells(i, 9) = Split(Split(.ResponseText, "th%3E%3Ctd%3E")(12), "%3C")(0)
        
        End With
     
     Next

End Sub

mxf21cn

Public Sub 茂名市2017年初二中考成绩查询()
'因楼主并未给出存储准考证号及输出信息格式，顾本查询只输出源代码，没有后续处理
    kh = "18098101020019"
    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://61.146.233.163/ChengJiChaXun/zkcj02.php", False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Cookie", "yy=2017; select=%C3%AF%C3%FB%CA%D02017%C4%EA%B3%F5%B6%FE%D6%D0%BF%BC%B3%C9%BC%A8%B2%E9%D1%AF; zkdata=zkcj201702"
        .send "kh=" & kh & "&submitBottonAction=isPressed"
         
        strData = .responseText
      
        Debug.Print strData
    End With
     
     
     
     
End Sub

mxf21cn

Public Sub 韶关中考查询()
'  Cells(j, 1)为考生号
'  Cells(j, 2)为身份证号
'
    Dim strURL As String
    Dim strData As String
    Dim xmlHttp As Object
   
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    For j = 2 To 4
        strURL = "http://www.sgedu.gov.cn/ItemSearch/Result.aspx?ItemId=11&keys=%e8%80%83%e7%94%9f%e5%8f%b7%24%24%24%e8%ba%ab%e4%bb%bd%e8%af%81%e5%8f%b7&values=" & Cells(j, 1) & "%24%24%24" & Cells(j, 2)
        With xmlHttp
        
        
            .Open "GET", strURL, False
            .setRequestHeader "If-Modified-Since", "0"
            .send
        
        
        
            Do While .readystate <> 4
                DoEvents
            Loop
        
      
            strData = Replace(Replace(Split(Split(.ResponseText, " <!-- X语文_KMZF -->")(2), "</tr></tbody></table>")(0), "<td style='padding:10px; border:1px solid #e4e4e4;'>", ""), Chr(10), "")
            Cells(j, 3) = Replace(Split(strData, "</td>")(0), " ", "")
            For i = 4 To 14
                strData1 = Replace(Split(Split(strData, "</td>")(i - 3), ">")(1), " ", "")
                Cells(j, i) = strData1
            Next
            Debug.Print strData1
            
            
        End With
    Next
   
   
   
   
End Sub

mxf21cn

Public Sub 陕西高考查询()
'动态参数ken的获取是失败的主要原因
'Cells(rowi, 1),Cells(rowi, 2),Cells(rowi, 3)分别对应准考证号，身份证号，密码
   
    Dim strURL As String
    Dim strData As String
    Dim xmlHttp As Object
   
    'Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    Set xmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
   
    strURL = "https://www.sneac.edu.cn/pzcjweb/cjcx/srindex.jsp"
   
    Set oDoc = CreateObject("htmlfile")
   
    With xmlHttp
        For rowi = 4 To 4
            .Open "GET", "https://www.sneac.edu.cn/pzcjweb/cjcx/srindex.jsp", False
            .setRequestHeader "If-Modified-Since", "0"
            .send
            
            ken = Split(Split(Split(.responseText, "token")(1), "value=""")(1), """>")(0)
            
            
            .Open "POST", "https://www.sneac.edu.cn/pzcjweb/cjcx/kssr.jsp", False
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"                 '一般可以不用修改
            .setRequestHeader "If-Modified-Since", "0"                                            '不读缓存
            .send "KSH=" & Cells(rowi, 1) & "&SFZH=" & Cells(rowi, 2) & "&PASSWORD=" & Cells(rowi, 3) & "&SECURITYCODE=&token=" & ken ' 在使用  POST  方式时要才使用.send  strData
            
            oDoc.body.innerHTML = .responseText
            
            Set tr = oDoc.all.tags("Table")(2).Rows
            
            For ci = 0 To 6
                Cells(rowi, ci + 5) = tr(ci + 2).Cells(1).innerText
            
            Next
        
        Next
   
    End With

End Sub

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

mxf21cn

Public Sub 承德2018中考成绩查询()
    Dim strURL As String
    Dim strData As String
    Dim xmlHttp As Object
   
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    strURL = "http://zsks.cdcedu.cn/InfoCx_Result.aspx"
    Set oDoc = CreateObject("htmlfile")
'--------------------------------------------------------------------------------------------------------
   
'--------------------------------------------------------------------------------------------------------
    With xmlHttp
        For rowi = 2 To 10
            .Open "POST", strURL, False
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"                 '一般可以不用修改
            .setRequestHeader "Referer", "http://zsks.cdcedu.cn/"                             '进行防盗链处理
            .setRequestHeader "Cookie", "Hm_lvt_a1a2049db19308d35c239268febaca2d=1530603953,1531062375,1531097425; Hm_lpvt_a1a2049db19308d35c239268febaca2d=1531231804"
            .setRequestHeader "If-Modified-Since", "0"                                            '不读缓存
            .send "id=159&number=" & Cells(rowi, 1) & "&xm=" & Cells(rowi, 2) ' 在使用  POST  方式时要才使用.send  strData
            
            
            
            Do While .readystate <> 4
                DoEvents
            Loop
            
            oDoc.body.innerHTML = .responseText
            Set tr = oDoc.all.tags("Table")(1).Rows
            
            For ci = 0 To 13
                Cells(rowi, ci + 4) = tr(1).Cells(ci).innerText
            Next
        Next
    End With
   
   
   
   
End Sub

mxf21cn

Public Sub 安徽高考查询()
'该验证码为文本格式，不是图片，比较好处理
'Cells(rowi, 1),Cells(rowi, 2)分别对应考生号，身份证号
   
     Dim strURL As String
     Dim strData As String
     Dim xmlHttp As Object
     
     'Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
     Set xmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
     
     strURL = "http://cx.ahzsks.cn/pugao/pgcj2018_in.php"
     
     Set oDoc = CreateObject("htmlfile")
     
     With xmlHttp
         For rowi = 2 To 2
             .Open "GET", "http://cx.ahzsks.cn/pugao/pgcj2018_in.php", False
             .setRequestHeader "If-Modified-Since", "0"
             .send
            
            
             yzm = Split(Split(Split(.responsetext, "id=""yzm""")(1), "/>")(1), "</div>")(0)
            
             .Open "POST", "http://cx.ahzsks.cn/pugao/pgcj2018_out.php", False
             .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"                 '一般可以不用修改
            .setRequestHeader "If-Modified-Since", "0"                                            '不读缓存
            .send "ksh=" & Cells(rowi, 1) & "&sfzh=" & Cells(rowi, 2) & "&yzm=" & yzm ' 在使用  POST  方式时要才使用.send  strData
            
             oDoc.body.innerHTML = Replace(StrConv(.responseBody, vbUnicode), "&nbsp;", "")
             Set tr = oDoc.all.tags("Table")(0).Rows
            
             Cells(rowi, 3) = Split(tr(0).Cells(0).innerText, "：")(2)
            
             Cells(rowi, 4) = tr(1).Cells(1).innerText
             Cells(rowi, 5) = tr(1).Cells(3).innerText
            
             Cells(rowi, 6) = tr(3).Cells(1).innerText
             Cells(rowi, 7) = tr(3).Cells(2).innerText
            
             Cells(rowi, 8) = tr(4).Cells(1).innerText
             Cells(rowi, 9) = tr(4).Cells(2).innerText
            
             Cells(rowi, 10) = tr(5).Cells(1).innerText
             Cells(rowi, 11) = tr(5).Cells(2).innerText
            
             Cells(rowi, 12) = tr(6).Cells(1).innerText
             Cells(rowi, 13) = tr(6).Cells(2).innerText
            
            
         
         Next
     
     End With

End Sub

zhxdida

感谢分享。。