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

xmyjk

原帖由 pc_12 于 2011-3-16 08:23 发表
XMYJK 版主，真的太感谢，代码很精彩。

http://club.excelhome.net/viewth ... =1139642#pid2455637
看来你经常用到网络查询的东西,这个应该能对你有所帮助.

flysum2008

找了很长时间的东西，谢谢分享，非常感谢！！！！！！！！！！！

xmyjk

代码如下，EXCEL见附件，你试看看行不？

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim I As Integer, Getpage As String, Tmp1() As String, Tmp2() As String, xmlhttp As Object, N As Integer, Fpdm As String, Fphm As String
   
5.                                     
   
6.     On Error Resume Next
   
7.     N = [a65536].End(xlUp).Row
   
8.     For I = 1 To N - 1
   
9.     Cells(2, 3).Value = "正在查询第" & I & "张"
   
10.     Fpdm = Trim(Cells(I + 1, 1).Value)
    
11.     Fphm = Trim(Cells(I + 1, 2).Value)
    
12.     Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
    
13.     With xmlhttp
    
14.         .Open "get", "http://219.140.196.6/cms/wh05/index.jsp?fpdm=" & Fpdm & "&fphm=" & Fphm & "&action=queryed", False
    
15.         .send
    
16.         Getpage = Replace(.responsetext, vbCrLf, "")
    
17.     End With
    
18.     If InStr(Getpage, "<b><font color=""blue"">") > 0 Then
    
19.      Cells(I + 1, 4).Value = Split(Split(Getpage, "<b><font color=""blue"">")(1), "</font>")(0)
    
20.      Tmp1() = Split(Getpage, "<td align=""left"" width=""80%""><b>")
    
21.      Cells(I + 1, 5).Value = Split(Tmp1(1), "</b>")(0)
    
22.      Cells(I + 1, 6).Value = Split(Tmp1(2), "</b>")(0)
    
23.      Cells(I + 1, 7).Value = Split(Tmp1(3), "</b>")(0)
    
24.      Cells(I + 1, 8).Value = Split(Tmp1(4), "</b>")(0)
    
25.     ElseIf InStr(Getpage, "<b><font color=""red"">") > 0 Then
    
26.      Cells(I + 1, 4).Value = Split(Split(Getpage, "<b><font color=""red"">")(1), "</font>")(0)
    
27.      Tmp1() = Split(Getpage, "<td align=""left"" width=""80%""><b>")
    
28.      Cells(I + 1, 5).Value = Split(Tmp1(1), "</b>")(0)
    
29.      Cells(I + 1, 6).Value = Split(Tmp1(2), "</b>")(0)
    
30.      Tmp2() = Split(Getpage, "<td colspan=""3"" align=""left"">")
    
31.      Cells(I + 1, 7).Value = Split(Tmp2(1), "</td>")(0)
    
32.      Cells(I + 1, 8).Value = Split(Tmp2(2), "</td>")(0)
    
33.     Else
    
34.      Cells(I + 1, 4).Value = "未知错误！"
    
35.     End If
    
36.     Erase Tmp1
    
37.     Erase Tmp2
    
38.     Getpage = ""
    
39.     Set xmlhttp = Nothing
    
40.     Next
    
41.     Cells(2, 3).Value = "查询状态栏"
    
42.     MsgBox "查询完毕！"
    
43. End Sub
    

复制代码

smileoa

测试成功！ 非常感谢xmyjk 兄

xmyjk

1. Option Explicit
   
2. Sub Test()
   
3.     Dim tmp() As String, i As Integer, arr() As String, xmlhttp As Object, N As Long, TMP1() As String, NM As Long, p As Long, k As Integer, Fpdm(1 To 10) As String, Fphm(1 To 10) As String
   
4.     Dim Url As String
   
5.                            
   
6.     N = [a65536].End(xlUp).Row
   
7.     NM = Application.Ceiling((N - 1) / 10, 1)
   
8.    
   
9.     For p = 1 To NM
   
10.      
    
11.     Cells(2, 3).Value = "正在查询，稍等..."
    
12.      
    
13.      For k = 1 To 10
    
14.         Fpdm(k) = Cells((p - 1) * 10 + k + 1, 1).Value
    
15.         Fphm(k) = Cells((p - 1) * 10 + k + 1, 2).Value
    
16.      Next k
    
17.      
    
18.      For k = 1 To 10
    
19.         Url = Url & "&fpdm" & k & "=" & Fpdm(k) & "&fphm" & k & "=" & Fphm(k)
    
20.      Next k
    
21.      
    
22.      Erase Fpdm
    
23.      Erase Fphm
    
24.      
    
25.      Url = "http://www.gdltax.gov.cn/wssw/fpcjController.do?cmd=fpcjcheck" & Url
    
26.             
    
27.      Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
    
28.      With xmlhttp
    
29.         .Open "get", Url, False
    
30.         .send
    
31.         tmp() = Split(Replace(Replace(Replace(.responsetext, vbCrLf, ""), "</span>", ""), "&nbsp;", ""), "<td description=")
    
32.      End With
    
33.      ReDim arr(UBound(tmp) \ 7, 6)
    
34.      For i = 1 To UBound(tmp)
    
35.         TMP1() = Split(Split(tmp(i), "</td>")(0), ">")
    
36.         arr((i - 1) \ 7, (i - 1) Mod 7) = TMP1(UBound(TMP1))
    
37.         Erase TMP1
    
38.      Next i
    
39.    
    
40.      Cells((p - 1) * 10 + 2, 4).Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1) = arr
    
41.    
    
42.      Erase tmp
    
43.      Erase TMP1
    
44.      Erase arr
    
45.      Set xmlhttp = Nothing
    
46.      Url = ""
    
47.    
    
48.     Next p
    
49.    
    
50.     Cells(2, 3).Value = "查询状态栏"
    
51.    
    
52.     [D:J].Columns.AutoFit
    
53.     MsgBox "Ok"
    
54. 
    
55. End Sub
    

复制代码

[ 本帖最后由 xmyjk 于 2011-4-5 21:20 编辑 ]

rjg

请高手再研究一下河南地税！

120HYH

谢谢，辛苦大哥了。

superqk

11111111111111111111111111111111111111

83560722

好像东莞地税的用不了，是不是哪有问题呢？点运行就序号为1的边空白，其他的无反应。是不是我操作问题？ 是了几次都不行。

xmyjk

原帖由 83560722 于 2011-5-20 22:12 发表
好像东莞地税的用不了，是不是哪有问题呢？点运行就序号为1的边空白，其他的无反应。是不是我操作问题？ 是了几次都不行。

不是你的问题，东莞地税的已经有验证码了，估计这个网站被过度查询了才出这个下策。不过验证码的机制真不怎么样。