Recherche
Les mémos
-
Tables
- · Annuler la suppression
- · Attacher feuilles Excel
- · Cacher une table
- · Concaténer une colonne
- · Créer une table
- · Dernière modification
- · Index composé
- · Limiter les enregistrements
- · Liste des champs
- · Modifier valeur de champ
- · Où est la table
- · Peupler une table de Logs
- · Renuméroter un champ
- · Réattacher les liens
- · Réattacher les liens locaux
- · Scinder un champ
- · Supprimer les tables liées
- · Trouver la différence
-
Formulaires
- · Afficher les derniers
- · Ajout à liste modifiable
- · Ajouter enregistrement
- · Barre de progression
- · Click ou double-click
- · Confirmer l'enregistrement
- · Copier - Coller
- · Défilement de la roulette
- · Exporter un graphique
- · Filtres personnalisés
- · Identifiants d'un Form continu
- · Importer les formulaires
- · Langue utilisateur
- · Limiter la saisie
- · Mémoriser une valeur
- · No enregistrement
- · Ouvert en normal
- · Position des formulaires
- · Recopier dernière valeur
- · Scroll automatique
- · Switch Modal
- · Tri manuel dans form
- · Tri personnalisé
- · Verrouillage de formulaire
- · Vérifier les saisies
-
Automation
-
Administration
- · Chemin de la base
- · Déconnecter utilisateur
- · Désactiver le Shift
- · Désactiver le Shift(2)
- · Liste des références
- · Liste des utilisateurs
- · Lister les applications
- · Mode exclusif
- · Nom d'utilisateur
- · Nom de l'ordinateur
- · Paramètres régionaux
- · Propriétés de la base
- · Sauvegarde journalière
- · Sauvegarde mensuelle
- · Shell and Wait
- · Version de Windows
-
Envoyer un mail
-
Outlook
- · Ajouter des contacts
- · Déplacer les messages
- · Enregistrer pièces jointes
- · Est ouvert ?
- · Exporter les contacts
- · Exporter les rendez-vous
- · Importer les messages
- · Integrer un état
- · Lire les contacts
- · Lire les rendez-vous
- · Lister les dossiers
- · Lister les tâches
- · SendMail (MAPI)
- · SendMail Automation
-
Dates - Heures
-
Fichiers
- · Compter les dossiers
- · Créer un dossier
- · Générer fichier TXT
- · Importer fichier TXT
- · Le dossier existe ?
- · Le fichier existe ?
- · Lister les fichiers
- · Lister les fichiers (2007)
- · Lister les sous-dossiers
- · Rechercher un répertoire
- · Répertoire dans table
- · Supprimer ReadOnly
- · Sélection de dossier
- · Sélection de dossier (API)
- · Sélection de fichiers
- · Sélection fichier (MOL)
-
Références
Je débute...
-
La normalisation
-
VBA
Visites
1263820 visiteurs
2 visiteurs en ligne
Nous contacter
Contact
Convertir les nombres
Convertir les nombres en lettres
De nombreuses fonction de conversion littérale de nombres existent mais comportent souvent de grossières erreurs grammaticales. J'ai donc décidé de proposer l'adaptation par Gus du code de Joe Foster.
Function NombreVersTexte(ByVal N As Currency) As String Dim Unité As String Dim Buf As String Dim Frac As Currency Dim i As Integer Dim MChiffre(4) As Currency Dim Mlettre(4) As String MChiffre(1) = 1000@ Mlettre(1) = "mille " MChiffre(2) = MChiffre(1) * MChiffre(1) Mlettre(2) = "million" MChiffre(3) = MChiffre(2) * MChiffre(1) Mlettre(3) = "milliard" MChiffre(4) = MChiffre(3) * MChiffre(1) Mlettre(4) = "billion" If (N < 0@) Then Buf = "moins " Else Buf = "" Frac = Abs(N - Fix(N)) If (N < 0@ Or Frac <> 0@) Then N = Abs(Fix(N)) If N = 0@ Then Buf = Buf & "zéro " If N <= 1 Then Unité = "euro" Else Unité = "euros" End If For i = 4 To 1 Step -1 If (N >= MChiffre(i)) Then If (MChiffre(i) <> 1000) Then Buf = Buf & ConverDigit(Int(N / MChiffre(i))) & " " & Mlettre(i) If Int(N / MChiffre(i)) > 1 Then Buf = Buf & "s" N = N - Int(N / MChiffre(i)) * MChiffre(i) If (N >= 1@) Then Buf = Buf & " " Else 'si compte rond ajouter d' devant l'unité 'ex : un million d'euros 'sauf pour 1000 ex : mille euros Buf = Buf & " d'" End If Else 'Gestion des exeptions pour 1000 invariable jamais de "s" ' si 1000 pas de 1 devant "un mille" If (N \ MChiffre(1)) = 1 Then Buf = Buf & Mlettre(i) Else Buf = Buf & ConverDigit(N \ MChiffre(1)) & " " & Mlettre(i) End If N = N - Int(N / MChiffre(i)) * MChiffre(i) End If End If Next i If (N > 0@) Then Buf = Buf & ConverDigit(N) & " " End If Buf = Buf & Unité If (Frac = 0@) Then Buf = Buf & "" '" et zéro cent" Else Buf = Buf & " et " Frac = Frac * 100 Buf = Buf & ConverDigit(Frac) & " cent" If Frac > 1 Then Buf = Buf & "s" End If NombreVersTexte = UCase(Left(Buf, 1)) & Mid(Buf, 2) End Function
Private Function ConverDigit(ByVal N As Integer) As String Const Un = "un" Const Deux = "deux" Const Trois = "trois" Const Quatre = "quatre" Const Cinq = "cinq" Const Six = "six" Const Sept = "sept" Const Huit = "huit" Const Neuf = "neuf" Dim Cent As String: Cent = "cent" Dim Buf As String: Buf = "" Dim Flag As Integer Dim Flag1 As Integer 'Selection des centaines 'Mettre un "s" à cent si le chiffre est sans dizaine ni unité If (N Mod 100) = 0 And (N \ 100) > 1 Then Cent = "cents" End If Select Case (N \ 100) Case 0: Buf = "": Flag = False Case 1: Buf = Cent: Flag = True Case 2: Buf = Deux & " " & Cent: Flag = True Case 3: Buf = Trois & " " & Cent: Flag = True Case 4: Buf = Quatre & " " & Cent: Flag = True Case 5: Buf = Cinq & " " & Cent: Flag = True Case 6: Buf = Six & " " & Cent: Flag = True Case 7: Buf = Sept & " " & Cent: Flag = True Case 8: Buf = Huit & " " & Cent: Flag = True Case 9: Buf = Neuf & " " & Cent: Flag = True End Select If (Flag <> False) Then N = N Mod 100 If (N > 0) Then If (Flag <> False) Then Buf = Buf & " " Else ConverDigit = Buf Exit Function End If 'Selection des dixaines sup. à 10 et inf. 100 'traitement des exceptions pour 21,31,41,51,61,71 'ajouter "et" soixante -et - onze Flag = True Flag1 = False Select Case (N \ 10) Case 0, 1: Flag = False Case 2 Buf = Buf & "vingt" If ((N Mod 10) = 1) Then Buf = Buf & " et " Case 3 Buf = Buf & "trente" If ((N Mod 10) = 1) Then Buf = Buf & " et " Case 4 Buf = Buf & "quarante" If ((N Mod 10) = 1) Then Buf = Buf & " et " Case 5 Buf = Buf & "cinquante" If ((N Mod 10) = 1) Then Buf = Buf & " et " Case 6 Buf = Buf & "soixante" If ((N Mod 10) = 1) Then Buf = Buf & " et " Case 7 Buf = Buf & "soixante" If ((N Mod 10) = 1) Then Buf = Buf & " et " Flag1 = True Case 8 Buf = Buf & "quatre-vingt" If ((N Mod 10) = 0) Then Buf = Buf & "s" If ((N Mod 10) = 1) Then Buf = Buf & "-" Case 9 Buf = Buf & "quatre-vingt" Flag1 = True End Select If (Flag = True) Then N = N Mod 10 'ajouter 10 pour soixante-dix et Quatre -vingt - dix If (Flag1 = True) Then N = N + 10 'rajouter le séparateur "-" si buffer ne se termine pas par "et " If (Flag = True) And (N > 1) And Right(Buf, 3) <> "et " Then Buf = Buf & "-" 'Selection de un à 19 Select Case (N) Case 0: Case 1: Buf = Buf & Un Case 2: Buf = Buf & Deux Case 3: Buf = Buf & Trois Case 4: Buf = Buf & Quatre Case 5: Buf = Buf & Cinq Case 6: Buf = Buf & Six Case 7: Buf = Buf & Sept Case 8: Buf = Buf & Huit Case 9: Buf = Buf & Neuf Case 10: Buf = Buf & "dix" Case 11: Buf = Buf & "onze" Case 12: Buf = Buf & "douze" Case 13: Buf = Buf & "treize" Case 14: Buf = Buf & "quatorze" Case 15: Buf = Buf & "quinze" Case 16: Buf = Buf & "seize" Case 17: Buf = Buf & "dix-sept" Case 18: Buf = Buf & "dix-huit" Case 19: Buf = Buf & "dix-neuf" End Select ConverDigit = Buf End Function
Catégorie : Les mémos - String
Page lue 8069 fois
Page lue 8069 fois