اسرار لا تعرفها عن عشبة الزريقة في تونس

Par exemple 
12589 = douze mille cinq cent quatre-vingt-neuf 

recopier dans un module

Option Compare Database

' Constantes diverses
' (voir tableau astrSpecial et fonction InitialisationMots)
Public Const CONV_ZERO As Integer = 1
Public Const CONV_MOINS As Integer = 2
Public Const CONV_ET As Integer = 3
Public Const CONV_VIRGULE As Integer = 4
' Constantes liées aux nombres
' (voir tableau astrSpecial et fonction InitialisationMots)
Public Const CONV_60 As Integer = 5
Public Const CONV_80 As Integer = 6
Public Const CONV_1E2 As Integer = 7
Public Const CONV_1E3 As Integer = 8
Public Const CONV_1E6 As Integer = 9
Public Const CONV_1E9 As Integer = 10
' Tableau des mots
Dim astrMot(1 To 24) As String
Dim astrSpecial(1 To 10) As String
' ---
' Conversion d'un nombre en lettres
' ---
' Entrée : strValeur  <= Nombre à convertir
'          strDevise  <= Nom au singulier de la devise (facultatif).
'                        Ex. : "euro"
'          strCentime <= Nom au singulier des centimes (facultatif).
'                        Ex. : "centime" ou "cent"
'          intDigits  <= Nombre de décimales.
' Sortie : Nombre en toutes lettres
'
Function NbEnLettres( _
  ByVal strValeur As String, _
  Optional ByVal strDevise As String = "dinar", _
  Optional ByVal strCentime As String = "millime", _
  Optional ByVal intDigits As Integer = 3) _
  As String
  Dim strA As String
  Dim strK As String
  Dim strN As String
  Dim intI As Integer
  Dim strResultat As String
  Dim blnVirgule As Boolean

  ' Initialisation du tableau contenant les mots interprétés
  InitialisationMots
  If strDevise = "" Or strCentime = "" Then
    astrSpecial(CONV_ET) = astrSpecial(CONV_VIRGULE)
  End If

  ' Récupération de paramètre passé
  strA = strValeur + " "

  ' Initialisation des variables de travail
  strN = ""
  blnVirgule = False
  strResultat = ""

  ' Traiter toute la chaîne de valeur
  For intI = 1 To Len(strA)
    ' On extrait chacun des caractères
    strK = Mid(strA, intI, 1)
 
    Select Case strK
      ' Gèrer les montants négatifs
      Case "-"
        AjouterMot strResultat, astrSpecial(CONV_MOINS)
     
      ' Pour les caractères numériques, bâtir la chaine strN
      Case "0" To "9"
        strN = strN + strK
   
      ' Sinon, on teste si on est arrivé à une virgule
      Case Else
        If blnVirgule Then
          ' Les centimes sont comptés sur 2 digits, réajustés de
          ' manière inverse aux devises, puisqu'on lit les unités
          ' et dizaines de manière inversée (0,2€ = 20c et 0,02€ = 2c)
          strN = Right("000" + Left(strN + "000", intDigits), intDigits)
          If Val(strN) = 0 Then strN = ""
        End If
     
        ' On traduit le nombre stocké dans strN
        strResultat = TraduireEntier(strResultat, strN)
     
        ' Puis on détermine son unité en fonction de la présence
        ' ou non d'une virgule
        If (Not blnVirgule) And Val(strN) > 0 Then
          AjouterMot strResultat, strDevise
     
          ' Et on accorde l'unité avec le nombre
          ' (sauf s'il n'y a pas de devise)
          If strDevise <> "" Then
            If Val(strN) > 1 Then AjouterMot strResultat, "s"
          End If
     
        ElseIf blnVirgule And Val(strN) > 0 Then
          AjouterMot strResultat, strCentime
       
          ' On ajoute un "s" si nécessaire
          If strCentime <> "" Then
            If Val(strN) > 1 Then AjouterMot strResultat, "s"
          End If
        End If
     
        strN = ""
        Select Case strK
          Case Chr(13)
            intI = intI + 1
         
          Case Is < " "
       
          Case ",", "."
            blnVirgule = True
            ' Si une valeur en devises est exprimée, et que le
            ' nombre de centimes est suffisant pour être traité,
            ' on lie les 2 par le mot "et"
            If Val(strA) <> 0 And Val("0." + Mid(strA, intI + 1)) >= 0.01 Then
              AjouterMot strResultat, astrSpecial(CONV_ET)
            End If
     
          Case Else
        End Select
    End Select
  Next

  ' Valeur finale
  NbEnLettres = strResultat
End Function
' ---
' Traduction d'un nombre entier contenu dans une chaîne de caractères
' en son équivalent ordinal.
' ---
' Entrée : strChaine          <= Chaîne de départ (à compléter)
'          strNombreATraduire <= Nombre à traduire (!)
' Sortie : Nombre traduit en toutes lettres
'
Function TraduireEntier( _
  ByVal strChaine As String, _
  ByVal strNombreATraduire As String) _
  As String

  Dim strNombre As String
  Dim intLongueur As Integer
  Dim strCDU As String
  Dim strCentaines As String
  Dim strDizaines As String
  Dim strUnites As String
  Dim blnEt As Boolean
  Dim blnTiret As Boolean

  strNombre = strNombreATraduire
  If strNombre <> "" Then
  ' Si le nombre est 0, on ne perd pas de temps
  If Val(strNombre) = 0 Then
    AjouterMot strChaine, astrSpecial(CONV_ZERO)
  Else
    ' Sinon, on convertit celui-ci en une chaine de caractères
    ' de intLongueur multiple de 3, afin de pouvoir la lire par blocs
    ' de 3 caractères
    strNombre = Right("000", -((Len(strNombre) Mod 3) <> 0) _
      * (3 - (Len(strNombre) Mod 3))) + strNombre
   
    For intLongueur = Len(strNombre) To 3 Step -3
      strCDU = Left(strNombre, 3)
      strNombre = Right(strNombre, intLongueur - 3)
   
      ' On extrait ainsi des ensembles de 3 chiffres,
      ' de la gauche vers la droite
      If strCDU <> "000" Then
        ' ... dont on tire une valeur de
        ' centaines, dizaines et unités
        strCentaines = Left(strCDU, 1)
        strDizaines = Mid(strCDU, 2, 1)
        strUnites = Right(strCDU, 1)
     
        ' On convertit les unités non muettes pour les centaines
        If strCentaines >= "2" Then
          AjouterMot strChaine, Equivalent(Val(strCentaines))
        End If
     
        ' Et on traite les 1 muets
        If strCentaines >= "1" Then
          AjouterMot strChaine, astrSpecial(CONV_1E2)
     
          ' On applique les règles d'accords pour les centaines
          If Val(strNombre) = 0 And strDizaines + strUnites = "00" _
            And Len(strChaine) > 4 Then AjouterMot strChaine, "s"
        End If
   
        ' On analyse si le mot ET est nécessaire (21, 31, 41...)
        blnEt = (strDizaines >= "2") And (strUnites = "1")
   
        ' Ainsi que les tirets pour certains couples
        ' dizaines-unités
        blnTiret = ((strDizaines >= "2") And (strUnites > "1") _
          Or (strDizaines >= "1" And strUnites >= "7")) And (Not blnEt)
     
        ' Traitement des valeurs 80-99
        If strDizaines >= "8" Then
          AjouterMot strChaine, astrSpecial(CONV_80)
          blnEt = False
     
          ' Retenue nécessaire pour 90 à 99
          If strDizaines = "8" Then
            strDizaines = "0"
          Else
            strDizaines = "1"
            blnTiret = True
          End If
     
          ' Traitement d
          If strUnites > "0" Then
            blnTiret = True
          Else
            AjouterMot strChaine, "s"
          End If
     
        ' Sinon on traite les valeurs 70 à 79
        ElseIf strDizaines = "7" Then
          AjouterMot strChaine, astrSpecial(CONV_60)
       
          ' Retenue pour les dizaines
          strDizaines = "1"
          If strUnites <> "1" Then blnTiret = True
        End If
     
        ' Valeurs entre 10 et 16
        If (strDizaines = "1") And (strUnites <= "6") Then
          strDizaines = "0"
          strUnites = "1" + strUnites
        End If
     
        ' Sinon, on gère toutes les autres dizaines
        If strDizaines >= "1" Then
          ' Gérer les tirets pour les dizaines composées
          If blnTiret And strDizaines = "1" _
            And Val(Right(strCDU, 2)) > 19 Then
              AjouterMot strChaine, "-"
          End If
     
          ' Traduction de la dizaine...
          AjouterMot strChaine, Equivalent(Val(strDizaines + "0"))
     
          ' Accorder l'exception des vingtaines
          If strDizaines + strUnites = "20" And strCentaines <> "0" Then
            AjouterMot strChaine, "s"
          End If
        End If
     
        ' Si le mot Et est nécessaire, on l'ajoute
        If blnEt Then AjouterMot strChaine, astrSpecial(CONV_ET)
          ' ... ainsi que le tiret, liant
          ' une dizaine et une unité
          If blnTiret Then AjouterMot strChaine, "-"
       
          ' puis on traduit l'unité du nombre
          If Val(strUnites) >= 22 Or ((Val(strUnites) >= 1 _
            And (Val(strCDU) > 1 _
            Or intLongueur <> 6))) Then
            AjouterMot strChaine, Equivalent(Val(strUnites))
          End If
       
          ' Enfin, la pondération du nombre est respectée,
          ' en ajoutant le multiple nécessaire, et en
          ' l'accordant s'il le faut
          Select Case intLongueur
            Case 6
              AjouterMot strChaine, astrSpecial(CONV_1E3)
         
            Case 9
              AjouterMot strChaine, astrSpecial(CONV_1E6)
              If Val(strCDU) > 1 Then AjouterMot strChaine, "s"
           
            Case 12
              AjouterMot strChaine, astrSpecial(CONV_1E9)
              If Val(strCDU) > 1 Then AjouterMot strChaine, "s"
       
            Case Else
          End Select
        End If
      Next
    End If
  End If

  TraduireEntier = strChaine
End Function
' ---
' Ajout d'un terme traduit à une chaine
' ---
' Entrée : strChaine <= Chaîne à laquelle ajouter un terme.
'          strMot    <= Terme à ajouter.
' Sortie : strChaine est directement modifiée.
'
Sub AjouterMot( _
  ByRef strChaine As String, _
  ByVal strMot As String)

  If strChaine <> "" Then
    ' Le nouveau terme est directement collé aux précédents
    ' dans le cas des "S" à rajouter, ou des tirets
    If Right(strChaine, 1) = "-" Or strMot = "s" Or strMot = "-" Or strMot = "" Then
      strChaine = strChaine + strMot
    Else
      ' Sinon, ajouter le terme après un espace
      strChaine = strChaine + " " + strMot
    End If
  Else
    strChaine = strMot
  End If
End Sub
' ---
' Recherche d'un mot équivalent à une valeur numérique
' ---
'
Function Equivalent(ByVal intValeur As Integer) As String
  Select Case intValeur
    Case Is < 21
      Equivalent = astrMot(intValeur)
    Case Else
      Equivalent = astrMot(18 + (intValeur / 10))
  End Select
End Function
' ---
' Initialisation du tableau de mots
' ---
'
Sub InitialisationMots()
  ' Termes principaux
  astrMot(1) = "un"
  astrMot(2) = "deux"
  astrMot(3) = "trois"
  astrMot(4) = "quatre"
  astrMot(5) = "cinq"
  astrMot(6) = "six"
  astrMot(7) = "sept"
  astrMot(8) = "huit"
  astrMot(9) = "neuf"
  astrMot(10) = "dix"
  astrMot(11) = "onze"
  astrMot(12) = "douze"
  astrMot(13) = "treize"
  astrMot(14) = "quatorze"
  astrMot(15) = "quinze"
  astrMot(16) = "seize"
  astrMot(20) = "vingt"
  astrMot(21) = "trente"
  astrMot(22) = "quarante"
  astrMot(23) = "cinquante"
  astrMot(24) = "soixante"

  ' Termes spéciaux
  astrSpecial(CONV_ZERO) = "zéro"
  astrSpecial(CONV_MOINS) = "moins"
  astrSpecial(CONV_ET) = ""
  astrSpecial(CONV_VIRGULE) = "dinars"

  ' Constantes liées aux nombres
  astrSpecial(CONV_60) = "soixante"
  astrSpecial(CONV_80) = "quatre-vingt"
  astrSpecial(CONV_1E2) = "cent"
  astrSpecial(CONV_1E3) = "mille"
  astrSpecial(CONV_1E6) = "million"
  astrSpecial(CONV_1E9) = "milliard"
End Sub

Vous pouvez changer la devise qui vous convient

Related Posts