Converture chiffre en lettre

'Convertion des chiffres en lettres avec choix de devise.
'Montant pôuvant aller jusqu' à 999 999 999.99
'Posibilité de l' incorporrer dans une Feuille Excel.
'------------------------------------------------------------------------------------------
'Auteur : CHAIBAT
'V1.0
'Retouché LE : 22/08/2006
'-------------------------------------------------------------------------------------------
'/////////////////////////////////////////////////////////////////////////////////////////////////////

Function CONVERTION(pMontant As String, _
                     pUPE As String, _
                     pUPD As String, _
                     SI_0_Zero As Boolean) As String
  
  '//paramètres de la fonction
  '//pMontant = Montant à convertir
  '//pUPE => Devise pour les unités (chaine vide si pas)
  '//pUPD => Devise pour les centièmes (chaine vide si pas)
  '//SI_0_Zero => si vrai: affiche "Zéro pUPD" si faux ""
 
   Dim cMontant As Variant 'chaine à traiter à l' intérieure
                           'de la fonction
 
   CONVERTION = "" 'initialisation
   
   '//J' ai choisi de traiter le format monétaire
   'de la chaine entrée pour que la fonction soit indépendante
   'du control que l' utilisateur pourrait faire ou ne pas faire
  
   On Error GoTo ERR_CURR
   cMontant = CCur(pMontant) 'provoque l' erreur si pas monétaire
   
   'code inutil ; erreur interceptée avant !
   'If cMontant > 999999999.99 Then 'erreur liée au système
     'dépassement de la capacité de la variable
   '  MsgBox "Montant impossible à traité..."
   '  Exit Function
   'End If
 
   'si vous ne désirez pas traiter le zéro désactiver cette ligne
   'If cMontant = 0 Then Exit Function
 
'****DEBUT DU TRAITEMENT******************************************
   
   cMontant = Format(cMontant, "0.00") 'format monétaire
   
   '//variables servant pour la décomposition du montant
    Dim xDH As Variant 'partie entière
    Dim xCT As Variant 'partie décimale
 
    xDH = Left$(cMontant, Len(cMontant) - 3)
    xCT = Right$(cMontant, 2)
 
    Dim xPart1 As String
    Dim xPart2 As String
    Dim xPart3 As String
    Dim xPart4 As String
  
    xPart1 = ""
    xPart2 = ""
    xPart3 = ""
    xPart4 = ""
   
    Dim xMt1 As Integer   'Millions
    Dim xMt2 As Integer   'Milliers
    Dim xMt3 As Integer   'Centaines
    Dim xMt4 As Integer   'Centièmes
   
    xMt1 = xDH \ 1000000
    xMt2 = (xDH Mod 1000000) \ 1000
    xMt3 = xDH Mod 1000
    xMt4 = xCT

'****
   'commence le traitement de chaque partie
   'en appelant la fonction CONVERTIR
   If xMt1 > 0 Then
     xPart1 = CONVERTIR(xMt1, " Million")
     If xMt1 > 1 Then
       xPart1 = xPart1 + "s"
     End If
   End If
   If xMt2 > 0 Then
     If xMt2 = 1 Then
       xPart2 = "mille "
     Else
       xPart2 = CONVERTIR(xMt2, " Mille")
     End If
   End If
   If xMt3 > 0 Then
      xPart3 = CONVERTIR(xMt3, "")
   End If
   If xMt4 > 0 Then
      xPart4 = CONVERTIR(xMt4, "")
   End If
   
   'traitement de l' orthographe
   If pUPE <> "" Then
     pUPE = " " & pUPE
     If xDH = 0 Then
         If SI_0_Zero = True Then
            pUPE = "Zéro" & pUPE
         Else
            pUPE = ""
         End If
      End If
      If xDH > 1 Then pUPE = pUPE & "s"
    End If
    If pUPD <> "" Then
      pUPD = " " & pUPD
      If xCT = 0 Then
         If SI_0_Zero = True Then
            pUPD = " Zéro" & pUPD
         Else
            pUPD = ""
         End If
      End If
      If xCT > 1 Then pUPD = pUPD & "s"
    End If
  
    'concaténation et retour de la chaine
    CONVERTION = xPart1 & xPart2 & xPart3 & pUPE & xPart4 & pUPD
      
Exit Function
ERR_CURR:
MsgBox Err.Description
End Function

Public Function CONVERTIR(xNombre As Integer, xAdject As String) As String
 CONVERTIR = ""
 If xNombre = 0 Then Exit Function

 Dim A(19) As String 'tableau littéral de un à dix neuf
 Dim B(9) As String  'tableau littéral des dixaines
 
 Dim xChaine As String
 Dim i As Integer
 Dim J As Integer
 Dim k As Integer
 Dim jk As Integer

 Dim cAdject As String
 cAdject = ""
 cAdject = xAdject
 
 A(1) = " Un"
 A(2) = " Deux"
 A(3) = " Trois"
 A(4) = " Quatre"
 A(5) = " Cinq"
 A(6) = " Six"
 A(7) = " Sept"
 A(8) = " Huit"
 A(9) = " Neuf"
 A(10) = " Dix"
 A(11) = " Onze"
 A(12) = " Douze"
 A(13) = " Treize"
 A(14) = " Quatorze"
 A(15) = " Quinze"
 A(16) = " Seize"
 A(17) = " Dix-Sept"
 A(18) = " Dix-Huit"
 A(19) = " Dix-Neuf"
 
 B(1) = " Dix"
 B(2) = " Vingt"
 B(3) = " Trente"
 B(4) = " Quarante"
 B(5) = " Cinquante"
 B(6) = " Soixante"
 B(7) = " Soixante-Dix"
 B(8) = " Quatre-Vingt"
 B(9) = " Quatre-Vingt-Dix"

 'décomposition du nombre
  
  i = xNombre \ 100
  jk = (xNombre Mod 100)
  J = jk \ 10
  k = jk Mod 10

  If i > 0 Then
   If i = 1 Then
    xChaine = "Cent"
   Else
    xChaine = A(i) + " Cent"
   End If
  End If
  
  If jk = 0 Then
   If i > 1 And cAdject = "" Then
     xChaine = xChaine + "s"
   End If
  ElseIf jk = 1 Then
     xChaine = xChaine + A(k)
  ElseIf jk > 1 And jk < 10 Then
     xChaine = xChaine + A(k)
  ElseIf jk >= 10 And jk < 20 Then
     xChaine = xChaine + A(jk)
  Else
     If k = 0 Then
        xChaine = xChaine + B(J)
        If J = 8 Then
           If cAdject = "" Then
              xChaine = xChaine + "s"
           End If
         End If
     Else
         If J = 7 Or J = 9 Then
           If k = 1 Then
              xChaine = xChaine + B(J - 1) + " et " + A(11)
           Else
              xChaine = xChaine + B(J - 1) + A(10 + k)
           End If
         Else
           If k = 1 Then
              xChaine = xChaine + B(J) + " Et Un"
           Else
              xChaine = xChaine + B(J) + A(k)
           End If
         End If
     End If
  End If
  
  CONVERTIR = xChaine + cAdject
End Function

'///////////////////////////////////////////////////////////////////
Private Sub cmdOk_Click()
  On Error GoTo ERR_TEXT
  
  Text2.Text = CONVERTION(Text1.Text, "Euro", "Ct", True)
  
  Exit Sub
  
ERR_TEXT:
  MsgBox Err.Description
End Sub

Private Sub Text1_GotFocus()
  Text2.Text = ""
  Text1.Alignment = 0
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
 'ici pourrait être insérer le control
 'sur les chiffres

End Sub

Private Sub Text1_Validate(Cancel As Boolean)
 Dim cValue As Currency
 On Error GoTo ERR_CUR
  'tester si le teste entré peut être convertit en monétaire
  'test superflux puisque la fonction le fait.
  cValue = CCur(Text1.Text)

  With Text1
    .Text = Format(.Text, "### ### ##0.00")
    .Alignment = 1
  End With

Exit Sub
ERR_CUR:
 MsgBox Err.Description
 Cancel = True
End Sub