cette fonction converti n'importe quel nombres en toutes lettres avec la monnaie "Euro" en francais
voir la discussion et surtout les mises a jour ICI
exemple
voir la discussion et surtout les mises a jour ICI
VB:
Function NblettreFR(chain As String) As String
Dim t, dixx&, dix&, cxx&, u&, Part, ms, m, Ul, Diz, n&, I&, seg$, cc$, et$, Ss$, R$, md$, euro$, centime
Ul = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", "dix", "onze", "douze", "treize", "quatorze", "quinze", "seize", "dix-sept", "dix-huit", "dix-neuf", "cent ")
Diz = Array("", "dix", "vingt", "trente", "quarante", "cinquante", "soixante", "soixante-dix", "quatre-vingt", "quatre-vingt-dix", "cent")
ms = Array("", " decilliard", " decillion", " nonilliard", " nonillion", " octillard", " octillion", " septilliard", " septillion", " sextilliard", " sextillion", " quintilliard ", " Quintillion", " quadrilliard", " quadrillion", " trilliard", " trillion", " Billiard", " billion", " milliard", " million", " mille", "")
If LCase(chain) Like "*[a-z|:|;|/|\]*" Then NblettreFR = "Invalid Chaine!!": Exit Function
Part = Split(chain, ","): If Len(Part(0)) > 66 Then NblettreFR = "OutOFF(CAR*66)!!": Exit Function
euro = IIf(Val(Part(0)) > 999000 And Val(Right(Part(0), 6)) = 0, "d'euro", "euro") & IIf(Part(0) > 1, "s ", " ") & IIf(UBound(Part) > 0, "et ", "")
centime = IIf(UBound(Part) > 0, "Centime", "")
For n = LBound(Part) To UBound(Part)
t = Split(Trim(Format(String((300 - Len(Part(n))) Mod 3, "0") & Part(n), WorksheetFunction.Rept(" @@@", Len(String((300 - Len(Part(n))) Mod 3, "0") & Part(n)) / 3))))
If n = 1 Then If Len(Part(1)) = 1 Then t = Array("0" & Part(1) & "0") 'ajustement centime(0.5 = 0.50)
m = UBound(ms) - UBound(t)
For I = LBound(t) To UBound(t)
cxx = Left(t(I), 1): dixx = Right(t(I), 2): dix = Mid(t(I), 2, 1): u = Right(t(I), 1)
If cxx = 1 Then cxx = 20: cc = "" Else cc = IIf(cxx > 0, " cent ", "")
If dix = 9 Or dix = 7 Then dix = dix - 1: u = Val(u) + 10
If dixx > 9 And dixx < 20 Then dix = 0: u = u + 10
If dix >= 2 And dix <= 7 And (u = 1 Or u = 11) Then et = " et " Else et = IIf(dix <> 0 And u <> 0, "-", " ")
If dixx = 80 Then Ss = "s" Else Ss = ""
If I = UBound(t) - 1 And Part(0) = 1000 Then u = 0
md = ms(m): If Val(t(I)) > 1 And I < UBound(t) - 1 Then md = md & "s"
R = R & Application.Trim(Ul(cxx) & cc & Diz(dix) & et & Ul(u)) & Ss & IIf(Val(t(I)) > 0, md, "") & " "
m = m + 1
Next
If Val(Part(0)) = 0 Then euro = ""
R = R & IIf(n = 0, euro, centime): If n = 1 Then If Part(1) > 1 Then R = R & "s" & IIf(Part(0) = 0, " d'euro", "")
If Trim(R) = "" Then R = ""
Next n
NblettreFR = Trim(R)
End Function
exemple
VB:
Sub test()
Debug.Print NblettreFR("191471851,56")'en string'
Debug.Print NblettreFR(191471851.56)'en numerique'
End Sub
- Auteur
- patricktoulon
- Version
- 2.0