Les meilleures sources AccessConsultez toutes les sources

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

 
OuvrirSommaireDiversFonctions de conversion et de calcul

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

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

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

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

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

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

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

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

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

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

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

  

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 et 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.