网页批量查成绩的问题

jimcomputer

网址是：http://zfkaoshi.17el.cn/ksgltest/chengji.jsp

查询姓名和身份证号码分别在excel表中，一个一个查询非常不方便，想批量查询，更重要的是，查询结果还是一张图片，请问如何批量把这些图片以姓名命名保存下来，或者识别图片中的分数直接记录到excel表中那就最好了。

实验1.rar (6.55 KB, 下载次数: 13)

2016-12-20 19:31 上传

点击文件名下载附件
名册

罗术威	男	430121197004264636
李海洋	男	430121197006135512
梁军山	男	430121197211073613

若能解决，不胜感激！

northwolves

IE+ OCR

jimcomputer

请高人指点！

huang1314wei

做个记号，有时间帮你写一下

huang1314wei

1. Sub test()
   
2.     Dim URL$, SendData$, ResData$, i%, Data$, arr
   
3.     arr = Range("A1").CurrentRegion
   
4.     URL = "http://zfkaoshi.17el.cn/ksgltest"
   
5.     With CreateObject("MsXml2.xmlhttp")
   
6.         For i = 2 To UBound(arr)
   
7.             SendData = "xm=" & UrlEncode(arr(i, 1)) & "&sfz=" & arr(i, 2)
   
8.             .Open "Post", URL & "/queryScore", False
   
9.             .setrequestheader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
   
10.             .setrequestheader "Connection", "keep-alive"
    
11.             .send SendData
    
12.             ResData = "<tr><td><img src=""" & URL & "/" & Trim(.responsetext) & """/></td></tr>"
    
13.             Data = IIf(Data = "", ResData, Data & ResData)
    
14.         Next
    
15.     End With
    
16.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
17.         .settext "<table>" & Data & "</table>"
    
18.         .putinclipboard
    
19.     End With
    
20.     [C2].Select
    
21.     ActiveSheet.Paste
    
22.     Range("A1").CurrentRegion.RowHeight = 116
    
23.     [A1].Select
    
24. End Sub
    
25. 
    
26. Public Function UrlEncode(ByVal szString As String) As String
    
27.        Dim szChar   As String
    
28.        Dim szTemp   As String
    
29.        Dim szCode   As String
    
30.        Dim szHex    As String
    
31.        Dim szBin    As String
    
32.        Dim iCount1  As Integer
    
33.        Dim iCount2  As Integer
    
34.        Dim iStrLen1 As Integer
    
35.        Dim iStrLen2 As Integer
    
36.        Dim lResult  As Long
    
37.        Dim lAscVal  As Long
    
38.        szString = Trim$(szString)
    
39.        iStrLen1 = Len(szString)
    
40.        For iCount1 = 1 To iStrLen1
    
41.            szChar = Mid$(szString, iCount1, 1)
    
42.            lAscVal = AscW(szChar)
    
43.            If lAscVal >= &H0 And lAscVal <= &HFF Then
    
44.               If (lAscVal >= &H30 And lAscVal <= &H39) Or _
    
45.                  (lAscVal >= &H41 And lAscVal <= &H5A) Or _
    
46.                  (lAscVal >= &H61 And lAscVal <= &H7A) Then
    
47.                  szCode = szCode & szChar
    
48.               Else
    
49.                
    
50.                  szCode = szCode & "%" & Hex(AscW(szChar))
    
51.               End If
    
52.            Else
    
53.               szHex = Hex(AscW(szChar))
    
54.               iStrLen2 = Len(szHex)
    
55.               For iCount2 = 1 To iStrLen2
    
56.                   szChar = Mid$(szHex, iCount2, 1)
    
57.                   Select Case szChar
    
58.                          Case Is = "0"
    
59.                               szBin = szBin & "0000"
    
60.                          Case Is = "1"
    
61.                               szBin = szBin & "0001"
    
62.                          Case Is = "2"
    
63.                               szBin = szBin & "0010"
    
64.                          Case Is = "3"
    
65.                               szBin = szBin & "0011"
    
66.                          Case Is = "4"
    
67.                               szBin = szBin & "0100"
    
68.                          Case Is = "5"
    
69.                         szBin = szBin & "0101"
    
70.                          Case Is = "6"
    
71.                               szBin = szBin & "0110"
    
72.                          Case Is = "7"
    
73.                               szBin = szBin & "0111"
    
74.                          Case Is = "8"
    
75.                               szBin = szBin & "1000"
    
76.                          Case Is = "9"
    
77.                               szBin = szBin & "1001"
    
78.                          Case Is = "A"
    
79.                               szBin = szBin & "1010"
    
80.                          Case Is = "B"
    
81.                               szBin = szBin & "1011"
    
82.                          Case Is = "C"
    
83.                               szBin = szBin & "1100"
    
84.                          Case Is = "D"
    
85.                               szBin = szBin & "1101"
    
86.                          Case Is = "E"
    
87.                               szBin = szBin & "1110"
    
88.                          Case Is = "F"
    
89.                               szBin = szBin & "1111"
    
90.                          Case Else
    
91.                   End Select
    
92.               Next iCount2
    
93.               szTemp = "1110" & Left$(szBin, 4) & "10" & Mid$(szBin, 5, 6) & "10" & Right$(szBin, 6)
    
94.               For iCount2 = 1 To 24
    
95.                   If Mid$(szTemp, iCount2, 1) = "1" Then
    
96.                      lResult = lResult + 1 * 2 ^ (24 - iCount2)
    
97.                   Else: lResult = lResult + 0 * 2 ^ (24 - iCount2)
    
98.                   End If
    
99.               Next iCount2
    
100.               szTemp = Hex(lResult)
     
101.                     szCode = szCode & "%" & Left$(szTemp, 2) & "%" & Mid$(szTemp, 3, 2) & "%" & Right$(szTemp, 2)
     
102.            End If
     
103.            szBin = vbNullString
     
104.            lResult = 0
     
105.        Next iCount1
     
106.        UrlEncode = szCode
     
107. End Function

复制代码

huang1314wei

代码在审核，附件参考

附件参考.rar (20.49 KB, 下载次数: 50)

2016-12-21 20:25 上传

点击文件名下载附件

jimcomputer

huang1314wei 发表于 2016-12-21 20:25
代码在审核，附件参考

非常感谢，但暂时还没有成功。

huang1314wei

jimcomputer 发表于 2016-12-21 21:31
非常感谢，但暂时还没有成功。

那是你自己的问题哦，我这里测试N次，N次成功，都能抓取到图片到相应位置

sac100

SendData改成(SendData)

huang1314wei

jimcomputer 发表于 2016-12-21 21:31
非常感谢，但暂时还没有成功。