高手们，求批量查分和导入表格中

swtax

高考查分.zip (17.11 KB, 下载次数: 18)

2024-3-1 06:51 上传

点击文件名下载附件

  查询网网址http://cx.ahzsks.cn/pugao/2024/pgcj2024yanlian_in-13a9ff06-3218-478b-8c21-deb1bf4520d7.php

user湫

有没有模拟数据，有的话可以尝试一下

user湫

1. Sub SubmitForm()
   
2.     Dim yzm As String
   
3.     Dim myurlin As String, myurlout As String
   
4.     Dim HTTPReq
   
5.     Dim htmlStr As String
   
6.     Dim arrScore(1 To 6)
   
7.     Dim arrS
   
8.     Dim s As String
   
9.     Dim sht As Worksheet
   
10.     Dim postData As String
    
11.    
    
12.     On Error Resume Next
    
13.     Set sht = Sheets("Sheet2")
    
14.     Set HTTPReq = New MSXML2.XMLHTTP60
    
15.    
    
16.     '定义被提交的URL地址
    
17.     myurlin = "http://cx.ahzsks.cn/pugao/2024/pgcj2024yanlian_in-13a9ff06-3218-478b-8c21-deb1bf4520d7.php"
    
18.     myurlout = "http://cx.ahzsks.cn/pugao/2024/pgcj2024yanlian_out-13a9ff06-3218-478b-8c21-deb1bf4520d7.php"
    
19.    
    
20.     For r = 2 To sht.Range("A1").End(xlDown).Row
    
21.       
    
22.         HTTPReq.Open "GET", myurlin, False
    
23.         HTTPReq.send
    
24.         
    
25.         ' 等待响应完成
    
26.         Do While HTTPReq.ReadyState <> 4 Or Len(HTTPReq.responseText) < 3000
    
27.             DoEvents
    
28.         Loop
    
29.       
    
30.         If HTTPReq.ReadyState = 4 And HTTPReq.Status = 200 Then
    
31.             htmlStr = HTTPReq.responseText
    
32.         End If
    
33. 
    
34.         yzm = 获取字段("4""/>[\s\S]+?", "[\s\S]+?<", htmlStr)
    
35.       postData = "sfzh=" & sht.Cells(r, "B") & "&xm=" & sht.Cells(r, "D") & "&ksh=" & sht.Cells(r, "C") & "&yzm=" & yzm
    
36. '      Debug.Print postData
    
37.       
    
38.       '打开XMLHttpRequest对象
    
39.       HTTPReq.Open "POST", myurlout, False
    
40.       
    
41.       '设置POST请求头
    
42.       HTTPReq.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
    
43.       '发送POST请求
    
44.       HTTPReq.send (postData)
    
45.       '输出响应信息
    
46.       htmlStr = HTTPReq.responseText
    
47.       Debug.Print htmlStr
    
48.       htmlStr = Replace(htmlStr, Chr(10), "")
    
49.       arrS = Split(htmlStr, "<tr align=""center"">")
    
50.       For i = 3 To UBound(arrS) - 1
    
51.         s = arrS(i)
    
52.         sht.Cells(r, i + 2) = 获取字段("<td colspan='2'>", "</td>", s)
    
53.       Next i
    
54.       sht.Cells(r, 9) = Split(Split(arrS(1), "</td>")(1), ">")(1) '总分
    
55.       sht.Cells(r, 10) = Split(Split(arrS(1), "</td>")(3), ">")(1)
    
56.     Next r
    
57.     Debug.Print "结束"
    
58. End Sub
    
59. Private Function 获取字段(str1 As String, str2 As String, Str As String) As String
    
60.     On Error Resume Next
    
61.     Dim RegExp As Object
    
62.     Set RegExp = CreateObject("vbscript.regexp")
    
63.     With RegExp
    
64.    
    
65.         .Global = False
    
66.         .IgnoreCase = False
    
67.         .Pattern = str1 & "(\d\d\d\d)" & str2
    
68.         获取字段 = .Execute(Str)(0).submatches(0)
    
69.     End With
    
70. End Function
    

复制代码

user湫

已经可以获取了

cai2532

这个厉害，能教教下方法吗？

user湫

cai2532 发表于 2024-3-1 12:25
这个厉害，能教教下方法吗？

https://club.excelhome.net/thread-1159783-1-1.html

A刘志勇

user湫 发表于 2024-3-1 10:22
已经可以获取了

可以学习了

swtax

user湫 发表于 2024-3-1 10:22
已经可以获取了

这个每年只要变化查分地址，还能用哟

swtax

swtax 发表于 2024-3-1 18:40
这个每年只要变化查分地址，还能用哟

非常感谢。在这学习不少东西

swtax

user湫 发表于 2024-3-1 10:22

你好，上次是2024的高考预考分数查询，可这次安徽的分类考试成绩就不行了。求解？我用这次的网址了