Conversion Nombre en Lettre

Bonjour et merci pour ceux qui utilise du VB.NET

Et en VBA

Option Explicit
Option Base 0

Public Enum Pays
    France
    Belgique
    Suisse
End Enum

Public Enum Devise
    Aucune
    Euro
    FrancSuisse
    Dollar
End Enum

Dim jusqueSeize As Variant

Dim dizaines As Variant

Dim resultat() As String

Dim troisChiffres() As Integer 'tableau qui scinde la partie entière en morceaux de 3 chiffres



'Fonction écrivant le nombre en lettres
'Nombre est le nombre à écrire
'LePays est le pays d'utilisation, pour spécificitées régionnales
'LaDevise la devise à utliser le cas échéant</param>
Public Function ToLettres(ByVal Nombre As Double, Optional ByVal LePays As Pays = Pays.France, Optional ByVal LaDevise As Devise = Devise.Aucune) As String

    ReDim resultat(0)
    ReDim troisChiffres(0)
    
    Select Case Sgn(Nombre)
        Case -1
            AjouteResultat "moins "
            Nombre = Nombre * -1

        Case 0
            ToLettres = jusqueSeize(0)
            Exit Function

    End Select
    
    If Nombre >= 2147483647 Then 'j'utilise un long pour la partie entière et c'est la valeur maximun
        ToLettres = "Nombre trop grand"
        Exit Function
    End If

    jusqueSeize = Array("zéro", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", "dix", "onze", "douze", "treize", "quatorze", "quinze", "seize")
    dizaines = Array("rien", "dix", "vingt", "trente", "quarante", "cinquante", "soixante", "soixante", "quatre-vingt", "quatre-vingt")


    Dim partieEntiere As Long
    partieEntiere = CLng(Fix(Nombre))
    
    Dim partieDecimale As Double
    partieDecimale = Nombre - partieEntiere

    Dim milliers As Variant
    milliers = Array("", "mille", "million", "milliard", "billion", "billiard")

    If partieEntiere > 0 Then

        Do While partieEntiere > 0
            AjouteTroisChiffres CInt(Fix(partieEntiere Mod 1000))
            partieEntiere = partieEntiere \ 1000
        Loop

        Dim reste As Double
        reste = Nombre - partieEntiere


        Dim i As Integer

        For i = UBound(troisChiffres) - 1 To 0 Step -1
            Dim leNombre As Integer
            leNombre = troisChiffres(i)

            If leNombre > 1 Then 'valeurs de milliers au pluriel
                AjouteResultat Ecrit3Chiffres(troisChiffres(i), LePays)
                If i > 1 Then ' mille est invariable et "" ne prend pas de s
                    AjouteResultat milliers(i) & "s"
                ElseIf i = 1 Then
                    AjouteResultat milliers(i)
                End If
            ElseIf leNombre = 1 Then
                If i <> 1 Then 'on dit un million, mais pas un mille
                    AjouteResultat "un"
                End If
                AjouteResultat milliers(i)
            End If
            'on ne traite pas le 0, car on ne dit pas X millions zéro mille Y.
        Next i
    Else
        AjouteResultat jusqueSeize(0)
    End If

    Select Case LaDevise
        Case Devise.Dollar
            AjouteResultat "$"

        Case Devise.Euro
            AjouteResultat "€"

        Case Devise.FrancSuisse
            AjouteResultat "CHF"

    End Select

    If LaDevise <> Devise.Aucune Then
        partieDecimale = Round(partieDecimale, 2)
        If partieDecimale <> 0 Then
            AjouteResultat "et"
            AjouteResultat Ecrire2Chiffres(CInt(Fix(partieDecimale * 100)), LePays)
            AjouteResultat "centimes"
        End If
    Else
        milliers = Array("millième", "millionième", "milliardième")

        'avec l'imprécision des nombres à virgules flotantes,  1234562.789 - 1234562 donne 0.78900000010617077 il faut donc compter le nombre de chiffres décimaux du nombre original et arrondir le resultat de la soustraction
        Dim morceaux() As String
        morceaux = Split(CStr(Nombre), ",") 'par défaut ToString arrondi à 10^-8, le format G25 oblige à écrire 25 caractères s'ils sont présents soit (au pire) 15 avant la virgule, la virgule et 9 après, split permet de découper le string obtenu

        If UBound(morceaux) = 1 Then 'il y a une partie décimale
            AjouteResultat "et"

            Dim lenghtPartieDecimale As Integer
            lenghtPartieDecimale = Len(morceaux(1))
            
            If lenghtPartieDecimale > 9 Then
                lenghtPartieDecimale = 9 'on se limite à 10^-9
            End If

            partieDecimale = Round(partieDecimale, lenghtPartieDecimale)

            i = 0
            Do While partieDecimale > 0
                partieDecimale = partieDecimale * 1000
                Dim valeur As Integer
                valeur = CInt(Fix(partieDecimale))
                lenghtPartieDecimale = lenghtPartieDecimale - 3
                If lenghtPartieDecimale < 0 Then
                    lenghtPartieDecimale = 0
                End If
                partieDecimale = Round(partieDecimale - valeur, lenghtPartieDecimale)

                If valeur <> 0 Then
                    AjouteResultat Ecrit3Chiffres(valeur, LePays)
                    If valeur > 1 Then
                        AjouteResultat milliers(i) & "s"
                        i = i + 1
                    Else
                        AjouteResultat milliers(i)
                        i = i + 1
                    End If

                End If
            Loop


        End If
    End If



    ToLettres = Join(resultat, " ")
End Function

'Ecrit les nombres de 0 à 999
Private Function Ecrit3Chiffres(ByVal Nombre As Integer, ByVal LePays As Pays) As String
    If Nombre = 100 Then
        Ecrit3Chiffres = "cent"
        Exit Function
    End If

    If Nombre < 100 Then
        Ecrit3Chiffres = Ecrire2Chiffres(Nombre, LePays)
        Exit Function
    End If

    Dim centaine As Integer
    centaine = Nombre \ 100
    Dim reste As Integer
    reste = Nombre Mod 100

    If reste = 0 Then 'Cent prend un s quand il est multiplié et non suivi d'un nombre, comme le cas de 100 est déjà traité on est face à un multiple
        Ecrit3Chiffres = jusqueSeize(centaine) & " cents"
        Exit Function
    End If

    If centaine = 1 Then
        Ecrit3Chiffres = "cent " & Ecrire2Chiffres(reste, LePays) 'on ne dit pas un cent X, mais cent X
        Exit Function
    End If

    Ecrit3Chiffres = jusqueSeize(centaine) & " cent " & Ecrire2Chiffres(reste, LePays)
End Function

'Ecrit les nombres de 0 à 99
Private Function Ecrire2Chiffres(ByVal Nombre As Integer, ByVal LePays As Pays) As String
    If LePays <> Pays.France Then
        dizaines(7) = "septante"
        dizaines(9) = "nonante"
    End If
    If LePays = Pays.Suisse Then
        dizaines(8) = "huitante"
    End If

    If Nombre < 17 Then
        Ecrire2Chiffres = jusqueSeize(Nombre)
        Exit Function
    End If

    Select Case Nombre 'cas particuliers de 71, 80 et 81
        Case 71 'en France 71 prend un et
            If LePays = Pays.France Then
                Ecrire2Chiffres = "soixante et onze"
                Exit Function
            End If

        Case 80 'en France et Belgique le vingt prend un s
            If LePays = Pays.Suisse Then
                Ecrire2Chiffres = dizaines(8)
                Exit Function
            Else
                Ecrire2Chiffres = dizaines(8) & "s"
                Exit Function
            End If

        Case 81 'en France et Belgique il n'y a pas de et
            If LePays <> Pays.Suisse Then
                Ecrire2Chiffres = dizaines(8) & "-un"
                Exit Function
            End If
    End Select


    Dim dizaine As Integer
    dizaine = Nombre \ 10
    Dim unite As Integer
    unite = Nombre Mod 10

    Dim laDizaine As String
    laDizaine = dizaines(dizaine)

    If LePays = France And (dizaine = 7 Or dizaine = 9) Then
        dizaine = dizaine - 1
        unite = unite + 10
    End If


    Select Case unite
        Case 0
            Ecrire2Chiffres = laDizaine

        Case 1
            Ecrire2Chiffres = laDizaine & " et un"

        Case 17, 18, 19 'pour 77 à 79 et 97 à 99
            unite = unite Mod 10
            Ecrire2Chiffres = laDizaine & "-dix-" & jusqueSeize(unite)

        Case Else
            Ecrire2Chiffres = laDizaine & "-" & jusqueSeize(unite)
    End Select
End Function

'Ajoute une valeur au tableau
Sub AjouteResultat(ByVal Texte As String)
On Error GoTo TableauVide 'la gestion d'erreur est le seul cas ou je m'autorise les goto
    Dim taille As Integer
    taille = UBound(resultat) + 1
    ReDim Preserve resultat(taille)
    resultat(taille - 1) = Texte
    Exit Sub
    
TableauVide:
    ReDim resultat(1)
    resultat(0) = Texte
End Sub

'ajoute une valeur au tableau
Sub AjouteTroisChiffres(ByVal Entier As Integer)
On Error GoTo TableauVide 'la gestion d'erreur est le seul cas ou je m'autorise les goto
    Dim taille As Integer
    taille = UBound(troisChiffres) + 1
    ReDim Preserve troisChiffres(taille)
    troisChiffres(taille - 1) = Entier
    Exit Sub
    
TableauVide:
    ReDim troisChiffres(1)
    troisChiffres(0) = Entier

End Sub

'code de test
Sub test()
        ActiveSheet.Range("A1") = ToLettres(123.456)
        ActiveSheet.Range("A2") = ToLettres(3210987654321.2)
        ActiveSheet.Range("A3") = ToLettres(123456789012345#)
        ActiveSheet.Range("A4") = ToLettres(1234.123456789)
        ActiveSheet.Range("A5") = ToLettres(-4321.987654321)
        ActiveSheet.Range("A6") = ToLettres(1E+16)    'ce nombre est trop grand
        ActiveSheet.Range("A7") = ToLettres(0.12345678961)  'il y a trop de chiffres dérrière la virgule, le resultat sera arrondi
        ActiveSheet.Range("A8") = ToLettres(6795432.456, Belgique, Euro)

End Sub

Il y a 2 goto pour la gestion d'erreur, car je n'ai pas trouver comment savoir qu'un tableau n'a pas encore de taille:

Dim toto() 
UBound(toto)'retourne une erreur, car le tableau n'a pas de taille à ce moment là
redim toto(1)

@Utilisateur anonymeBonjour,

Merci pour ce code, a quel moment un tableau ne serait pas defini ??

test si tableau:
Sub test()
    Dim toto
    
    If IsArray(toto) Then
        MsgBox "ok"
        
        ReDim toto(1)
        x = UBound(t)
    Else
        Msgbox"pas tableau"
    End If
End Sub

@f894009Merci, voilà les 2 procédures corrigées.

'Ajoute une valeur au tableau
Sub AjouteResultat(ByVal Texte As String)
    If IsArray(resultat) Then
        Dim taille As Integer
        taille = UBound(resultat) + 1
    Else
        taille = 1
    End If
    
    ReDim Preserve resultat(taille)
    resultat(taille - 1) = Texte
End Sub

'ajoute une valeur au tableau
Sub AjouteTroisChiffres(ByVal Entier As Integer)
    If IsArray(troisChiffres) Then
        Dim taille As Integer
        taille = UBound(troisChiffres) + 1
    Else
        taille = 1
    End If
    
    ReDim Preserve troisChiffres(taille)
    troisChiffres(taille - 1) = Entier
End Sub

VBA c'est pas trop mon truc, VB6, j'ai arrêté il y a plus de 10 ans.
Le mieux serait sans doute d’initialiser les tableaux directement à la bonne taille.
Mais je n'ai pas vraiment cherché de ce coté là.

@Utilisateur anonymeBonjour tout le monde,

Je n'ai pas encore eu le temps de tester ton code Whismeril, mais je le ferais dès que possible.
Pour éviter le Goto Etiquette, tu peux passer par une gestion d'erreur "simple" ou ne subsistera que le Goto 0 d'annulation (pas forcément utile, mais plus "propre") :

Sub AjouteResultat(ByVal Texte As String)
Dim taille As Integer
    
    On Error Resume Next
    taille = UBound(resultat) + 1
    If (Err.Number <> 0) Then taille = 1
'La ligne suivante peut être supprimée car pas très utile
    On Error GoTo 0 ' ==> seul Goto subsistant. 
    ReDim Preserve resultat(taille)
    resultat(taille - 1) = Texte
End Sub

@f894009 : Le problème de Whismeril n'est pas de savoir s'il a un Array ou non, il en a de part ses déclarations. Mais c'est d'utiliser UBound même lorsqu'aucune valeur n'a été mise dans son Array dynamique. IsArray est ici inopérant :

Sub test()
    Dim toto
    
    If IsArray(toto) Then
        MsgBox "ok"
        x = UBound(t) 'Erreur 9 l'indice n'appartient pas à la sélection   
        ReDim toto(1)
        x = UBound(t)
    Else
        Msgbox"pas tableau"
    End If
End Sub

Tu es forcé à un moment d'utiliser la gestion d'erreur si tu veux savoir si ton Array s'est déjà vu allouer une valeur, sauf à le dimensionner initialement...

En ce qui concerne le Goto, mon opinion est qu'il n'y a pas de contre indication à l'utiliser, mais, qu'il faut éloigner cet outil des mains des débutants.

Bonsoir,

Ce code utilise des goto, c'est déconseillé depuis tellement longtemps que je ne m'en souviens pas.
En plus, il est dit compatible avec Vb.net, ce qui est vrai à la condition d'importer les instruction vb6 dans vb.net, ce qui est aussi déconseillé. Bon vu que la demande concerne vba, on s'en fout un peu, mais quand même,

@Utilisateur anonymeBonjour Whismeril,

« Ce code utilise des goto, c'est déconseillé depuis tellement longtemps que je ne m'en souviens pas » : depuis plus de 20 ans !

Mais n'est-ce pas un des premiers hoax ?

Hormis le fait que certains trouvent que « cela rend le code moins compréhensible », y aurait une raison justifiée de bannir le Goto ?

Cdlt
Patrice

Salut, il y a cette discussion chez nos collègues de développez, qui contient quelques éléments, entre autre la possibilité de bug avec des labels placés "trop loin" et que le compilateur se marche dessus.

@Utilisateur anonymeBonjour,

nonossov en a besoin en Excel, donc le compilateur .......
Et les goto, ben y a rien contre, a partir du moment ou ca marche
Z'avez mieux a proposer?

@f894009Non rien de mieux sous la main, mais comme le sujet est récurrent je vais y réfléchir