This code is used to validate an European VAT number using the WebService Vies (provided by the European Commission)
It retrieve also the informations of the company
Sample of use
The code
And the test project VATValidator.zip
It retrieve also the informations of the company
Sample of use
Code:
Private Sub Command1_Click()
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 08/02/2012
' * Time : 14:13
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : Command1_Click
' * Purpose :
' * Parameters :
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Dim sXMLVAT As String
Dim sError As String
Dim sMessage As String
If LenB(tbVAT.Text) > 4 Then
If VAT_Validator(tbVAT.Text, sXMLVAT, sError) Then
sMessage = "VAT is valid" & vbCrLf
sMessage = sMessage & "Country" & " : " & TVA_GetInfo(sXMLVAT, "countryCode") & vbCrLf
sMessage = sMessage & "VAT" & " : " & TVA_GetInfo(sXMLVAT, "countryCode") & " " & TVA_GetInfo(sXMLVAT, "vatNumber") & vbCrLf
sMessage = sMessage & "Name" & " : " & TVA_GetInfo(sXMLVAT, "name") & vbCrLf
sMessage = sMessage & "Address" & " : " & TVA_GetInfo(sXMLVAT, "address") & vbCrLf
tbResult.Text = sMessage
Else
If LenB(sError) Then
tbResult.Text = sError
Else
tbResult.Text = "Invalid VAT"
End If
End If
End If
End SubCode:
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 11/01/2021
' * Time : 13:54
' * Module Name : Module1
' * Module Filename : Module1.bas
' * Purpose :
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Option Explicit
Private Function GetCorrectVAT(sVAT As String) As String
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 06/12/2013
' * Time : 07:47
' * Module Name : Module1
' * Module Filename : Module1.bas
' * Procedure Name : GetCorrectVAT
' * Purpose :
' * Parameters :
' * sVAT As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
' #VBIDEUtilsERROR#
On Error GoTo ERROR_GetCorrectVAT
' Belgique BE0999.999.999 10 chiffres
' Danemark DK99 99 99 99 4 blocs de 2 chiffres
' Allemagne DE999999999 1 bloc de 9 chiffres
' Grèce EL999999999 1 bloc de 9 chiffres
' Espagne ESX9999999X (1) 1 bloc de 9 caractères
' France FRXX999999999 1 bloc de 2 caractères et 1 bloc de 9 chiffres
' Irlande IE9S99999L 1 bloc de 8 caractères
' Italie IT99999999999 1 bloc de 11 chiffres
' Luxembourg LU99999999 1 bloc de 8 chiffres
' Pays-Bas NL999999999B99 (2) 1 bloc de 12 caractères
' Autriche ATU99999999 (3) 1 bloc de 9 caractères
' Portugal PT999999999 1 bloc de 9 chiffres
' Finlande FI99999999 1 bloc de 8 chiffres
' Suède SE999999999999 1 bloc de 12 chiffres
' Royaume-Uni GB999 9999 99 1 bloc de 3, 1 bloc de 4 et 1 bloc de 2 chiffres
' GB999 9999 99 999 (4) même format que ci avant + 1 bloc de 3 chiffres
' GBGD999 (5) 1 bloc de 5 caractères
' GBHA999 (6) 1 bloc de 5 caractères
' Chypre CY99999999L 1 bloc de 9 caractères
' République tchèque CZ99999999 1 bloc de 8,9 ou 10 chiffres
' CZ999999999
' CZ9999999999
' Estonie EE999999999 1 bloc de 9 chiffres
' Lettonie LV99999999999 1 bloc de 11 chiffres
' Lituanie LT999999999 1 bloc de 9 ou 12 chiffres
' LT999999999999
' Hongrie HU99999999 1 bloc de 8 chiffres
' Malte MT99999999 1 bloc de 8 chiffres
' Pologne PL9999999999 1 bloc de 10 chiffres
' Slovénie SI99999999 1 bloc de 8 chiffres
' République slovaque SK9999999999 1 bloc de 10 chiffres
' Bulgarie BG999999999 1 bloc de 9 ou 10 chiffres
' BG9999999999
' Roumanie RO9999999999 1 bloc de minimum 2 chiffres et de maximum 10 chiffres
' Croatie HR99999999999 1 bloc de 11 chiffres
'
' (1) Le premier et le dernier caractère peuvent être de type alphabétique ou numérique mais ils ne peuvent pas être tous les deux numériques.
' (2) La 10ème position suivant le préfixe code pays est toujours "B"
' (3) La première position suivant le préfixe code pays est toujours "U"
' (4) Identifie la branche de l'assujetti
' (5) Identifie le gouvernement départemental
' (6) Identifie l'autorité de santé
' 9 : représente un chiffre
' S : une lettre, un chiffre, "+" ou " * " X : un caractère ou un chiffre
' L : une lettre
Dim sTmp As String
Dim sCountry As String
Dim bForceBE As Boolean
sCountry = GetCountryVAT(sVAT)
' *** If no country, we enforce to Belgium
If (LenB(sCountry) = 0) And IsNumeric(sVAT) Then
sTmp = "BE" & sVAT
bForceBE = True
Else
sTmp = sVAT
If sCountry = "BE" Then bForceBE = True
End If
sTmp = Replace(sTmp, " ", vbNullString)
sTmp = Replace(sTmp, ".", vbNullString)
sTmp = Replace(sTmp, "-", vbNullString)
sTmp = Trim$(Mid$(sTmp & " ", 3))
If (Len(sTmp) = 9) And bForceBE Then
sTmp = "0" & sTmp
End If
EXIT_GetCorrectVAT:
On Error Resume Next
GetCorrectVAT = sTmp
Exit Function
' #VBIDEUtilsERROR#
ERROR_GetCorrectVAT:
Resume EXIT_GetCorrectVAT
End Function
Private Function GetCountryVAT(sVAT As String) As String
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 06/12/2013
' * Time : 07:47
' * Module Name : Module1
' * Module Filename : Module1.bas
' * Procedure Name : GetCountryVAT
' * Purpose :
' * Parameters :
' * sVAT As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
' #VBIDEUtilsERROR#
On Error GoTo ERROR_GetCountryVAT
Dim sTmp As String
sTmp = UCase$(Left$(sVAT & " ", 2))
If IsNumeric(sTmp) Then sTmp = vbNullString
EXIT_GetCountryVAT:
On Error Resume Next
GetCountryVAT = sTmp
Exit Function
' #VBIDEUtilsERROR#
ERROR_GetCountryVAT:
Resume EXIT_GetCountryVAT
End Function
Private Function GetStringBetweenTags(ByVal sSearchIn As String, ByVal sFrom As String, ByVal sUntil As String, Optional nPosAfter As Long, Optional ByVal nStartAtPos As Long = 0) As String
' #VBIDEUtils#***********************************************************
' * Programmer Name :
' * Web Site :
' * E-Mail :
' * Date : 01/15/2001
' * Time : 13:31
' * Module Name : Module1
' * Module Filename : Module1.bas
' * Procedure Name : GetStringBetweenTags
' * Parameters :
' * ByVal sSearchIn As String
' * ByVal sFrom As String
' * ByVal sUntil As String
' * Optional nPosAfter As Long
' * Optional ByVal nStartAtPos As Long = 0
' **********************************************************************
' * Comments :
' * This function gets in a string and two keywords
' * and returns the string between the keywords
' *
' **********************************************************************
Dim nPos1 As Long
Dim nPos2 As Long
Dim nPos As Long
Dim nLen As Long
Dim sFound As String
Dim nLenFrom As Long
On Error GoTo ERROR_GetStringBetweenTags
nLenFrom = Len(sFrom)
nPos1 = InStr(nStartAtPos + 1, sSearchIn, sFrom, vbTextCompare)
nPos2 = InStr(nPos1 + nLenFrom, sSearchIn, sUntil, vbTextCompare)
If (nPos1 = 0) Or (nPos2 = 0) Then
sFound = vbNullString
Else
nPos = nPos1 + nLenFrom
nLen = nPos2 - nPos
sFound = Mid$(sSearchIn, nPos, nLen)
End If
GetStringBetweenTags = sFound
If nPos + nLen > 0 Then
nPosAfter = (nPos + nLen) - 1
End If
Exit Function
ERROR_GetStringBetweenTags:
GetStringBetweenTags = vbNullString
End Function
Private Function PostWebserviceXML(ByVal AsmxUrl As String, ByVal SoapActionUrl As String, ByVal XmlBody As String) As String
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 12/03/2012
' * Time : 14:14
' * Module Name : Module1
' * Module Filename : Module1.bas
' * Procedure Name : PostWebserviceXML
' * Purpose :
' * Parameters :
' * ByVal AsmxUrl As String
' * ByVal SoapActionUrl As String
' * ByVal XmlBody As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
' #VBIDEUtilsERROR#
On Error GoTo ERROR_PostWebserviceXML
Dim oDOM As Object
Dim oXMLHttp As Object
Dim sRet As String
' *** Create objects to DOMDocument and XMLHTTP
Set oDOM = CreateObject("MSXML2.DOMDocument")
Set oXMLHttp = CreateObject("MSXML2.XMLHTTP")
' *** Load XML
oDOM.Async = False
oDOM.LoadXML XmlBody
' *** Open the webservice
oXMLHttp.Open "POST", AsmxUrl, False
' *** Create headings
oXMLHttp.setRequestHeader "Content-Type", "text/xml; charset=utf-8"
oXMLHttp.setRequestHeader "SOAPAction", SoapActionUrl
' *** Send XML command
oXMLHttp.sEnd oDOM.xml
' *** Retrieve response text from webservice
sRet = oXMLHttp.responseText
' *** Close object
Set oXMLHttp = Nothing
' *** Return result
PostWebserviceXML = sRet
EXIT_PostWebserviceXML:
On Error Resume Next
Exit Function
' #VBIDEUtilsERROR#
ERROR_PostWebserviceXML:
PostWebserviceXML = vbNullString
Resume EXIT_PostWebserviceXML
End Function
Public Function TVA_GetInfo(sXMLTVA As String, sField As String) As String
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 02/08/2015
' * Time : 07:58
' * Module Name : Module1
' * Module Filename : Module1.bas
' * Procedure Name : TVA_GetInfo
' * Purpose :
' * Parameters :
' * sXMLTVA As String
' * sField As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
TVA_GetInfo = XML_Quick_GetTextNodeText(sXMLTVA, sField)
End Function
Public Function VAT_Validator(sVAT As String, sXMLVAT As String, sError As String) As Boolean
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 12/03/2012
' * Time : 13:15
' * Module Name : Module1
' * Module Filename : Module1.bas
' * Procedure Name : VAT_Validator
' * Purpose :
' * Parameters :
' * sVAT As String
' * sXMLVAT As String
' * sError As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
' #VBIDEUtilsERROR#
On Error GoTo ERROR_VAT_Validator
Dim sSoapAction As String
Dim sURL As String
Dim sXML As String
Dim slCountry As String
Dim slVAT As String
slCountry = GetCountryVAT(sVAT)
slVAT = GetCorrectVAT(sVAT)
sURL = "https://ec.europa.eu/taxation_customs/vies/services/checkVatService"
sSoapAction = "urn:ec.europa.eu:taxud:vies:services:checkVat:types/checkVat"
sXML = vbNullString
sXML = sXML & "<?xml version=""1.0"" encoding=""utf-8""?>"
sXML = sXML & "<SOAP-ENV:Envelope xmlns:SOAP-ENV=""http://schemas.xmlsoap.org/soap/envelope/"">"
sXML = sXML & " <SOAP-ENV:Body>"
sXML = sXML & " <tns1:checkVat xmlns:tns1=""urn:ec.europa.eu:taxud:vies:services:checkVat:types"">"
sXML = sXML & " <tns1:countryCode>" & slCountry & "</tns1:countryCode>"
sXML = sXML & " <tns1:vatNumber>" & slVAT & "</tns1:vatNumber>"
sXML = sXML & " </tns1:checkVat>"
sXML = sXML & " </SOAP-ENV:Body>"
sXML = sXML & "</SOAP-ENV:Envelope>"
sXMLVAT = PostWebserviceXML(sURL, sSoapAction, sXML)
If InStrB(LCase$(sXMLVAT), "<valid>true</valid>") > 0 Then
VAT_Validator = True
Else
VAT_Validator = False
If InStrB(LCase$(sXMLVAT), "<valid>false</valid>") > 0 Then
' *** TVA invalide
Else
' *** Un erreur du service
sError = XML_Quick_GetTextNodeText(sXMLVAT, "faultstring")
Select Case sError
Case "INVALID_INPUT": sError = "The provided CountryCode is invalid or the VAT number is empty"
Case "SERVICE_UNAVAILABLE": sError = "The service is unavailable, try again later"
Case "MS_UNAVAILABLE": sError = "The Member State service is unavailable, try again later or with another Member State"
Case "TIMEOUT": sError = "The Member State service could not be reach in time, try again later or with another Member State"
Case "SERVER_BUSY": sError = "The service can't process your request. Try again latter"
End Select
End If
End If
EXIT_VAT_Validator:
On Error Resume Next
Exit Function
' #VBIDEUtilsERROR#
ERROR_VAT_Validator:
Resume EXIT_VAT_Validator
End Function
Private Function XML_Quick_GetTextNodeText(sXML As String, ByVal sXPath As String) As String
' #VBIDEUtils#***********************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 09/05/2003
' * Purpose :
' * Project Name : SyndicAssist
' * Module Name : Module1
' * Procedure Name : XML_Quick_GetTextNodeText
' * Parameters :
' * sXML As String
' * ByVal sXPath As String
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * History :
' *
' * See Also :
' *
' *
' **********************************************************************
Dim sTmp As String
sTmp = GetStringBetweenTags(sXML, "<" & sXPath & ">", "</" & sXPath & ">")
If (InStrB(sTmp, vbLf) > 0) Or (InStrB(sTmp, vbCr) > 0) Then sTmp = Replace(Replace(sTmp, vbCrLf, vbLf), vbLf, vbCrLf)
XML_Quick_GetTextNodeText = sTmp
End Function