Question

我发现此VBA代码可以通过Excel检查增值税号。但是他们在代码中使用的链接不再起作用，需要调整为该链接http://ec.europa.eu/taxation_customs/vies/?locale=be

但是，如果我更改链接，则还需要更改其他元素。不幸的是，我仍然是编码方面的初学者。有人知道我需要更改以获得以下内容吗？

VatNumberCheckExcel

vba代码当前是这样：

Sub test()
    Dim lrow As Long, data, obj As Object, i As Long, country, VATnum, webreply As String

    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    If lrow = 1 Then Exit Sub

    If Range("a1") <> "VAT" Then Exit Sub

    data = Range("a1:d" & lrow)

    Set obj = CreateObject("MSXML2.XMLHTTP")

    For i = 2 To lrow
        If Len(data(i, 1)) > 2 Then
            country = Left(data(i, 1), 2)
            VATnum = Right(data(i, 1), Len(data(i, 1)) - 2)
            obj.Open "GET", "http://vatid.eu/check/" & country & "/" & VATnum & "/" & country & "/" & VATnum
            obj.send
            Do: DoEvents: Loop Until obj.ReadyState = 4
            webreply = obj.responsetext
            If InStr(webreply, "<error>") > 0 Then
                data(i, 2) = False
            Else
                data(i, 2) = Split(Split(webreply, "<valid>")(1), "</valid>")(0)
                data(i, 3) = Split(Split(webreply, "<name><![CDATA[")(1), "]]></name>")(0)
                data(i, 4) = Split(Split(webreply, "<address><![CDATA[")(1), "]]></address>")(0)
            End If
        End If
    Next

    obj.abort

    Range("a1:d" & lrow) = data

End Sub





Public Function VAT(rng As Range) As String
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "http://vatid.eu/check/" & Left(rng, 2) & "/" & Right(rng, Len(rng) - 2)
        .send
        Do: DoEvents: Loop Until .ReadyState = 4
        VAT = Split(Split(.responsetext, "<valid>")(1), "</valid>")(0)
        .abort
    End With
End Function

Answer 1

主要基于此answer。仅将NextSibling部分更改为获得第x个td标签：

Sub getData()

'~~~~Variable declaration~~~~'
Dim IE As Object
Dim country As Object
Dim num As Object
Dim btn As Object
Dim tlb As Object, td As Object

Set IE = CreateObject("InternetExplorer.Application")

IE.Visible = False
IE.navigate "http://ec.europa.eu/taxation_customs/vies/?locale=en"

'Wait till page is loaded
Do While IE.readystate <> 4
    DoEvents
Loop


Set country = IE.document.getElementById("countryCombobox")
country.Value = "FR" 'set the value for Member state


'Pause the code for 1 sec
Application.Wait Now + TimeSerial(0, 0, 1)

'
Set num = IE.document.getElementById("number")
num.Value = "27435044714" 'set the Vat number


Application.Wait Now + TimeSerial(0, 0, 1)


Set btn = IE.document.getElementById("submit")
btn.Click ' click the verify button

'Wait till page is loaded
Do While IE.readystate <> 4: DoEvents: Loop

'Pause the code for 5 sec
    Application.Wait Now + TimeSerial(0, 0, 5)

    Set tbl = IE.document.getElementById("vatResponseFormTable")

    numb_spans = tbl.getElementsByTagName("td").Length
    MsgBox (tbl.getElementsByTagName("td")(0).innerText)
    pos = InStr(1, tbl.getElementsByTagName("td")(0).innerText, "valid VAT")
    If pos > 0 Then
        Cells(2, 2) = True
        Cells(2, 3) = tbl.getElementsByTagName("td")(10).innerText
        Cells(2, 4) = tbl.getElementsByTagName("td")(12).innerText
    Else
        Cells(2, 2) = False
    End If
    IE.Quit
    Set IE = Nothing
 End Sub

Answer 2

以下内容似乎对我有用，但您可能需要将"Sheet1"更改为数据所在工作表的名称。

Option Explicit

Private Sub VerifyEUVatNumbers()

    Const EU_VIES_API_ENDPOINT As String = "http://ec.europa.eu/taxation_customs/vies/services/checkVatService"

    ' Change this to whatever your worksheet is called. I assume Sheet1
    With ThisWorkbook.Worksheets("Sheet1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        .Range("B2:D" & lastRow).ClearContents ' Clear results from last time code was run

        Dim euVATnumbersToCheck() As Variant
        euVATnumbersToCheck = .Range("A2:D" & lastRow).Value2

        Dim countryCode As String
        Dim vatNumber As String
        Dim envelopeToSend As String
        Dim rowIndex As Long

        Dim webClient As MSXML2.ServerXMLHTTP60
        Set webClient = New MSXML2.ServerXMLHTTP60

        With webClient
            For rowIndex = LBound(euVATnumbersToCheck, 1) To UBound(euVATnumbersToCheck, 1)
                countryCode = VBA.Strings.Left$(euVATnumbersToCheck(rowIndex, 1), 2)
                vatNumber = VBA.Strings.Mid$(euVATnumbersToCheck(rowIndex, 1), 3)
                envelopeToSend = soapEnvelope(countryCode, vatNumber)

                .Open "POST", EU_VIES_API_ENDPOINT, True
                .send envelopeToSend
                .waitForResponse

                euVATnumbersToCheck(rowIndex, 2) = TextBetweenTwoDelimiters(.responseText, "<valid>", "</valid>")
                euVATnumbersToCheck(rowIndex, 3) = TextBetweenTwoDelimiters(.responseText, "<name>", "</name>")
                euVATnumbersToCheck(rowIndex, 4) = TextBetweenTwoDelimiters(.responseText, "<address>", "</address>")
                euVATnumbersToCheck(rowIndex, 4) = VBA.Strings.Replace(euVATnumbersToCheck(rowIndex, 4), VBA.Strings.Chr$(10), ", ", 1, -1, vbBinaryCompare)
            Next rowIndex
        End With

        .Range("A2").Resize(UBound(euVATnumbersToCheck, 1), UBound(euVATnumbersToCheck, 2)).Value2 = euVATnumbersToCheck

    End With
End Sub

Public Function TextBetweenTwoDelimiters(ByVal textToParse As String, ByVal firstDelimiter As String, ByVal secondDelimiter As String) as String
    Dim firstDelimiterIndex As Long
    firstDelimiterIndex = VBA.Strings.InStr(1, textToParse, firstDelimiter, vbBinaryCompare)

    If firstDelimiterIndex = 0 Then
        Exit Function
    Else
        firstDelimiterIndex = firstDelimiterIndex + Len(firstDelimiter) ' Assume we don't delimiter included
    End If

    Dim secondDelimiterIndex As Long
    secondDelimiterIndex = VBA.Strings.InStr(firstDelimiterIndex, textToParse, secondDelimiter, vbBinaryCompare)

    If secondDelimiterIndex = 0 Then
        Exit Function
    Else
        secondDelimiterIndex = secondDelimiterIndex ' Assume we don't delimiter included
    End If

    TextBetweenTwoDelimiters = VBA.Strings.Mid$(textToParse, firstDelimiterIndex, secondDelimiterIndex - firstDelimiterIndex)
End Function

Private Function soapEnvelope(ByVal countryCode As String, ByVal vatNumber As String) As String
    ' Give this function a country code and VAT Number.
    ' It will return an envelope that can be sent in the request's body

    Dim outputEnvelope As String
    outputEnvelope = "<s11:Envelope xmlns:s11='http://schemas.xmlsoap.org/soap/envelope/'>" & _
                "<s11:Body>" & _
                    "<tns1:checkVat xmlns:tns1='urn:ec.europa.eu:taxud:vies:services:checkVat:types'>" & _
                        "<tns1:countryCode>" & countryCode & "</tns1:countryCode>" & _
                        "<tns1:vatNumber>" & vatNumber & "</tns1:vatNumber>" & _
                    "</tns1:checkVat>" & _
                "</s11:Body>" & _
            "</s11:Envelope>"

    soapEnvelope = outputEnvelope
End Function

一些注意事项：

我从一个现有的PHP实现中获取了SOAP信封在GitHub上（此后我已经关闭了特定的浏览器标签，否则会在我的答案中包含链接）。
代替解析服务器的响应作为XML文档，我只是将其解析为字符串（不好，但返回的资源很小）。
代码假设一切都会成功。如果请求超时或返回错误消息，代码可能会引发错误（如果它不知道如何处理）
来自EC自身网站上的技术资源/文档（例如WSDL和FAQ），似乎没有中央数据库（您的请求先转到他们的服务器，然后再转到他们的服务器要求相关国家/成员国的信息数据库）。
通常的配额/使用规定（管理消费量任何服务/ API）。如果他们收到太多来自的请求给定IP在短时间内或请求过多产生无效的欧盟增值税号，他们可能会怀疑滥用其服务和黑名单您的IP。

这就是我的出发点：

这是我输入代码后得到的：

更新税费链接后，增值税号检查不起作用

2 个答案: