Les mémos

Fermer Tables

Fermer Requêtes

Fermer Formulaires

Fermer Etats

Fermer Modules

Fermer Base

Fermer Automation

Fermer Administration

Fermer Registre

Fermer String

Fermer Email CDO

Fermer Outlook

Fermer Net

Fermer Dates - Heures

Fermer Fichiers

Fermer Références

Fermer Vrac

Je débute...

Fermer La normalisation

Fermer VBA

Attention
Aucun support
par émail !

Utilisez le forum pour les questions/réponses concernant MsAccess et les codes que vous trouverez sur ce site.
Visites

   visiteurs

   visiteurs en ligne

String - Convertir les nombres

Convertir les nombres en lettres

De nombreuses fonction de conversion littérale de nombres existent mais comportent souvent de grossières erreurs grammaticales. J'ai donc décidé de proposer l'adaptation par Gus du code de Joe Foster.

Function NombreVersTexte(ByVal N As Currency) As String

Dim Unité As String
Dim Buf As String
Dim Frac As Currency
Dim i As Integer
Dim MChiffre(4) As Currency
Dim Mlettre(4) As String

MChiffre(1) = 1000@
Mlettre(1) = "mille "
MChiffre(2) = MChiffre(1) * MChiffre(1)
Mlettre(2) = "million"
MChiffre(3) = MChiffre(2) * MChiffre(1)
Mlettre(3) = "milliard"
MChiffre(4) = MChiffre(3) * MChiffre(1)
Mlettre(4) = "billion"

If (N < 0@) Then Buf = "moins " Else Buf = ""
Frac = Abs(N - Fix(N))
If (N < 0@ Or Frac <> 0@) Then N = Abs(Fix(N))

If N = 0@ Then Buf = Buf & "zéro "

If N <= 1 Then
Unité = "euro"
Else
Unité = "euros"
End If

For i = 4 To 1 Step -1
If (N >= MChiffre(i)) Then
If (MChiffre(i) <> 1000) Then
Buf = Buf & ConverDigit(Int(N / MChiffre(i))) & " " & Mlettre(i)
If Int(N / MChiffre(i)) > 1 Then Buf = Buf & "s"

N = N - Int(N / MChiffre(i)) * MChiffre(i)
If (N >= 1@) Then
Buf = Buf & " "

Else
'si compte rond ajouter d' devant l'unité
'ex : un million d'euros
'sauf pour 1000 ex : mille euros
Buf = Buf & " d'"
End If
Else
'Gestion des exeptions pour 1000 invariable jamais de "s"
' si 1000 pas de 1 devant "un mille"
If (N \ MChiffre(1)) = 1 Then
Buf = Buf & Mlettre(i)
Else
Buf = Buf & ConverDigit(N \ MChiffre(1)) & " " & Mlettre(i)
End If
N = N - Int(N / MChiffre(i)) * MChiffre(i)
End If
End If
Next i

If (N > 0@) Then
Buf = Buf & ConverDigit(N) & " "
End If

Buf = Buf & Unité

If (Frac = 0@) Then
Buf = Buf & "" '" et zéro cent"
Else
Buf = Buf & " et "
Frac = Frac * 100
Buf = Buf & ConverDigit(Frac) & " cent"
If Frac > 1 Then Buf = Buf & "s"
End If

NombreVersTexte = UCase(Left(Buf, 1)) & Mid(Buf, 2)
End Function

Private Function ConverDigit(ByVal N As Integer) As String

Const Un = "un"
Const Deux = "deux"
Const Trois = "trois"
Const Quatre = "quatre"
Const Cinq = "cinq"
Const Six = "six"
Const Sept = "sept"
Const Huit = "huit"
Const Neuf = "neuf"
Dim Cent As String: Cent = "cent"
Dim Buf As String: Buf = ""
Dim Flag As Integer
Dim Flag1 As Integer

'Selection des centaines
'Mettre un "s" à cent si le chiffre est sans dizaine ni unité
If (N Mod 100) = 0 And (N \ 100) > 1 Then
Cent = "cents"
End If

Select Case (N \ 100)
Case 0: Buf = "": Flag = False
Case 1: Buf = Cent: Flag = True
Case 2: Buf = Deux & " " & Cent: Flag = True
Case 3: Buf = Trois & " " & Cent: Flag = True
Case 4: Buf = Quatre & " " & Cent: Flag = True
Case 5: Buf = Cinq & " " & Cent: Flag = True
Case 6: Buf = Six & " " & Cent: Flag = True
Case 7: Buf = Sept & " " & Cent: Flag = True
Case 8: Buf = Huit & " " & Cent: Flag = True
Case 9: Buf = Neuf & " " & Cent: Flag = True
End Select

If (Flag <> False) Then N = N Mod 100
If (N > 0) Then
If (Flag <> False) Then Buf = Buf & " "
Else
ConverDigit = Buf
Exit Function
End If

'Selection des dixaines sup. à 10 et inf. 100
'traitement des exceptions pour 21,31,41,51,61,71
'ajouter "et" soixante -et - onze
Flag = True
Flag1 = False

Select Case (N \ 10)
Case 0, 1: Flag = False
Case 2
Buf = Buf & "vingt"
If ((N Mod 10) = 1) Then Buf = Buf & " et "
Case 3
Buf = Buf & "trente"
If ((N Mod 10) = 1) Then Buf = Buf & " et "
Case 4
Buf = Buf & "quarante"
If ((N Mod 10) = 1) Then Buf = Buf & " et "
Case 5
Buf = Buf & "cinquante"
If ((N Mod 10) = 1) Then Buf = Buf & " et "
Case 6
Buf = Buf & "soixante"
If ((N Mod 10) = 1) Then Buf = Buf & " et "
Case 7
Buf = Buf & "soixante"
If ((N Mod 10) = 1) Then Buf = Buf & " et "
Flag1 = True
Case 8
Buf = Buf & "quatre-vingt"
If ((N Mod 10) = 0) Then Buf = Buf & "s"
If ((N Mod 10) = 1) Then Buf = Buf & "-"
Case 9
Buf = Buf & "quatre-vingt"
Flag1 = True
End Select

If (Flag = True) Then N = N Mod 10

'ajouter 10 pour soixante-dix et Quatre -vingt - dix
If (Flag1 = True) Then N = N + 10
'rajouter le séparateur "-" si buffer ne se termine pas par "et "
If (Flag = True) And (N > 1) And Right(Buf,3) <> "et " Then Buf = Buf & "-"

'Selection de un à 19
Select Case (N)
Case 0:
Case 1: Buf = Buf & Un
Case 2: Buf = Buf & Deux
Case 3: Buf = Buf & Trois
Case 4: Buf = Buf & Quatre
Case 5: Buf = Buf & Cinq
Case 6: Buf = Buf & Six
Case 7: Buf = Buf & Sept
Case 8: Buf = Buf & Huit
Case 9: Buf = Buf & Neuf
Case 10: Buf = Buf & "dix"
Case 11: Buf = Buf & "onze"
Case 12: Buf = Buf & "douze"
Case 13: Buf = Buf & "treize"
Case 14: Buf = Buf & "quatorze"
Case 15: Buf = Buf & "quinze"
Case 16: Buf = Buf & "seize"
Case 17: Buf = Buf & "dix-sept"
Case 18: Buf = Buf & "dix-huit"
Case 19: Buf = Buf & "dix-neuf"
End Select

ConverDigit = Buf
End Function


Date de création : 01/11/2005 : 03:10
Dernière modification : 04/01/2008 : 01:43
Catégorie : String
Page lue 6074 fois


Imprimer l'article Imprimer l'article

Recherche



Lettre d'information
Pour avoir des nouvelles de ce site, inscrivez-vous à notre Newsletter.
Captcha
Recopier le code :
Au sujet de l'auteur
L'auteur qui fréquente (fréquentait) le forum microsoft.public.fr.access a eu le plaisir d'être nommé MVP Office-Access de janvier 2003 à décembre 2011.

Qui sont les MVP ?

Divers ;-)
Nous contacter

Haut