用EXCEL实现网页上批量查询发票(谢谢lsftest,xmlhttp,IE/webbrowser,webquery均做出)

xmyjk

明白，好的，受教了，谢谢了

120HYH

我的意思只是取数，不弹出网页。就是这样。哈哈。

wkbu

留下脚印，进一步学习！

lsftest

原帖由 120HYH 于 2011-1-11 20:26 发表
我的意思只是取数，不弹出网页。就是这样。哈哈。

呵呵，走运，那网站服务器没有再校验验证码，省了很多事。。。按上面连接里说的在excel里用webquery应该很轻松就搞好了吧。。
既然可以绕过验证码，如果想提高速度，也是和给楼主的建议一样，使用xmlhttp去搞，速度会快很多。。。具体方法上网找找，我就不说了。。
最后还是那句，那是政府网站，不要干坏事，否则我也成帮凶了。。。批量查询也最好选在网络非繁忙时间去做。。。

xmyjk

呵呵，明白了
放心，我们也是按政府的要求，去查验客户的发票的真实性，才不得不去查询的
只是一次要查好几百张，那个工作量实在恐怖，而且查完了还要打印存档
现在有了工具，后勤人员只要存电子档或仅仅打印EXcel文档，又环保
谢谢了。

120HYH

XMYJK兄帮我搞出来。省事啊。我不会弄这玩艺

120HYH

有会弄的朋友不？

xmyjk

抽空研究了下XMLHTTP的做法，成功做出来了，如附件
也感谢lsftest的指点。

[ 本帖最后由 xmyjk 于 2011-1-27 14:37 编辑 ]

xmyjk

1. Option Explicit
   
2. Sub chaxun()
   
3. Dim xmlhttp As Object
   
4. Dim intnum As Integer
   
5. Dim i As Integer
   
6. Dim strdaima As String
   
7. Dim strhaoma As String
   
8. Dim getpage As String
   
9. Dim stra As String
   
10. Dim strb(4) As String
    
11. 
    
12. intnum = Application.WorksheetFunction.CountA([A:A])
    
13. For i = 1 To intnum - 1
    
14. Cells(2, 3).Value = "正在查询第" & i & "张"
    
15. Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
    
16. strdaima = Cells(i + 1, 1).Value
    
17. strhaoma = Cells(i + 1, 2).Value
    
18. xmlhttp.Open "get", "http://www.xm-n-tax.gov.cn/BrowseServlet?szsat.trancode=101007&szsat.errpage=%2Fjsp%2Finternet%2Findex%2FerrPage.jsp&szsat.normalpage=%2Fjsp%2Finternet%2Finforservice%2Fidentifyout.jsp&szsat.fpzw.fplx=&szsat.fpzw.fpdm=" & strdaima & "&szsat.fpzw.fphm=" & strhaoma, False
    
19. xmlhttp.setRequestHeader "Content-Type", "text/html"
    
20. xmlhttp.Send ""
    
21. Do Until xmlhttp.ReadyState = 4
    
22. DoEvents
    
23. Loop
    
24. If xmlhttp.Status = 200 Then
    
25. getpage = xmlhttp.responseText
    
26. stra = Replace(Mid(getpage, InStr(getpage, "纳税人识别号："), InStr(getpage, "</font></td>") - InStr(getpage, "纳税人识别号：")), "src=" & Chr(34) & "/jsp/internet/images/main_reddian.gif" & Chr(34) & " width=" & Chr(34) & "6" & Chr(34) & " height=" & Chr(34) & "10" & Chr(34) & ">", "[")
    
27. strb(0) = Replace(Split(stra, "[")(0), "</td>", "]")
    
28. strb(1) = Replace(Split(stra, "[")(1), "</td>", "]")
    
29. strb(2) = Replace(Split(stra, "[")(2), "</td>", "]")
    
30. strb(3) = Replace(Split(stra, "[")(3), "</td>", "]")
    
31. strb(4) = Replace(Split(stra, "[")(4), "</td>", "]")
    
32. Cells(i + 1, 4).Value = Trim(Mid(Split(strb(0), "]")(1), InStr(Split(strb(0), "]")(1), ">") + 1, Len(Split(strb(0), "]")(1))))
    
33. Cells(i + 1, 5).Value = Trim(Mid(Split(strb(1), "]")(1), InStr(Split(strb(1), "]")(1), ">") + 1, Len(Split(strb(1), "]")(1))))
    
34. Cells(i + 1, 6).Value = Trim(Mid(Split(strb(2), "]")(1), InStr(Split(strb(2), "]")(1), ">") + 1, Len(Split(strb(2), "]")(1))))
    
35. Cells(i + 1, 7).Value = Trim(Mid(Split(strb(3), "]")(1), InStr(Split(strb(3), "]")(1), ">") + 1, Len(Split(strb(3), "]")(1))))
    
36. Cells(i + 1, 8).Value = Trim(Mid(Split(strb(4), "]")(1), InStr(Split(strb(4), "]")(1), ">") + 1, Len(Split(strb(4), "]")(1))))
    
37. Cells(i + 1, 9).Value = Trim(Mid(Split(strb(4), "]")(3), InStr(Split(strb(4), "]")(3), "0000") + 7, InStr(Split(strb(4), "]")(3), "！") - InStr(Split(strb(4), "]")(3), "0000") - 6))
    
38. 
    
39. Set xmlhttp = Nothing
    
40. getpage = Empty
    
41. Else
    
42.   reportErr (xmlhttp.Status)
    
43. End If
    
44. Next i
    
45. 
    
46. Cells(2, 3).Value = "查询完毕！"
    
47. MsgBox "OK"
    
48. Cells(2, 3).Value = "查询状态提示栏"
    
49. 
    
50. End Sub
    
51. 
    
52. Sub reportErr(lStatus As Integer)
    
53.         Select Case lStatus
    
54.             Case 400
    
55.                 MsgBox "Bad Request", vbCritical, "连接错误"
    
56.             Case 401
    
57.                 MsgBox "Unauthorized", vbCritical, "连接错误"
    
58.             Case 402
    
59.                 MsgBox "Payment Required", vbCritical, "连接错误"
    
60.             Case 403
    
61.                 MsgBox "Forbidden", vbCritical, "连接错误"
    
62.             Case 404
    
63.                 MsgBox "Not Found", vbCritical, "连接错误"
    
64.             Case 407
    
65.               MsgBox "Proxy Authentication Required", vbCritical, "连接错误"
    
66.             Case 408
    
67.                 MsgBox "Request Timeout", vbCritical, "连接错误"
    
68.             Case 503
    
69.                 MsgBox "Service Unavailable", vbCritical, "连接错误"
    
70.             Case Else
    
71.               MsgBox "Can not reach by other reason", vbCritical, "连接错误"
    
72.         End Select
    
73. End Sub

复制代码

[ 本帖最后由 xmyjk 于 2011-1-28 10:10 编辑 ]

lsftest

原帖由 xmyjk 于 2011-1-27 14:40 发表
Sub chaxun()
Dim xmlhttp As Object, objstream As Object
Dim intnum As Integer
Dim i As Integer
Dim strdaima As String
Dim strhaoma As String
Dim getpage As String
Dim stra As String
Dim strb() ...

呵呵，恭喜恭喜。。。
如果有时间想进一步优化，就看看正则表达式的东西吧，对数据提取有很大帮助，语句会简洁很多。。