Access - Les Sources

Sommaire > Divers > Fonctions de conversion et de calcul
        Calculer la médiane d'une colonne numérique d'une table (mathématique)
        Convertir des nombres en chiffres romains
        Convertir les noms et prénom en noms propres qu'ils soient composés ou non.
        Convertir une date Julienne au format jj/mm/yyyy
        Determiner le nombre de jours entre deux dates. (Par exemple nombre de lundi)
        Extraire et mettre en forme le nom de rue d'une adresse afin de faciliter la recherche.
        Fonctions mathématiques dérivées (Arcsinus, fonctions hyperboliques...)
        Mise en majuscule de la première lettre du prénom (simple, composé, avec espace, tiret ou non)
        Traduire une date
        Transformer des chiffres en lettres. Avec décimal ou non

Auteur : Tofalu
Version : 08/10/2005

Calculer la médiane d'une colonne numérique d'une table (mathématique)

[haut]

Versions : Toutes

La médiane est la valeur qui se trouve au centre d'un ensemble de nombres. En d'autres termes, les nombres appartenant à la première moitié de l'ensemble ont une valeur inférieure à la médiane, tandis que ceux appartenant à l'autre moitié ont une valeur supérieure à la médiane.

Exemple :

MEDIAN(1, 2, 3, 4, 5) égal 3
MEDIAN(1, 2, 3, 4, 5, 6) égal 3.5, moyenne de 3 et 4

Public Function fMediane(strTable As String, strField As String) As Variant 

Dim oDBS As DAO.Database 
Dim oRST As DAO.Recordset 
Dim blnEven As Boolean 
Dim vntMedian As Variant 

  Set oDBS = CurrentDb() 
  Set oRST = oDBS.OpenRecordset("SELECT * FROM " & strTable & " ORDER BY " & strField) 
  
  If oRST.EOF = False Then 
     oRST.MoveLast 
     'Is there an even number of records in the recordset? 
     blnEven = (oRST.RecordCount Mod 2 = 0) 
     'Rounds down if there is an even number of records... 
     oRST.PercentPosition = 50 
     vntMedian = oRST.Fields(strField) 
     If blnEven Then 
         oRST.MoveNext 
         '...so take the average of the this and the next value up 
         vntMedian = (vntMedian + oRST.Fields(strField)) / 2 
     End If 
  End If 
  
  fMediane = vntMedian 
  oRST.Close 
  Set oRST = Nothing 
  Set oDBS = Nothing 

End Function

Test :

Sub TesterExemple() 
'Code client 
'----------- 
'ALFKI 
'ANATR 
'ANTON 
'AROUT 
'BERGS 
'BLAUS 
'BLONP 
'BOLID 
'BONAP 
MsgBox fMediane("TBLClients", "[Code client]") 
'Renvoie "BERGS" 
End Sub

Auteur : Tofalu
Version : 05/03/2005
Page de l'auteur

Convertir des nombres en chiffres romains

[haut]

Ce code permet de convertir des nombres en chiffres romains. La plage de conversion s'étend de 0 à 3999.

Dans un module :

Function ChiffreRomain(ByVal Nombre As Integer) As String
Dim TNombre() As String
Dim i As Integer, Unite As Integer
If Nombre < 4000 Then
TNombre = Split("I,V,X,L,C,D,M", ",")
  While Nombre > 0
    Unite = Nombre Mod 10
    Nombre = Nombre \ 10
    Select Case Unite
      Case 1 To 3
        ChiffreRomain = String(Unite, TNombre(i)) & ChiffreRomain
      Case 4
        ChiffreRomain = TNombre(i) & TNombre(i + 1) & ChiffreRomain
      Case 5 To 8
        ChiffreRomain = TNombre(i + 1) & String(Unite - 5, _
               TNombre(i)) & ChiffreRomain
      Case 9
        ChiffreRomain = TNombre(i) & TNombre(i + 2) & _
               ChiffreRomain
    End Select
     i = i + 2
  Wend
End If
End Function

Utilisation :

MsgBox ChiffreRomain(49)

Auteur : Argyronet
Version : 12/11/2005
Page de l'auteur

Convertir les noms et prénom en noms propres qu'ils soient composés ou non.

[haut]

Versions : Access 2000 et supérieures. Access 97 avec utilisation de la fonction Split issues des codes sources.

Pour convertir une chaine de caractères en nom propre (1ère lettre du mot en majuscule) il est possible d'utiliser l'expression suivante:

strLastName=StrConv(strLastName, vbProperCase)

Cela marche très bien si peu que le prénom ou le nom est composé d'un seul mot. En revanche, lorsqu'il y a une succession de mots séparés par un tiret ou un autre caractère, ce n'est plus opérationel. Voici une petite fonction qui répond au problème.

Public Function GetProperName(ByVal TextToConvert As String) As String 
Dim aSeparatorStrings() As String 
Dim aSeparatorChar() As String 
Dim aSeparatorsPos() As String 
Dim aWords() As String 
Dim sSeparators As String 
Dim sTempChar As String 
Dim sTempResult As String 
Dim I As Integer 
Dim S As Integer 
Dim sSeparatorsPos As String 
Dim iNBSeparators As Integer 
Dim sLastChar As String 

  On Error GoTo L_ErrConversion 

  sSeparators = "| |;|:|-|~|@|_|&|*|#|'| " 'Last space = 160 
  aSeparatorStrings = Split(sSeparators, "|") 
  For I = 1 To Len(TextToConvert) 
    sTempChar = Mid(TextToConvert, I, 1) 
      For S = LBound(aSeparatorStrings) To UBound(aSeparatorStrings) 
        If sTempChar = aSeparatorStrings(S) Then 
          iNBSeparators = iNBSeparators + 1 
          ReDim Preserve aSeparatorChar(0 To iNBSeparators) 
          aSeparatorChar(iNBSeparators - 1) = sTempChar 
          sSeparatorsPos = sSeparatorsPos + Trim(str(I)) & ";" 
          Exit For 
        End If 
      Next 
  Next 
  If iNBSeparators = 0 Then 
    sTempResult = UCase(Left(TextToConvert, 1)) & LCase(Mid(TextToConvert, 2)) 
  Else 
    sSeparatorsPos = IIf(Right(sSeparatorsPos, 1) = ";", Left(sSeparatorsPos, _
     Len(sSeparatorsPos) - 1), sSeparatorsPos) 
    sSeparatorsPos = "1;" & sSeparatorsPos & ";" & Trim(str(Len(TextToConvert))) 
    I = 0: S = 0 
    aSeparatorsPos = Split(sSeparatorsPos, ";") 
    ReDim aWords(1 To iNBSeparators + 1) 
  
    For I = 1 To iNBSeparators + 1 
      sLastChar = IIf(I = (iNBSeparators + 1), vbNullString, aSeparatorChar(I - 1)) 
      If I = 1 Then 
        aWords(I) = UCase(Mid(TextToConvert, 1, 1)) & LCase(Mid(TextToConvert, _
    2, aSeparatorsPos(I) - 2)) & sLastChar 
      Else 
        S = IIf(I = (iNBSeparators + 1), 1, 2) 
        aWords(I) = UCase(Mid(TextToConvert, aSeparatorsPos(I - 1) + 1, 1)) & _
   LCase(Mid(TextToConvert, aSeparatorsPos(I - 1) + 2, aSeparatorsPos(I) - _
   aSeparatorsPos(I - 1) - S)) & sLastChar 
      End If 
    Next 
    For I = 1 To iNBSeparators + 1 
      sTempResult = sTempResult & aWords(I) 
    Next 
  End If 
L_ExConversion: 
  GetProperName = sTempResult 
  Erase aSeparatorStrings 
  Erase aSeparatorChar 
  Erase aSeparatorsPos 
  Exit Function 
L_ErrConversion: 
  MsgBox "Une erreur est survenue durant la  conversion de la chaîne de caractère...", _
    48, "Conversion échouée" 
  sTempResult = TextToConvert 
  Resume L_ExConversion 
End Function

Mode d'utilisation :

Debug.Print GetProperName("charles-henri de l'arbre aux mésanges bleues")

Bien, c'est pas très commun comme nom de famille mais bon, cela retourne:

Charles-Henri De L'Arbre Aux Mésanges Bleues

Note :

Les caractères de séparation pris en compte sont:

L'espace, le point-virgule, les deux points, le tiret, le tilde, l'arobase, le underscore, le symbole de concaténation, l'astérisque, le dièse, l'apostrophe et l'espace caché.

Vous pouvez modifier ce tableau à votre convenance.

Auteur : Tofalu
Version : 05/03/2005
Page de l'auteur

Convertir une date Julienne au format jj/mm/yyyy

[haut]

Cette fonction convertit une date julienne (utilisée par les AS400) du type 105047 en 16/02/2005. Si une erreur se produit lors de la conversion, la fonction retourne la date : 30/12/1899.

Function DateFromJulian(LaDate as string) as date
On error goto err
   Dim Annee as integer
   Dim Jour as integer
   Dim Temp as date
   Annee=1900+Cint(Left(Ladate,1))*100+Cint(mid(LaDate,2,2))
   Temp=DateSerial(Annee,1,1)
   Jour=Cint(Right(LaDate,3))
   DateFromJulian=DateAdd("d",Jour-1,Temp)
err:
End function

Utilisation dans une requête :

SELECT DateFromJulian(MaDate) FROM MaTable

Explications :

Le premier chiffre de la date julienne correspond au siècle. 0 pour 1900, 1 pour 2000
Les deux suivants, l'année dans le siècle.
Enfin les trois derniers correspondent au numéro du jour dans l'année.

Auteur : Tofalu
Version : 28/01/2005
Page de l'auteur

Determiner le nombre de jours entre deux dates. (Par exemple nombre de lundi)

[haut]

Versions : 2000 et supérieures

Public Function njour(jour As VbDayOfWeek, date1 As Date, date2 As Date) As Integer 
Dim d As Date 
Dim i As Integer 
If date1 > date2 Then 
    MsgBox "Impossible de calculer, date2 doit être supérieur à date1" 
Else 
i = Weekday(date1) 
If i > jour Then 
i = 7 - i + jour 
Else 
i = jour - i 
End If 
d = DateAdd("d", i, date1) 
If d < date2 Then njour = njour + 1 
njour = njour + DateDiff("d", d, date2) \ 7 
End If 
End Function

Auteur : Fred.G
Version : 05/03/2005

Téléchargez le zip

Extraire et mettre en forme le nom de rue d'une adresse afin de faciliter la recherche.

[haut]

Ce module complet propose des fonctions afin d'extraire et mettre en forme le nom de rue d'une adresse. Cette mise en forme offre la possibilité de trier de manière alphabétique les noms des rues dans une requête, alimentant par exemple une zone liste modifiable dans un formulaire de saisie des adresses.

Il permet par exemple de transformer :

46 bis Rue de la Paix par Rue de la Paix ou bien Paix (Rue de la).

Dans un module placez le code suivant :

Function fNomVoie(ByVal str As String) As String

Dim strMotsClés As String, strMotsSecondaires As String, _
strMot As String

'Vérifie qu'une chaine de longueur non nulle a été passée
If str = "" Then Exit Function
strMotsClés = Trim(str)
''fVoieSansNum sert uniquement à vérifier si strMotsClés commence _
'par un numéro de voie (avec ou sans Bis/B) _
'Afin de ne pas tenir compte de ce numéro s'il existe. _
'Cette procédure est donc facultative si vous stockez le numéro de voie _
'(et la mention "Bis ou B") dans un champ à part. _
'fVoieSansNum reconnait les doubles numéros _
's'ils sont séparés par un tiret, une virgule ou une esperluette _
'avec ou sans espaces.
strMotsClés = fVoieSansNum(strMotsClés)

strMot = fPremierMot(strMotsClés)
Do Until fMotClé(strMot)
  strMotsSecondaires = strMotsSecondaires & " " & strMot
  strMotsClés = LTrim(Right(strMotsClés, Len(strMotsClés) - Len(strMot)))
  strMot = fPremierMot(strMotsClés)
Loop
If Len(LTrim(strMotsSecondaires)) > 0 Then _
  strMotsSecondaires = " (" & LTrim(strMotsSecondaires) & ")"
fNomVoie = strMotsClés & strMotsSecondaires

End Function

Function fPremierMot(str As String)
'Cette fonction renvoie le premier mot contenu dans str
Dim lng As Long
Dim strMot As String
For lng = 1 To Len(str)
  Select Case Mid(str, lng, 1)
    Case " "
      strMot = Left(str, lng - 1)
      fPremierMot = strMot
      Exit Function
    Case "'"
      strMot = Left(str, lng)
      fPremierMot = strMot
      Exit Function
  End Select
Next lng
fPremierMot = str
End Function

Function fMotClé(str As String) As Boolean
'Cette fonction indique si str correspond à un mot clé. _
'C'est à dire s'il est différent d'un simple article ou d'un type de voie).
Select Case str
  Case "Rue", "Boulevard", "Avenue", "Chemin", "Passage", "Traverse", _
      "Route", "Place", "Allée", "Allées", "Esplanade", "Quai", _
      "-", "le", "la", "les", "l'", "du", "de", "des", "d'", _
    fMotClé = False
  Case Else
    fMotClé = True
End Select
End Function

Function fVoieSansNum(ByVal Voie As String) As String
'Cette fonction reconnait les doubles numéros _
's'ils sont séparés par un tiret, une virgule ou une esperluette _
'avec ou sans espaces.
'Cette fonction peut être utilisée seule ou en 
'complément de la fonction fNomVoie
Dim str As String
Dim bte As Byte, bteFinNum As Byte
Voie = Replace(Voie, ",", "")
str = Left$(Voie, 1)
If Not IsNumeric(str) Then
  fVoieSansNum = Voie
Else
  bte = 1
  Do
    If IsNumeric(str) Then
      bteFinNum = bte
      Do
        bte = bte + 1
        str = Mid$(Voie, bte, 1)
      Loop Until str <> " "
    Else
      Select Case str
        Case "-", "&"
          Do
            bte = bte + 1
            str = Mid$(Voie, bte, 1)
          Loop While str = " "
          If Not IsNumeric(str) Then
            Exit Do
          End If
        Case "b"
          If Mid$(Voie, bte, 3) = "bis" Then
            Select Case Mid$(Voie, bte + 3, 1)
              Case " "
                bte = bte + 3
                bteFinNum = bte
                Do
                  bte = bte + 1
                  str = Mid$(Voie, bte, 1)
                Loop While str = " "
              Case "-", "&"
                bte = bte + 3
                str = Mid$(Voie, bte, 1)
              Case Else
                Exit Do
            End Select
          Else
            Select Case Mid$(Voie, bte + 1, 1)
              Case " "
                bte = bte + 1
                bteFinNum = bte
                Do
                  bte = bte + 1
                  str = Mid$(Voie, bte, 1)
                Loop While str = " "
              Case "-", "&"
                bte = bte + 1
                str = Mid$(Voie, bte, 1)
              Case Else
                'Fin du numéro
                Exit Do
            End Select
          End If
        Case Else
          'Fin du numéro
          Exit Do
      End Select
    End If
  Loop
  fVoieSansNum = Trim$(Right$(Voie, Len(Voie) - bteFinNum))
End If
End Function

Utilisation des fonctions :

Msgbox fVoieSansNum("90-92 Rue Meynadier")

Affiche : Rue Meynadier

Msgbox fNomVoie("90-92 Rue Meynadier")

Affiche : Meynadier (Rue)

Remarques :

Select Case str
  Case "Rue", "Boulevard", "Avenue", "Chemin", "Passage", "Traverse", _
      "Route", "Place", "Allée", "Allées", "Esplanade", "Quai", _
      "-", "le", "la", "les", "l'", "du", "de", "des", "d'", _
    fMotClé = False
  Case Else
    fMotClé = True
End Select

Vous pouvez compléter vous-même la fonction fMotClé en ajoutant dans le premier Case, des mots "non-clés" (c'est à dire à ne pas considérer comme des noms de voie).

Vous trouverez une base de données utilisant ces fonctions dans une requête et un formulaire dans le fichier zip téléchargeable.

Auteur : Tofalu
Version : 05/03/2005
Page de l'auteur
Téléchargez le zip

Fonctions mathématiques dérivées (Arcsinus, fonctions hyperboliques...)

[haut]

Versions : 97 et supérieures

Voici une liste de fonctions mathématiques dérivées des fonctions disponibles dans Access telles que sinus,cosinus et tangente.

Fonction sécante :

Public Function Secante(Valeur As Double) As Double
Secante = 1 / Cos(Valeur)
End Function

Fonction cosécante :

Public Function CoSecante(Valeur As Double) As Double
CoSecante = 1 / Sin(Valeur)
End Function

Fonction cotangente :

Public Function CoTangente(Valeur As Double) As Double
CoTangente = 1 / Tan(Valeur)
End Function

Fonction arcsinus :

Public Function ArcSinus(Valeur As Double) As Double
ArcSinus = Atn(Valeur / Sqr(-Valeur * Valeur + 1))
End Function

Fonction arccosinus :

Public Function ArcCosinus(Valeur As Double) As Double
ArcCosinus = Atn(-Valeur / Sqr(-Valeur * Valeur + 1)) + _
  2 * Atn(1)
End Function

Fonction arcsécante :

Public Function ArcSecante(Valeur As Double) As Double
ArcSecante = Atn(Valeur / Sqr(Valeur * Valeur - 1)) + _
    Sgn((Valeur) - 1) * (2 * Atn(1))
End Function

Fonction arccosécante :

Public Function ArcCoSecante(Valeur As Double) As Double
ArcCoSecante = Atn(Valeur / Sqr(Valeur * Valeur - 1)) + _
  (Sgn(Valeur) - 1) * (2 * Atn(1))
End Function

Fonction arccotangente :

Public Function ArcCoTangente(Valeur As Double) As Double
ArcCoTangente = Atn(Valeur) + 2 * Atn(1)
End Function

Fonction sinus hyperbolique :

Public Function SinusHyperbolique(Valeur As Double) As Double
SinusHyperbolique = (Exp(Valeur) - Exp(-Valeur)) / 2
End Function

Fonction cosinus hyperbolique :

Public Function CosinusHyperbolique(Valeur As Double) As Double
CosinusHyperbolique = (Exp(Valeur) + Exp(-Valeur)) / 2
End Function

Fonction tangente hyperbolique :

Public Function TangenteHyperbolique(Valeur As Double) As Double
TangenteHyperbolique = (Exp(Valeur) - Exp(-Valeur)) / _
  (Exp(Valeur) + Exp(-Valeur))
End Function

Fonction sécante hyperbolique :

Public Function SecanteHyperbolique(Valeur As Double) As Double
SecanteHyperbolique = 2 / (Exp(Valeur) + Exp(-Valeur))
End Function

Fonction cosécante hyperbolique :

Public Function CosecanteHyperbolique(Valeur As Double) As Double
CosecanteHyperbolique = 2 / (Exp(Valeur) - Exp(-Valeur))
End Function

Fonction cotangente hyperbolique :

Public Function CoTangenteHyperbolique(Valeur As Double) As Double
CoTangenteHyperbolique = (Exp(Valeur) + Exp(-Valeur)) / _
  (Exp(Valeur) - Exp(-Valeur))
End Function

Fonction arcsinus hyperbolique :

Public Function ArcSinusHyperbolique(Valeur As Double) As Double
ArcSinusHyperbolique = Log(Valeur + Sqr(Valeur * Valeur + 1))
End Function

Fonction arccosinus hyperbolique :

Public Function ArcCosinusHyperbolique(Valeur As Double) As Double
ArcCosinusHyperbolique = Log(Valeur + Sqr(Valeur * Valeur - 1))
End Function

Fonction arctangente hyperbolique :

Public Function ArcTangenteHyperbolique(Valeur As Double) As Double
ArcTangenteHyperbolique = Log((1 + Valeur) / (1 - Valeur)) / 2
End Function

Fonction arcsécante hyperbolique :

Public Function ArcSecanteHyperbolique(Valeur As Double) As Double
ArcSecanteHyperbolique = Log((Sqr(-Valeur * Valeur + 1) + 1) / Valeur)
End Function

Fonction arccosécante hyperbolique :

Public Function ArcCosecanteHyperbolique(Valeur As Double) As Double
ArcCosecanteHyperbolique = Log((Sgn(Valeur) * _
  Sqr(Valeur * Valeur + 1) + 1) / Valeur)
End Function

Fonction arccotangente hyperbolique :

Public Function ArcCoTangenteHyperbolique(Valeur As Double) As Double
ArcCoTangenteHyperbolique = Log((Valeur + 1) / (Valeur - 1)) / 2
End Function

Fonction logarithme de base N :

Public Function LogBaseN(Valeur As Double, BaseN) As Double
LogBaseN = Log(Valeur) / Log(BaseN)
End Function

Vous pouvez télecharger l'ensemble de ses fonctions regroupées dans un fichier .bas en cliquant sur le lien : télechargez le zip.

Auteur : Papilou
Version : 27/08/2004

Mise en majuscule de la première lettre du prénom (simple, composé, avec espace, tiret ou non)

[haut]

Versions : 2000 et supérieures

Cette fonction permet de mettre la première lettre de chaque mot en majuscule. Cela peut être très utile pour les prénoms composés

Option Compare Database
Function MiseEnMajuscule(Chaine As String) As String
Dim nCar As Integer  'Compteur (position dans la chaine à traiter)

Chaine = Trim$(Chaine) 'Récupère la chaîne sans les espaces facultatifs
'Traitement spécifique sur le premier caractère
MiseEnMajuscule = UCase$(Left(Chaine, 1))
'Début de la boucle sur les autres caractères
For nCar = 2 To Len(Chaine)
'Teste le caractère précédent (" " ou "-")
If (Mid$(Chaine, nCar - 1, 1) = " ") Or (Mid$(Chaine, nCar - 1, 1) = "-") Then
'Si c'est vrai, mettre en majuscule le caractère courant
MiseEnMajuscule = MiseEnMajuscule & UCase$(Mid(Chaine, nCar, 1))
Else
'Si c'est faux, mettre en minuscule le caractère courant
MiseEnMajuscule = MiseEnMajuscule & LCase$(Mid(Chaine, nCar, 1))
End If
'Fin de la boucle sur les caractères
Next
End Function

Utilisation :

Msgbox MiseEnMajuscule("jean-paul")

Ceci affichera : Jean-Paul

Auteur : Tofalu
Version : 20/05/2005
Page de l'auteur

Traduire une date

[haut]

Version : Access 2000 et supérieures

Cet exemple de code vous propose une fonction de conversion permettant de traduire une date en différentes langues.

Par exemple :

Langue	Date
Français	Paris, le 10 Mai 2005
Anglais	Paris, May 10th 2005
Allemand	Paris, den 10. Mai 2005
Espagnol	Paris, 10 de mayo

Dans un module, placez le code suivant :

Option Compare Database
Option Explicit
Public Enum Langue
  langueFrancais
  langueAnglais
  langueAllemand
  langueespagnol
End Enum

Public Function TradDate(strLocalite As String, dteDate As Date, lanLangue As Langue) As String
Dim strListeMoisLang(4) As String
Dim strTemp As String
'La taille doit correspondre au nombre de langue
Dim strMois() As String
'Initialise le tableau des langues

strListeMoisLang(Langue.langueFrancais) = _
"Janvier;Février;Mars;Avril;Mai;Juin;Juillet;Août;Septembre;Octobre;Novembre;Décembre"


strListeMoisLang(Langue.langueAnglais) = _
"January;February;Mars;April;May;June;July;August; September;October;November;December"

strListeMoisLang(Langue.langueAllemand) = _
"Januar;Februar; an März;April;Mai;Juni;Juli;August;September;Oktober;November;Dezember"

strListeMoisLang(Langue.langueespagnol) = _
"El enero;febrero;marzo;abril;mayo;junio;julio;agosto;septiembre;octubre;noviembre;diciembre"

'Récupère la liste des mois de la langue sélectionnée dans un tableau
strMois = Split(strListeMoisLang(lanLangue), ";")

Select Case lanLangue
  Case Langue.langueFrancais
      strTemp = "le " & Day(dteDate) & " " & strMois(Month(dteDate) - 1) & " " & Year(dteDate)
  Case Langue.langueAnglais
      strTemp = strMois(Month(dteDate) - 1) & " " & Day(dteDate)
        'Ajoute la numérotaion ordinale
        Select Case Day(dteDate)
          Case 1: strTemp = strTemp & "st"
          Case 2: strTemp = strTemp & "nd"
          Case 3: strTemp = strTemp & "rd"
          Case Else: strTemp = strTemp & "th"
        End Select
      strTemp = strTemp & ", " & Year(dteDate)
  Case Langue.langueAllemand
      strTemp = "den " & Day(dteDate) & ". " & strMois(Month(dteDate) - 1) & " " & Year(dteDate)
  Case Langue.langueEspagnol
      strTemp =  Day(dteDate) & " de " & strMois(Month(dteDate) - 1) & " " & Year(dteDate)
End Select
TradDate = strLocalite & ", " & strTemp
End Function

Exemple d'utilisation :

MsgBox TradDate("Metz", Now, langueAllemand)

N'hésitez pas à ajouter de nouvelles langues et à me les faire parvenir pour une future intégration dans cette page.

Auteur : HelpClic
Version : 27/08/2004

Transformer des chiffres en lettres. Avec décimal ou non

[haut]

Versions : 97 et supérieures

 Option Compare Database

Dim mot$(25), Résultat$, N$
Dim Virgule, B, K$, nombre$, longueur
Dim cdu$, C$, D$, U$, Et, Tiret


Sub Ajoute(MotSimple$)
'--- ajoute un nouveau terme traduit à la chaine résultat
If Résultat$ <> "" Then
'--- vérifie s'il est nécessaire de coller le nouveau terme au
'--- précédent dans le cas des "S" à rajouter, ou des tirets
If Right$(Résultat$, 1) = "-" Or _
MotSimple$ = "s" Or MotSimple$ = "-" Then
Résultat$ = Résultat$ + MotSimple$
'--- sinon, ajoute le terme après un espace
Else
Résultat$ = Résultat$ + " " + MotSimple$
End If
Else
Résultat$ = MotSimple$
End If
End Sub


Function Equivalent$(Valeur)
'--- recherche le mot équivalent à une valeur numérique
Select Case Valeur
Case Is < 21
Equivalent$ = mot$(Valeur)
Case Else
Equivalent$ = mot$(18 + (Valeur / 10))
End Select
End Function


Function Nb2Mot$(Valeur$)
Dim a$
'--- initialisation du tableau contenant les mots interprétés
mot$(1) = "un"
mot$(2) = "deux"
mot$(3) = "trois"
mot$(4) = "quatre"
mot$(5) = "cinq"
mot$(6) = "six"
mot$(7) = "sept"
mot$(8) = "huit"
mot$(9) = "neuf"
mot$(10) = "dix"
mot$(11) = "onze"
mot$(12) = "douze"
mot$(13) = "treize"
mot$(14) = "quatorze"
mot$(15) = "quinze"
mot$(16) = "seize"
mot$(20) = "vingt"
mot$(21) = "trente"
mot$(22) = "quarante"
mot$(23) = "cinquante"
mot$(24) = "soixante"
'--- récupération de paramètre passé
a$ = Valeur$ + " "
'--- initialisation des variables de travail
N$ = ""
Virgule = 0
Résultat$ = ""
'--- pour toute la longueur de celui-ci
For B = 1 To Len(a$)
'--- on extrait chacun de ses caractères
K$ = Mid$(a$, B, 1)
Select Case K$
'--- gère les montants négatifs
Case "-"
Ajoute "moins"
'--- si ceux-ci sont numériques, on batit la chaine n$
Case "0" To "9"
N$ = N$ + K$
'--- sinon, on teste si on est arrivé à une virgule
Case Else
If Virgule = 1 Then
'--- les centimes sont comptés sur 2 digits, réajustés de
'--- manière inverse aux euros, puisqu'on lit les unités
'--- et dizaines de manière inversée (0,2? = 20c et
'--- 0,02?=2c)
N$ = Right$("000" + Left$(N$ + "000", 2), 2)
If Val(N$) = 0 Then N$ = ""
End If
'--- on traduit le nombre stocké dans n$
TraduireEntier N$
'--- puis on détermine son unité en fonction de la présence
'--- ou non d'une virgule
If Virgule = 0 And Val(N$) > 0 Then
Ajoute "euro"
'--- et on accorde l'unité avec le nombre
If Val(N$) > 1 Then Ajoute "s"
ElseIf Virgule = 1 And Val(N$) > 0 Then
Ajoute "centime"
'--- en ajoutant un "s" si nécessaire
If Val(N$) > 1 Then Ajoute "s"
End If
N$ = ""
Select Case K$
Case Chr$(13)
B = B + 1
Case Is < " "
Case ",", "."
Virgule = 1
'--- si une valeur en euros est exprimée, et que le
'--- nombre de centimes est suffisant pour être traité,
'--- on lie les 2 par le mot "et"
If Val(a$) <> 0 And _
Val("0." + Mid$(a$, B + 1)) >= 0.01 Then Ajoute "et"
Case Else
End Select
End Select
Next
Nb2Mot$ = Résultat$

End Function

Sub TraduireEntier(NombreATraduire$)
'--- convertit un nombre entier contenu dans une chaine de caractères
'--- en son équivalent ordinal
nombre$ = NombreATraduire$
If nombre$ <> "" Then
'--- si le nombre est 0, on ne perd pas de temps
If Val(nombre$) = 0 Then
Ajoute "zéro"
Else
'--- sinon, on convertit celui-ci en une chaine de caractères
'--- de longueur multiple de 3, afin de pouvoir la lire par blocs
'--- de 3 caractères
nombre$ = Right$("000", -((Len(nombre$) Mod 3) <> 0) * (3 - (Len(nombre$) Mod 3))) _
         + nombre$
For longueur = Len(nombre$) To 3 Step -3
cdu$ = Left$(nombre$, 3)
nombre$ = Right$(nombre$, longueur - 3)
'--- on extrait ainsi des ensembles de 3 chiffres, de la
'--- gauche vers la droite
If cdu$ <> "000" Then
'--- dont on tire une valeur de centaines, dizaines et
'--- unités
C$ = Left$(cdu$, 1)
D$ = Mid$(cdu$, 2, 1)
U$ = Right$(cdu$, 1)
'--- on convertit les unités non muettes pour les
'--- centaines
If C$ >= "2" Then Ajoute Equivalent$(Val(C$))
'--- et on traite les 1 muets
If C$ >= "1" Then
Ajoute "cent"
'--- en appliquant les règles d'accords pour les
'--- centaines
If Val(nombre$) = 0 And D$ + U$ = "00" _
And Len(Résultat$) > 4 Then Ajoute "s"
End If
'--- on analyse si le mot ET est nécessaire (21, 31,
'--- 41 ...)
Et = (D$ >= "2") And (U$ = "1")
'--- ainsi que les tirets pour certains couples
'--- dizaines-unités
Tiret = ((D$ >= "2") And (U$ > "1") _
Or (D$ >= "1" And U$ >= "7")) And Not Et
'--- traitement des valeurs 80-99
If D$ >= "8" Then
Ajoute "quatre-vingt"
Et = 0
'--- retenue nécessaire pour 90 à 99
If D$ = "8" Then D$ = "0" _
Else D$ = "1": Tiret = True
'--- et traitement des unités
If U$ > "0" Then Tiret = True Else Ajoute "s"
'--- sinon on traite les valeurs 70 à 79
ElseIf D$ = "7" Then
Ajoute "soixante"
'--- avec une retenue pour les dizaines
D$ = "1"
If U$ <> "1" Then Tiret = True
End If
'--- valeurs entre 10 et 16
If (D$ = "1") And (U$ <= "6") Then
D$ = "0"
U$ = "1" + U$
End If
'--- sinon, on gère toutes les autres dizaines
If D$ >= "1" Then
'--- gère les tirets pour les dizaines composées
If Tiret And D$ = "1" _
And Val(Right$(cdu$, 2)) > 19 Then
Ajoute "-"
End If
'--- traduction de la dizaine...
Ajoute Equivalent$(Val(D$ + "0"))
'--- en accordant l'exception des vingtaines
If D$ + U$ = "20" And C$ <> "0" Then Ajoute "s"
End If
'--- si le mot Et est nécessaire, on l'ajoute
If Et Then Ajoute "et"
'--- ainsi que le tiret, liant une dizaine et une
'--- unité
If Tiret Then Ajoute "-"
'--- puis on traduit l'unité du nombre
If Val(U$) >= 22 Or ((Val(U$) >= 1 And (Val(cdu$) > 1 Or longueur <> 6))) Then 
    Ajoute Equivalent$(Val(U$))
End If
'--- enfin, la pondération du nombre est respectée,
'--- en ajoutant le multiple nécessaire, et en
'--- l'accordant s'il le faut
Select Case longueur
Case 6: Ajoute "mille"
Case 9: Ajoute "million"
If Val(cdu$) > 1 Then Ajoute "s"
Case 12
Ajoute "milliard"
If Val(cdu$) > 1 Then Ajoute "s"
Case Else
End Select
End If
Next
End If
End If
End Sub

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2005 Maxence Hubiche Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.