excel - 更新税务链接后增值税号检查不起作用

Question

我发现这个 VBA 代码可以通过 Excel 检查增值税号。但是他们在代码中使用的链接已经失效了，需要调整为这个链接http://ec.europa.eu/taxation_customs/vies/?locale=be

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

目前的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

以下似乎对我有用，但您可能需要将 "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。

这就是我的开头:

这是我在代码之后得到的: