Chiffres_lettres

Commenter

Contenu du snippet

' ********************************************************************************
' Conversion selon la nouvelle orthographe d'un montant monétaire en Euro (Lettres)
' ********************************************************************************
'
' Function Ecrite le 04/04/2009 par Louis LAFRUIT
' sur base (mais largement remaniée) de la macro diffusée le 10/10/2004 par Bob Anderson (xpatriot)
' http://www.vbfrance.com/codes/CONVERTIR-CHIFFRES-LETTRES_27511.aspx
'
' Attention : Cette fonction nécessite la présence de la fonction ChiffresVersLettres
'
' Cette macro fonctionne selon les règles de la nouvelle orthographe
' En ce qui concerne les numéraux la macro fonctionne en tenant compte du commentaire suivant:
' En parlant des "numéraux" le document officiel recommande l'emploi systématique des tirets ;
' la règle doit donc logiquement s'appliquer aussi bien aux adjectifs numéraux (un, deux, vingt, cent, mille...)
' qu'aux noms numéraux (million, milliard...).
' Néanmoins la macro contient des commentaires permettant d'ajuster la macro
' pour entourer les noms (million, milliard) d'espaces
'
' Cette macro fonctionne selon les usages belges (septante, nonante), mais contient des commentaires
' permettant de la transformer en mode français (soixante-dix, quatre-vingt-dix)
'
' Une remarque permet aussi de tenir compte de la particularité de la Suisse romande, ou l'on utilise huitante
' dans les cantons de Vaud, du Valais et de Fribourg

Source / Exemple : 


Option Explicit
Dim EuroMontant As Double
Dim CentMontant As Double
Dim EuroMontantLettres As String
Dim CentMontantLettres As String
Dim i As Integer
Dim UpTo19 As String
Dim Array_UpTo19() As String
Dim Tents As String
Dim Array_Tents() As String
Dim Mil As String
Dim Array_Mil() As String
Sub Chiffres_Lettres()
' ********************************************************************************
' Conversion selon la nouvelle orthographe d'un montant monétaire en Euro (Lettres)
' ********************************************************************************
'
'   Function Ecrite le 04/04/2009 par Louis LAFRUIT
'   sur base (mais largement remaniée) de la macro diffusée le 10/10/2004 par Bob Anderson (xpatriot)
' http://www.vbfrance.com/codes/CONVERTIR-CHIFFRES-LETTRES_27511.aspx
'
'       Attention : Cette fonction nécessite la présence de la fonction ChiffresVersLettres
'
'   Cette macro fonctionne selon les règles de la nouvelle orthographe
' En ce qui concerne les numéraux la macro fonctionne en tenant compte du commentaire suivant:
' En parlant des "numéraux" le document officiel recommande l'emploi systématique des tirets  ;
' la règle doit donc logiquement s'appliquer aussi bien aux adjectifs numéraux (un, deux, vingt, cent, mille...)
' qu'aux noms numéraux (million, milliard...).
'   Néanmoins la macro contient des commentaires permettant d'ajuster la macro
'       pour entourer les noms (million, milliard) d'espaces
'
'   Cette macro fonctionne selon les usages belges (septante, nonante), mais contient des commentaires
'       permettant de la transformer en mode français (soixante-dix, quatre-vingt-dix)
'
' Une remarque permet aussi de tenir compte de la particularité de la Suisse romande, ou l'on utilise huitante
'   dans les cantons de Vaud, du Valais et de Fribourg
'=============================================================================================
    With Selection
        ' Sélection du nombre complet quelle que soit la sélection initiale
        ' La marque de sélection doit néanmoins se situer soit immédiatement avant,
        '       soit à l'intérieur du nombre
        '
        Do While Not (.Characters.Last = " " Or .Characters.Last = Chr(13) Or .Characters.Last = Chr(160))
            .End = .End + 1
        Loop
        .End = .End - 1
        Do While Not (.Characters.First = " " Or .Characters.First = Chr(13) Or .Characters.Last = Chr(160))
            .Start = .Start - 1
        Loop
        .Start = .Start + 1
        If IsNumeric(Selection) Then
            ' Supression des points
            Selection = Replace(Selection, ".", "")
            ' Ne conserver que 2 décimales
            ' arrondi au centime supérieur à partir de 5 millièmes de centimes ET
            '   et suppression des 0 non significatifs
            ' Au cas ou le chiffre contient 0 centimes éliminer les centimes
            Selection = Round(Selection, 2)
        Else
            MsgBox Prompt:="La sélection ne correspond pas à un nombre", Buttons:=vbExclamation, Title:="ERREUR"
            Exit Sub
        End If
    End With

    'Récupèration des Euros et des Centimes
    i = InStr(1, Selection, ",")
    If i = 0 Then
        EuroMontant = Val(Selection)
        CentMontant = 0
    Else
        EuroMontant = Val(Left(Selection, i - 1))
        CentMontant = Val(Right(Selection, Len(Selection) - i))
    End If
    'Si le chiffre est trop grand => erreur
    If EuroMontant > 999999999999# Then
        MsgBox Prompt:="Nombre supérieur à 999.999.999.999,99", Buttons:=vbInformation, Title:="ERREUR"
        Exit Sub
    End If
    'Initialisation de constantes
    UpTo19 = " ;-un;-deux;-trois;-quatre;-cinq;-six;-sept;-huit;-neuf;-dix;-onze;-douze;-treize;-quatorze;-quinze;-seize;-dix-sept;-dix-huit;-dix-neuf"
    Array_UpTo19 = Split(UpTo19, ";")
    ' Pour tenir compte de la particularité de la Suisse romande, ou l'on utilise "huitante"
    '   dans les cantons de Vaud, du Valais et de Fribourg replacez la ligne suivant par celle-ci
    '    Tents = " ;-dix;-vingt;-trente;-quarante;-cinquante;-soixante;-septante;-huitante;-nonante"
    Tents = " ;-dix;-vingt;-trente;-quarante;-cinquante;-soixante;-septante;-quatre-vingt;-nonante"
    Array_Tents = Split(Tents, ";")
    Mil = ";-cent;-mille;-million;-milliard"
    ' Note: dans la nouvelle édition du Bon usage, André Goosse signale plusieurs interprétations possibles,
    '   et admet aussi bien le trait d'union que l'absence de trait d'union avec les noms numéraux.
    ' !!! A remplacer par la définition suivante si l'on ne veut l'absence de trait d'union avec les noms numéraux. !!!
    ' Mil = ";-cent;-mille; million; milliard"
    Array_Mil = Split(Mil, ";")
    ' Envoi de la valeur des Euros vers la fonction ChiffresVersLettres (voir plus bas)
    ' Gestion de l'absence d'euros
    If EuroMontant > 0 Then
        EuroMontantLettres = ChiffresVersLettres(EuroMontant, True)
        Select Case EuroMontant
            Case 1:
                EuroMontantLettres = EuroMontantLettres & " euro"
            Case Else
                ' Gestion des pluriels
                EuroMontantLettres = EuroMontantLettres & " euros"
        End Select
    End If
    If CentMontant = 0 Then
        ' Composition du résultat sans centimes
        ' La ligne suivante est réservée aux tests afin de présever le nombre
'        Selection.Start = Selection.End + 3
        Selection = Trim(EuroMontantLettres) & " "
    Else
        CentMontantLettres = ChiffresVersLettres(CentMontant, False)
        If EuroMontant = 0 Then
            ' Composition du résultat rien que des centimes
            CentMontantLettres = CentMontantLettres & " eurocentimes"
        Else
            ' Composition du résultat entiers et centimes
            ' Gestion des pluriels
            If CentMontant = 1 Then
                CentMontantLettres = CentMontantLettres & " centime"
            Else
                CentMontantLettres = CentMontantLettres & " centimes"
            End If
            ' La ligne suivante est réservée aux tests afin de présever le nombre
'            Selection.Start = Selection.End + 3
            Selection = Trim(EuroMontantLettres & " et " & CentMontantLettres) & " "
        End If
    End If

    '   Envoi de la valeur des Centimes vers la fonction ChiffresVersLettres (voir plus bas)
End Sub

'=============================================================================================
'
' ChiffresVersLettres
'
'   Function Ecrite le 04/04/2009 par Louis LAFRUIT
'   sur base (mais largement remaniée) de la macro diffusée le 10/10/2004 par Bob Anderson (xpatriot)
'
'=============================================================================================
Private Function ChiffresVersLettres(ValEuro As Double, Montant As Boolean) As String
    Dim strEuro As String
    Dim Result As String    ' Résultat partiel pour chaque groupe de chiffres d'une boucle
    Dim partResult As String        'Résultat global
    Dim NombreBoucle As Integer
    Dim boucle As Integer
    Dim StrEx As String
    Dim StrE As String
    Dim ValStrE As Integer
    Dim ValE As Integer
    Dim ValCent As Integer
    Dim ValDiz As Integer
    Dim BoolUnit As Boolean
    strEuro = Trim(Str(ValEuro))
    ' Nombre de boucles = nombre de groupes de 1 à 3 chiffres
    ' après avoir séparé les entiers et les décimales
    ' et en comptant de droite à gauche, mais les blocs sont traités de gauche à droite
    NombreBoucle = Int((Len(strEuro) + 2) / 3)
    'Traitement d'un groupe de 3 chiffres  en partant de la gauche
    For boucle = NombreBoucle To 1 Step -1
        StrEx = Right(strEuro, 3 * boucle)
        StrE = Left(StrEx, Len(StrEx) - 3 * (boucle - 1))
        ValStrE = Val(StrE)
        ValE = ValStrE
        partResult = ""
        Do
            BoolUnit = False
            Select Case ValE
                Case 0:
                    GoTo nxtBoucle
                Case Is > 99:
                    ValCent = Int(ValE / 100)
                    ' collecter les lettres des centaines y compris ou seulement "-cent"

                    ValE = ValE - (ValCent * 100)
                    If ValCent = 1 Then
                        partResult = Array_Mil(boucle)
                    Else
                        partResult = Array_UpTo19(ValCent) + "-cent"
                        ' 100 s'accorde quand il est multiplié par un nombre
                        '   sans être suivis par un autre nombre.
                        ' deux-cents mais deux-cent-trente-deux
                        ' et qu'il précède million ou milliard
                        If ValE = 0 Then
                            If boucle <> 2 Then partResult = partResult + "s"
                        End If
                    End If
                    If ValE = 0 Then Exit Do
                    BoolUnit = True
                Case Is > 19:
                    ValDiz = Int(ValE / 10)
                    ' Ligne suivante à inclure pour une version FRANCAISE
                    ' If ValDiz = 7 Or ValDiz = 9 Then ValDiz = ValDiz - 1
                    partResult = partResult + Array_Tents((ValDiz))
                    If ValE = 80 Then partResult = partResult + "s"
                    ValE = ValE - (ValDiz * 10)
                    ' si les unités restantes sont > 0 alors il faut encore trater ces unités
                    If ValE = 0 Then Exit Do
                    BoolUnit = True
                Case 2 To 19:
                    partResult = partResult + Array_UpTo19(ValE)
                    Exit Do
                Case 1:
                    If partResult = "" Then
                        If boucle <> 2 Then
                            partResult = "-un"
                        End If
                    Else
                        ' Particularité de quatre-vingt-un
                        If ValDiz <> 8 Then
                            partResult = partResult + "-et-un"
                        Else
                            partResult = partResult + "-un"
                        End If
                    End If
            End Select
        Loop Until ValE < 10 And BoolUnit = False
        If Montant = True Then
            'Ce sont les entiers
            Select Case boucle
                Case 1:    ' Collecter cent
                Case 2:    '  Collecter Mille qui est invariable
                    partResult = partResult + Array_Mil(boucle)
                Case Else:    ' Collecter  million, milliard
                    partResult = partResult + Array_Mil(boucle)
                    If ValStrE > 1 Then partResult = partResult + "s"
                    ' !!! ajouter ligne suivante si millios et milliards sans traits d'union !!!
                    ' partResult = partResult + " "
            End Select
            If Result = "" Or Right(Result, 1) = " " Then
                If Left(partResult, 1) = "-" Then partResult = Right(partResult, Len(partResult) - 1)
            End If
        Else
            ' ce sont les décimales
            If Left(partResult, 1) = "-" Then partResult = " " + Right(partResult, Len(partResult) - 1)
        End If
        Result = Result + partResult
nxtBoucle:
    Next boucle
    ChiffresVersLettres = Trim(Result)
End Function

Conclusion :


Merci à Anderson pour son coup de pouce
S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.