IdentifiantMot de passe
Mot de passe oublié ?Je m'inscris ! (gratuit)

Les meilleures sources Access

Les meilleures sources AccessConsultez toutes les sources

Nombre d'auteurs : 44, nombre de sources : 147, création le 19 mars 2013 

 
OuvrirSommaire→Divers→Fonctions de conversion et de calcul
précédentsommairesuivant
 Version hors-ligne 
 
 
HautPage
Calculer la médiane d'une colonne numérique d'une table (mathématique)

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

 
Sélectionnez
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 :

 
Sélectionnez
Sub TesterExemple() 
'Code client 
'----------- 
'ALFKI 
'ANATR 
'ANTON 
'AROUT 
'BERGS 
'BLAUS 
'BLONP 
'BOLID 
'BONAP 
MsgBox fMediane("TBLClients", "[Code client]") 
'Renvoie "BERGS" 
End Sub
Créé le 8 octobre 2005  par Tofalu

Page de l'auteur

 
HautPage
Convertir des nombres en chiffres romains

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

Dans un module :

 
Sélectionnez
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 :

 
Sélectionnez
MsgBox ChiffreRomain(49)
Créé le 5 mars 2005  par Tofalu

Page de l'auteur

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

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:

 
Sélectionnez
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.

 
Sélectionnez
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 :

 
Sélectionnez
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.

Créé le 12 novembre 2005  par Argyronet

Page de l'auteur

 
HautPage
Convertir une date Julienne au format jj/mm/yyyy

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.

 
Sélectionnez
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 :

 
Sélectionnez
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.
Créé le 5 mars 2005  par Tofalu

Page de l'auteur

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

Versions : 2000 et supérieures

 
Sélectionnez
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
Créé le 28 janvier 2005  par Tofalu

Page de l'auteur

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

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 :

 
Sélectionnez
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 :

 
Sélectionnez
Msgbox fVoieSansNum("90-92 Rue Meynadier")

Affiche : Rue Meynadier

 
Sélectionnez
Msgbox fNomVoie("90-92 Rue Meynadier")

Affiche : Meynadier (Rue)

Remarques :

 
Sélectionnez
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.

Créé le 5 mars 2005  par Fred.G

Téléchargez le zip

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

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 :

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

Fonction cosécante :

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

Fonction cotangente :

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

Fonction arcsinus :

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

Fonction arccosinus :

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

Fonction arcsécante :

 
Sélectionnez
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 :

 
Sélectionnez
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 :

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

Fonction sinus hyperbolique :

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

Fonction cosinus hyperbolique :

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

Fonction tangente hyperbolique :

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

Fonction sécante hyperbolique :

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

Fonction cosécante hyperbolique :

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

Fonction cotangente hyperbolique :

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

Fonction arcsinus hyperbolique :

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

Fonction arccosinus hyperbolique :

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

Fonction arctangente hyperbolique :

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

Fonction arcsécante hyperbolique :

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

Fonction arccosécante hyperbolique :

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

Fonction arccotangente hyperbolique :

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

Fonction logarithme de base N :

 
Sélectionnez
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.

Créé le 5 mars 2005  par Tofalu

Page de l'auteur
Téléchargez le zip

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

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

 
Sélectionnez
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 :

 
Sélectionnez
Msgbox MiseEnMajuscule("jean-paul")

Ceci affichera : Jean-Paul

Créé le 27 août 2004  par Papilou
 
HautPage
Traduire une date

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 :

 
Sélectionnez
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 :

 
Sélectionnez
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.

Créé le 20 mai 2005  par Tofalu

Page de l'auteur

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

Versions : 97 et supérieures

 
Sélectionnez
 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
Créé le 27 août 2004  par HelpClic
 
HautPage
Convertir un nombre en base n vers une base m

Voici une fonction permettant de convertir un nombre donné en base n vers une base m.

 
Sélectionnez
Function base(ByVal FigDec As Long, ByVal Bas As Integer, ByVal Longueur As Integer) As String
 
    Dim strH As String
    Dim i As Integer, j As Integer
    Dim FigX As Long
    Dim Hexx As String
 
    strH = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    Hexx = vbNullString
    FigX = FigDec
 
    For i = Longueur - 1 To 0 Step -1
    For j = Bas - 1 To 1 Step -1
        If ((Bas) ^ i) * j <= FigX Then
            Hexx = Hexx & Mid(strH, j + 1, 1)
            FigX = FigX - ((Bas) ^ i) * j
            GoTo found01
        End If
    Next j
    Hexx = Hexx & "0"
found01:
    Next i
 
    base = Hexx
 
End Function
 
Function ConvertBase(ByVal StrSource As String, _
                    ByVal BasSource As Integer, _
                    ByVal BasDest As Integer, _
                    ByVal Longueur As Integer) As String
 
    ' conversion du Nombre base N en decimal
    Dim strH As String
    Dim FigDec As Long
    Dim i As Integer
 
    strH = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    FigDec = 0
    For i = Len(StrSource) To 1 Step -1
        FigDec = FigDec + (InStr(strH, Mid(StrSource, i, 1)) - 1) _
			* BasSource ^ (Len(StrSource) - i)
    Next i
 
    'Debug.Print "la conversion décimale de " & _
		StrSource & " de base " & _
		 BasSource & " donne un décimal de " & FigDec
    ' récupération du décimal en base N'
    ConvertBase = base(FigDec, BasDest, Longueur)
 
End Function

L'entête de la fonction reçoit en paramètre : le nombre à convertir, la base source, la base destination et la longueur de la valeur retournée (nombre de caractères).

Exemple :
3 : le nombre à convertir, 10 : la base 10, 2 : la base et 8 la longueur de la chaine retournée.

 
Sélectionnez
ConvertBase("3", 10, 2, 8)

va retourner "00000011".
Autre exemple :

 
Sélectionnez
ConvertBase("B6", 16, 10, 4)

va retourner "0182".

Créé le 16 janvier 2007  par cafeine

Page de l'auteur

précédentsommairesuivant
 Version hors-ligne 
 

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 © 2013 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.