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

lsftest

原帖由 rjg 于 2011-2-11 23:47 发表
验证网址：http://www.12366.ha.cn/server/fpzwcx/index.jsp#tt
测试：发票代码：141001050062     发票号码：29807374
方式：webQuery

谢谢！

楼主短信收到。。。
呵呵。。。这个有点意思了。。。
等会儿我试试。。。搞完这个，也应该是时候又再暂别eh了。。。。

xmyjk

嘿嘿，谢谢了。
又麻烦您老人家出来救场。
谢谢老师了。新年快乐：）

[ 本帖最后由 xmyjk 于 2011-2-12 18:44 编辑 ]

lsftest

1. Sub chaxun()
   
2. Dim xmlhttp As Object
   
3. Dim getpage As String
   
4. Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
   
5. xmlhttp.Open "post", "http://www.12366.ha.cn//dwr/plaincall/callejb.getResultsetFpzw.dwr", False
   
6. a = "callCount=1" & Chr(10)
   
7. a = a + "httpSessionId=NWznZnhZ5GKxW62RpQhnj7hyn8VKJCGx1VmvCvyT75BQxYbG2yvD!-1138754356!1297494887928" + Chr(10)
   
8. a = a + "scriptSessionId=82C832182E9958726D69C44E2D4128AB" + Chr(10)
   
9. a = a + "page=/server/fpzwcx/index.jsp" + Chr(10)
   
10. a = a + "c0-scriptName=callejb" + Chr(10)
    
11. a = a + "c0-methodName=getResultsetFpzw" + Chr(10)
    
12. a = a + "c0-id=7161_1297495974155" + Chr(10)
    
13. a = a + "c0-param0=string:getFpzw" + Chr(10)
    
14. a = a + "c0-e1=string:141001050062" + Chr(10)
    
15. a = a + "c0-e2=string:29807374" + Chr(10)
    
16. a = a + "c0-param1=Object:{FPDM:reference:c0-e1, FPHM:reference:c0-e2}" + Chr(10)
    
17. xmlhttp.Send a
    
18. Do Until xmlhttp.ReadyState = 4
    
19. DoEvents
    
20. Loop
    
21. If xmlhttp.Status = 200 Then
    
22.   getpage = xmlhttp.responseText
    
23.   Debug.Print xmlhttp.responseText
    
24. Else
    
25.   MsgBox xmlhttp.statusText
    
26. End If
    
27. End Sub

复制代码

返回的东西中文字有Unicode编码，自己上网找转换代码。。。
呵呵。。。是说再见的时候了。。。大家新年快乐，后会有期。。。

[ 本帖最后由 lsftest 于 2011-2-12 19:42 编辑 ]

xmyjk

谢谢老师，祝顺利：）

rjg

谢谢lsftest老师！
    为什么无法使用！我测试无法返回信息！请再指教！

goldowl2011

非常感谢，学习了新的用法。

xmyjk

测试的数据返回在立即窗口里面，如下：
<?xml version=\"1.0\" encoding=\"gb2312\"?>
<RECORDS><RECORD>\r\n  
<NSRDZDAH>410010002711245015</NSRDZDAH>\r\n  
<NSRSBH>41060319860905053X00</NSRSBH>\r\n     ------领购纳税人识别号
<NSRMC>\u9E64\u58C1\u5E02\u5F00\u53D1\u533A\u6797\u590F\u7EA2\u7C73\u8BBF</NSRMC>\r\n      ----领购纳税人名称
<NSRZT_DM>21</NSRZT_DM>\r\n  
<NSRZT_MC>\u5F00\u4E1A</NSRZT_MC>\r\n   --------领购纳税人状态
<FPZL_MC>\u901A\u7528\u5B9A\u989D\u53D1\u7968\uFF08\u4F0D\u62FE\u5143\uFF09</FPZL_MC>\r\n   ---------------发票名称
<BS>1</BS>\r\n  
<FP_DM>141001050062</FP_DM>\r\n  
<FPHM>29807374</FPHM>\r\n  
<FPQH>29807351</FPQH>\r\n  
<FPZH>29807400</FPZH>\r\n
</RECORD></RECORDS>

\u后面是四位Unicode编码，转成中文就能显示了  例如9E64代表：鹤  5F00代表：开

[ 本帖最后由 xmyjk 于 2011-2-12 23:56 编辑 ]

xmyjk

代码如下，excel见附件。

1. Option Explicit
   
2. 
   
3. Sub chaxun()
   
4. Dim xmlhttp As Object
   
5. Dim a As Variant
   
6. Dim fpdm As String
   
7. Dim fphm As String
   
8. Dim getpage As String
   
9. Dim intnum As Integer
   
10. Dim i As Integer
    
11. Dim j As Integer
    
12. Dim k As Integer
    
13. Dim l As Integer
    
14. 
    
15. intnum = Application.WorksheetFunction.CountA([A:A])
    
16. For i = 1 To intnum - 1
    
17. Cells(2, 3).Value = "正在查询第" & i & "张"
    
18. 
    
19. fpdm = Cells(i + 1, 1).Value
    
20. fphm = Cells(i + 1, 2).Value
    
21. 
    
22. Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
    
23. xmlhttp.Open "post", "http://www.12366.ha.cn//dwr/plaincall/callejb.getResultsetFpzw.dwr", False
    
24. a = "callCount=1" & Chr(10)
    
25. a = a & "httpSessionId=NWznZnhZ5GKxW62RpQhnj7hyn8VKJCGx1VmvCvyT75BQxYbG2yvD!-1138754356!1297494887928" & Chr(10)
    
26. a = a & "scriptSessionId=82C832182E9958726D69C44E2D4128AB" & Chr(10)
    
27. a = a & "page=/server/fpzwcx/index.jsp" & Chr(10)
    
28. a = a & "c0-scriptName=callejb" & Chr(10)
    
29. a = a & "c0-methodName=getResultsetFpzw" & Chr(10)
    
30. a = a & "c0-id=7161_1297495974155" & Chr(10)
    
31. a = a & "c0-param0=string:getFpzw" & Chr(10)
    
32. a = a & "c0-e1=string:" & fpdm & Chr(10)
    
33. a = a & "c0-e2=string:" & fphm & Chr(10)
    
34. a = a & "c0-param1=Object:{FPDM:reference:c0-e1, FPHM:reference:c0-e2}" & Chr(10)
    
35. xmlhttp.Send a
    
36. 
    
37. Do Until xmlhttp.ReadyState = 4
    
38. DoEvents
    
39. Loop
    
40. 
    
41. If xmlhttp.Status = 200 Then
    
42.   getpage = xmlhttp.responseText
    
43.   
    
44.   Dim nsrmc As String
    
45.   Dim nsrmcz As String
    
46.   nsrmc = Replace(Mid(getpage, InStr(getpage, "<NSRMC>") + 7, InStr(getpage, "</NSRMC>") - InStr(getpage, "<NSRMC>") - 7), "\u", "")
    
47.   For j = 1 To Len(nsrmc) Step 4
    
48.     nsrmcz = nsrmcz + ChrW(CInt("&H" & Mid(nsrmc, j, 4)))
    
49.     Next j
    
50.   Cells(i + 1, 4).Value = nsrmcz
    
51.   nsrmcz = Empty
    
52.   nsrmc = Empty
    
53. 
    
54.   Dim nsrsbh As String
    
55.   nsrsbh = Mid(getpage, InStr(getpage, "<NSRSBH>") + 8, InStr(getpage, "</NSRSBH>") - InStr(getpage, "<NSRSBH>") - 8)
    
56.   Cells(i + 1, 5).Value = nsrsbh
    
57.   nsrsbh = Empty
    
58.   
    
59.   Dim fpdmc As String
    
60.   fpdmc = Mid(getpage, InStr(getpage, "<FP_DM>") + 7, InStr(getpage, "</FP_DM>") - InStr(getpage, "<FP_DM>") - 7)
    
61.   Cells(i + 1, 6).Value = fpdmc
    
62.   fpdmc = Empty
    
63. 
    
64.   Dim fphmc As String
    
65.   fphmc = Mid(getpage, InStr(getpage, "<FPHM>") + 6, InStr(getpage, "</FPHM>") - InStr(getpage, "<FPHM>") - 6)
    
66.   Cells(i + 1, 7).Value = fphmc
    
67.   fphmc = Empty
    
68. 
    
69.   Dim fpmc As String
    
70.   Dim fpmcz As String
    
71.   fpmc = Replace(Mid(getpage, InStr(getpage, "<FPZL_MC>") + 9, InStr(getpage, "</FPZL_MC>") - InStr(getpage, "<FPZL_MC>") - 9), "\u", "")
    
72.   For k = 1 To Len(fpmc) Step 4
    
73.     fpmcz = fpmcz + ChrW(CInt("&H" & Mid(fpmc, k, 4)))
    
74.   Next k
    
75.   Cells(i + 1, 8).Value = fpmcz
    
76.   fpmcz = Empty
    
77.   fpmc = Empty
    
78.   
    
79.   Dim nsrzt As String
    
80.   Dim nsrztz As String
    
81.     nsrzt = Replace(Mid(getpage, InStr(getpage, "<NSRZT_MC>") + 10, InStr(getpage, "</NSRZT_MC>") - InStr(getpage, "<NSRZT_MC>") - 10), "\u", "")
    
82.   For l = 1 To Len(nsrzt) Step 4
    
83.     nsrztz = nsrztz + ChrW(CInt("&H" & Mid(nsrzt, l, 4)))
    
84.   Next l
    
85.   Cells(i + 1, 9).Value = nsrztz
    
86.   nsrztz = Empty
    
87.   nsrzt = Empty
    
88.    
    
89. Set xmlhttp = Nothing
    
90.   getpage = Empty
    
91. Else
    
92.   MsgBox xmlhttp.statusText
    
93. End If
    
94.   
    
95. Next i
    
96.   
    
97. Cells(2, 3).Value = "查询完毕！"
    
98. MsgBox "OK"
    
99. Cells(2, 3).Value = "查询状态提示栏"
    
100.   
     
101. End Sub
     
102. 
     
103. Sub reportErr(lStatus As Integer)
     
104.         Select Case lStatus
     
105.             Case 400
     
106.                 MsgBox "Bad Request", vbCritical, "连接错误"
     
107.             Case 401
     
108.                 MsgBox "Unauthorized", vbCritical, "连接错误"
     
109.             Case 402
     
110.                 MsgBox "Payment Required", vbCritical, "连接错误"
     
111.             Case 403
     
112.                 MsgBox "Forbidden", vbCritical, "连接错误"
     
113.             Case 404
     
114.                 MsgBox "Not Found", vbCritical, "连接错误"
     
115.             Case 407
     
116.               MsgBox "Proxy Authentication Required", vbCritical, "连接错误"
     
117.             Case 408
     
118.                 MsgBox "Request Timeout", vbCritical, "连接错误"
     
119.             Case 503
     
120.                 MsgBox "Service Unavailable", vbCritical, "连接错误"
     
121.             Case Else
     
122.               MsgBox "Can not reach by other reason", vbCritical, "连接错误"
     
123.         End Select
     
124. End Sub

复制代码

xmyjk

rjg
我用我的样式做了
原理都在里面，你看看自己需要如何的，再改吧。

rjg

不错！谢谢大侠热心帮助!!!!