Vérification de la validité d'un SIREN et d'un SIRET

Shamard · 21/03/2007, 14h29

Bonjour,
Ayant un peu galéré pour le faire, je vous poste ces deux bouts de code (certainement perfectibles) pour tous ceux qui cherchent...

Code :

 
Private Sub Siretemployeur_AfterUpdate()
On Error GoTo Siretemployeur_AfterUpdate_Error
 
    Dim numerosaisi As String
    Dim numerotest As Variant
    Dim i As Integer
    Dim j As Integer
    Dim grille1(9, 0)
    Dim grille2(18, 0)
    Dim A As Variant
    Dim a1 As Byte
    Dim a2 As Byte
    Dim atester As Single
    Dim resultat As Variant
 
'initialisation des variables
    i = 1
    j = 1
    numerosaisi = Me.ActiveControl
    numerotest = Left(numerosaisi, 9)
    atester = 0
'décomposition du SIREN dans grille1
    Do Until (9 - i) = -1
        grille1(i, 0) = Left(numerotest, 1)
'si rang impaire *1 si rang paire *2
    Select Case (i)
        Case 1, 3, 5, 7, 9
            A = grille1(i, 0) * 1
        Case 2, 4, 6, 8
            A = grille1(i, 0) * 2
       End Select
       a1 = IIf(Len(A) = 2, Left(A, 1), 0)
       a2 = IIf(Len(A) = 2, Right(A, 1), A)
'alimentation des resultats dans grille2
       grille2(j, 0) = a1
       grille2(j + 1, 0) = a2
       j = j + 2
'on passe au digit suivant
       numerotest = IIf((9 - i) > 0, Right(numerotest, (9 - i)), numerotest)
    i = i + 1
    Loop
'addition des digits de grille 2
    For j = 1 To 18
    atester = atester + grille2(j, 0)
    Next j
    resultat = atester Mod 10
'on teste le modulo 10
    If resultat <> 0 Then
        MsgBox "NUMERO SIREN INVALIDE", vbExclamation
        Exit Sub
    Else
        MsgBox "NUMERO SIREN VALIDE", vbExclamation
        Call controle_siretemployeur
    End If
   On Error GoTo 0
   Exit Sub
 
Siretemployeur_AfterUpdate_Error:
 
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Siretemployeur_AfterUpdate "
End Sub
'--------------------------------------------------------------------------
Private Sub controle_siretemployeur()
   On Error GoTo controle_siretemployeur_Error
    Dim numerosaisi As String
    Dim numerotest As Variant
    Dim i As Integer
    Dim j As Integer
    Dim grille1(12, 0)
    Dim grille2(26, 0)
    Dim n As Byte
    Dim A As Variant
    Dim a1 As Byte
    Dim a2 As Byte
    Dim atester As Single
    Dim resultat As Variant
'initialisation des variables
    i = 0
    j = 1
    numerosaisi = Me.ActiveControl
    numerotest = Left(numerosaisi, 13)
'conservation de la clef
    n = Right(numerosaisi, 1)
    atester = 0
'décomposition du SIRET dans grille1 avec premier digit en rang 0
    Do Until (12 - i) = -1
       grille1(i, 0) = Left(numerotest, 1)
'si rang impaire *1 si rang paire *2
       Select Case (i)
        Case 1, 3, 5, 7, 9, 11
            A = grille1(i, 0) * 1
        Case 0, 2, 4, 6, 8, 10, 12
            A = grille1(i, 0) * 2
       End Select
'décomposition en 2 digits
       a1 = IIf(Len(A) = 2, Left(A, 1), 0)
       a2 = IIf(Len(A) = 2, Right(A, 1), A)
'alimentation des resultats dans grille2
       grille2(j, 0) = a1
       grille2(j + 1, 0) = a2
       j = j + 2
'on passe au digit suivant
        numerotest = IIf((12 - i) > -1, Right(numerotest, (12 - i)), numerotest)
    i = i + 1
    Loop
'addition des digits de grille 2
    For j = 1 To 26
    atester = atester + grille2(j, 0)
    Next j
'on ajoute la clef
    atester = atester + n
    resultat = atester Mod 10
'on teste le modulo 10
    If resultat <> 0 Then
        MsgBox "NUMERO SIRET INVALIDE", vbExclamation
        Exit Sub
    Else
        MsgBox "NUMERO SIRET VALIDE", vbExclamation
    End If
   On Error GoTo 0
   Exit Sub
controle_siretemployeur_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure controle_siretemployeur of Document VBA Form_F_TRANSIT DDTEFP ETABLISSEMENTS"
End Sub

et voilà... Merci encore pour toutes les infos que je trouve grace à vous.

Tofalu · 22/03/2007, 16h45

Il faudrait en faire une fonction indépendante qui renverra vrai ou faux suivant que le siren est correct ou pas. Là le code est un peu indigeste

Shamard · 16/04/2007, 17h17

Citation:

Envoyé par Tofalu

Il faudrait en faire une fonction indépendante qui renverra vrai ou faux suivant que le siren est correct ou pas. Là le code est un peu indigeste

Voilà voilà le code des 2 fonctions qui renvoient True si OK et false si KO!
En meme temps, "Tofalu" en 3 mn t'avais pas vraiment le temps de te pencher sur la question je pense...

Code :

 
'---------------------------------------------------------------------------------------
' Fonction : VerifSiren
' DateTime  : 20/03/2007 17:11
' Author    : HAMARD
' Purpose   : Vérification de la validité du numéro de Siren d'une entreprise
'             Passer le Numéro de Siren ou de Siret (mini 9 chiffres) en parametre
'             renvoie True si OK
'---------------------------------------------------------------------------------------
'
Public Function VérifSiren(Siret As String) As Boolean
 
    
    Dim numerosaisi As String
    Dim numerotest As Variant
    Dim i As Integer
    Dim j As Integer
    Dim grille1(9, 0)
    Dim grille2(18, 0)
    Dim A As Variant
    Dim a1 As Byte
    Dim a2 As Byte
    Dim atester As Single
    Dim resultat As Variant
    
    
    
'initialisation des variables
   On Error GoTo VérifSiren_Error
 
    i = 1
    j = 1
    numerosaisi = Siret
    numerotest = Left(numerosaisi, 9)
    atester = 0
 
'décomposition du SIREN dans grille1
 
               
    Do Until (9 - i) = -1
        
        grille1(i, 0) = Left(numerotest, 1)
'si rang impaire *1 si rang paire *2
       
       Select Case (i)
        Case 1, 3, 5, 7, 9
            A = grille1(i, 0) * 1
        Case 2, 4, 6, 8
            A = grille1(i, 0) * 2
       End Select
            
       a1 = IIf(Len(A) = 2, Left(A, 1), 0)
       a2 = IIf(Len(A) = 2, Right(A, 1), A)
'alimentation des resultats dans grille2
 
       grille2(j, 0) = a1
       grille2(j + 1, 0) = a2
       j = j + 2
       
'on passe au digit suivant
 
        numerotest = IIf((9 - i) > 0, Right(numerotest, (9 - i)), numerotest)
    i = i + 1
    Loop
 
'addition des digits de grille 2
 
    For j = 1 To 18
    atester = atester + grille2(j, 0)
    Next j
    
    resultat = atester Mod 10
 
'on teste le modulo 10
 
    If resultat <> 0 Then
        VérifSiren = False
    Else
        VérifSiren = True
    End If
    
 
   On Error GoTo 0
   Exit Function
 
VérifSiren_Error:
 
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure VérifSiren of Module Général"
    
End Function
'
'---------------------------------------------------------------------------------------
' Procedure : VérifSiret
' DateTime  : 16/04/2007 17:02
' Author    : HAMARD
' Purpose   : Vérification de la validité du n° de Siret d'une entreprise
'             Passer le Numéro de Siret en parametre
'             renvoie True si OK
'---------------------------------------------------------------------------------------
'
Public Function VérifSiret(Siret As String) As Boolean
 
 
    Dim numerosaisi As String
    Dim numerotest As Variant
    Dim i As Integer
    Dim j As Integer
    Dim grille1(12, 0)
    Dim grille2(26, 0)
    Dim n As Byte
    Dim A As Variant
    Dim a1 As Byte
    Dim a2 As Byte
    Dim atester As Single
    Dim resultat As Variant
   
'initialisation des variables
   On Error GoTo VérifSiret_Error
 
    i = 0
    j = 1
    numerosaisi = Siret
    numerotest = Left(numerosaisi, 13)
 
'conservation de la clef
 
    n = Right(numerosaisi, 1)
    atester = 0
 
'décomposition du SIRET dans grille1 avec premier digit en rang 0
 
               
    Do Until (12 - i) = -1
        
        grille1(i, 0) = Left(numerotest, 1)
        
'si rang impaire *1 si rang paire *2
       
       Select Case (i)
        Case 1, 3, 5, 7, 9, 11
            A = grille1(i, 0) * 1
        Case 0, 2, 4, 6, 8, 10, 12
            A = grille1(i, 0) * 2
       End Select
            
'décomposition en 2 digits
       
       a1 = IIf(Len(A) = 2, Left(A, 1), 0)
       a2 = IIf(Len(A) = 2, Right(A, 1), A)
 
'alimentation des resultats dans grille2
 
       grille2(j, 0) = a1
       grille2(j + 1, 0) = a2
       j = j + 2
       
'on passe au digit suivant
 
        numerotest = IIf((12 - i) > -1, Right(numerotest, (12 - i)), numerotest)
    i = i + 1
    Loop
 
'addition des digits de grille 2
 
    For j = 1 To 26
    atester = atester + grille2(j, 0)
    Next j
    
'on ajoute la clef
 
    atester = atester + n
    
    resultat = atester Mod 10
    
'on teste le modulo 10
 
    If resultat <> 0 Then
        verifsiret = False
    Else
        verifsiret = True
    End If
 
 
   On Error GoTo 0
   Exit Function
 
VérifSiret_Error:
 
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure VérifSiret of Module Général"
 
End Function

Merci encore pour tout ce que je trouve comme aide ici...

philben · 17/04/2007, 22h52

Bonjour Shamard,

Humble félicitation pour l'idée et l'amélioration de la lisibilité du code.

Un petit problème : la fonction VérifSiret a un <é> et votre code contient <VerifSiret> sans accent d'où une erreur signalée à la compilation.
Je pense qu'il vaut mieux éviter les caractères particuliers dans le nom des fonctions.

J'ai fouiné sur le web et j'ai écrit une fonction générique qui check en plus la clef de contrôle des cartes de crédit à 16 chiffres :

Code :

 
' Utilisé par la fonction CheckLuhn
Public Enum eTypeLuhn
   eCarteDeCredit
   eSiren
   eSiret
End Enum
 
'---------------------------------------------------------------------------------------
' Procédure    : CheckLuhn [Function]
' Retour       : Boolean (vrai si clef correcte) et la valeur de la clef (iKey)
' Version      : 1.0
' Auteur       : PhilBen
' Création/Maj : Le mardi 17 avril 2007
' Objet        : - Vérifier la clef de contrôle d'un numéro construit selon
'                  l'algorithme de Luhn.
'                - Attention ! une clef correcte ne signifie pas que
'                  le numéro soit valide...
'                - Fonctionne pour les numéros de carte de crédit, Siren et Siret
' Dépendances  : Enum eTypeLuhn et la fonction CalcLuhn
'---------------------------------------------------------------------------------------
Public Function CheckLuhn(ByVal sNumber As String, ByVal eTL As eTypeLuhn, _
                          ByRef iKey As Integer) As Boolean
   iKey = -1
   Select Case eTL
      Case eTypeLuhn.eCarteDeCredit
         CheckLuhn = CalcLuhn(sNumber, 16, 1, iKey)
      Case eTypeLuhn.eSiren
         CheckLuhn = CalcLuhn(sNumber, 9, 0, iKey)
      Case eTypeLuhn.eSiret
         CheckLuhn = CalcLuhn(sNumber, 14, 1, iKey)
   End Select
End Function
 
'---------------------------------------------------------------------------------------
' Procédure    : CalcLuhn  [Private Function] appelée par CheckLuhn
' Retour       : Boolean (vrai si clef correcte) et la valeur de la clef (iKey)
' Version      : 1.0
' Auteur       : PhilBen
' Création/Maj : Le mardi 17 avril 2007
' Objet        : Voir fonction CheckLuhn
' Référence    : <a href="http://en.wikipedia.org/wiki/Luhn_algorithm" target="_blank">http://en.wikipedia.org/wiki/Luhn_algorithm</a>
'---------------------------------------------------------------------------------------
Private Function CalcLuhn(ByVal sNumber As String, ByVal byLenNumberWithKey As Byte, _
                            ByVal byParity As Byte, ByRef iKey As Integer) As Boolean
   Dim bNoKey As Boolean
   Dim i As Integer, iVal As Integer, iStartPos As Integer, iSum As Integer
   sNumber = Trim$(sNumber)
   iStartPos = Len(sNumber)
   If iStartPos = byLenNumberWithKey - 1 Then bNoKey = True
   If bNoKey Or iStartPos = byLenNumberWithKey Then
      iSum = 0
      For i = iStartPos To 1 Step -1
         iVal = val(Mid$(sNumber, i, 1))
         If i Mod 2 = byParity Then
            iVal = iVal * 2
            If iVal > 9 Then iVal = iVal - 9
         End If
         iSum = iSum + iVal
      Next i
      If bNoKey Then
         iKey = (10 - (iSum Mod 10)) Mod 10
         If byLenNumberWithKey Mod 2 = byParity Then iKey = iKey / 2
      ElseIf (iSum Mod 10) = 0 Then
         iKey = Right$(sNumber, 1)
         CalcLuhn = True
      End If
   End If
End Function

Exemples d'utilisation :

Code :

 
Dim iclef As Integer
' Mon numéro de CB mais chut !
 MsgBox "CB Ok ? " & CheckLuhn("4973101234567890", eCarteDeCredit, iclef) & " Clef : " & iclef
 MsgBox "CB Ok (manque clef) ? " & CheckLuhn("497010000030052", eCarteDeCredit, iclef) & " Clef : " & iclef
 MsgBox "Siren Ok ? " & CheckLuhn("732829320", eSiren, iclef) & " Clef : " & iclef
 MsgBox "Siret Ok ? " & CheckLuhn("73282932000074", eSiret, iclef) & " Clef : " & iclef

Grâce à vous j'ai découvert l'algorithme de Luhn et le contrôle de clefs

Cordialement,

Philippe

Shamard · 18/04/2007, 10h56

Citation:

Envoyé par philben

Bonjour Shamard,

Humble félicitation pour l'idée et l'amélioration de la lisibilité du code.

Un petit problème : la fonction VérifSiret a un <é> et votre code contient <VerifSiret> sans accent d'où une erreur signalée à la compilation.
Je pense qu'il vaut mieux éviter les caractères particuliers dans le nom des fonctions.

Merci, Merci pour tous ces compliments !!! que je ne mérite pas...
Effectivement, j'ai vu (apres avoir posté) qu'il restait cette petite erreur due sans doute à un reste de conditionnement scolaire !!! orthographe quand tu nous tiens !
Mais je suis comme vous, je pense qu'il vaut mieux éviter les caractères accentués dans les procédures et les fonctions.

En tous cas, merci également pour votre travail de recherche sur LUHN ainsi que les vérifications du N° de CB.

22/03/2007, 16h45	#2 (permalink)
Tofalu Rédacteur Date d'inscription: octobre 2004 Localisation: Mâcon Messages: 5 851	Il faudrait en faire une fonction indépendante qui renverra vrai ou faux suivant que le siren est correct ou pas. Là le code est un peu indigeste __________________ Tutoriel : Gestion de favoris sous Access 2007 Cours : Manipulation des fichiers en VBA

		Forum des développeurs > Hardware, Systèmes et Logiciels > Microsoft Office > Access > Contribuez
Vérification de la validité d'un SIREN et d'un SIRET

Outils de la discussion
Afficher une version imprimable Envoyer un lien vers cette page par email