Il est de bon ton de se souhaiter la bonne année. Mais vous, et vous seul, pourrez faire en sorte que cette année soit bonne, meilleure que celle qui vient de s'écouler. Apprenez à ne compter que sur vous, car personne n'est plus qualifié que vous-même pour bâtir, réparer ou améliorer votre propre vie. Personne ne fera les choses à votre place. D'ailleurs, tout ce que les autres peuvent faire, c'est souhaiter que vous le fassiez. Et ne croyez pas que tout ceux qui vous entourent vous apporteront des solutions : certains font juste partie de vos problèmes. Transformez vos résolutions en actes, et dans douze mois, retournez-vous et souriez-vous fièrement : C'était long. C'était difficile. Mais ça y est : 2017 était une bonne année, merci Moi.

Fonctions personnalisées

Dans ce chapitre, découvrez ce que j'ai moi-même découvert au fur et à mesure de mes besoins en programmation Access.

Récupérer le nom de l'ordinateur courant

Déclaration

Declare Function RecupNomOrdinateur Lib "Kernel32.dll" Alias "GetComputerNameA" (ByVal lpbuffer As String, nsize As Long) As Long

Utilisation

Dim NomOrdinateur As String
Dim Resultat As Long
NomOrdinateur = String$(255, 32)
Resultat = RecupNomOrdinateur(NomOrdinateur, 255)
MsgBox NomOrdinateur

Récupérer le nom de l'utilisateur courant

Cette fonction permet de récupérer non pas l'utilisateur Access (que l'on peut simplement obtenir avec CurrentUser), mais bien le nom d'utilisateur que l'on rentre lorsqu'on arrive dans Windows :

Déclaration

Declare Function RecupNomUtilisateur Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Implémentation

Function NomUtilisateur() As String
Dim StrNomUtilisateur As String
Dim Resultat As Long ' Contiendra simplement 1 si l'appel s'est bien déroulé
StrNomUtilisateur = String$(255, 0)
Resultat = RecupNomUtilisateur(StrNomUtilisateur, 255)
If Resultat = 1 Then
NomUtilisateur = StrNomUtilisateur
Else
NomUtilisateur = "UTILISATEUR INCONNU"
End If
End Function

Exemple d'utilisation

Sub Test()
MsgBox NomUtilisateur
End Sub

Déterminer la langue d'Access utilisée

Function DetermineLangue()
On Error Resume Next
Err.Raise 3
Select Case Err.Description
Case "Return without GoSub"
DetermineLangue = "Anglais"
Case "Return sans GoSub"
DetermineLangue = "Français"
Case "'Return' ohne 'GoSub'"
DetermineLangue = "Allemand"
Case "Return sem GoSub"
DetermineLangue = "Portugais"
Case "Return sin GoSub"
DetermineLangue = "Espagnol"
Case Else
DetermineLangue = "LANGUE INCONNUE"
End Select
End Function

Extraire le 2ème mot d'une chaîne de caractères

ChaîneTest = "Mot1 Mot2 Mot3"
PosEsp1 = InStr(1, ChaîneTest, Chr(32))
PosEsp2 = InStr(PosEsp1 + 1, ChaîneTest, Chr(32))
LongueurMot = (PosEsp2 - PosEsp1) - 1
x = Mid(ChaîneTest, PosEsp1 + 1, LongueurMot) ' Contient le 2ème mot

Calculer le dernier jour possible du mois d'une date

Function CalculFinMois (QuelleDate)
If IsDate("31/" & Month(QuelleDate) & "/" & Day(QuelleDate)) Then
CalculFinMois = "31/" & Month(QuelleDate) & "/" & Day(QuelleDate)
Exit Function
End If
If IsDate("30/" & Month(QuelleDate) & "/" & Day(QuelleDate)) Then
CalculFinMois = "31/" & Month(QuelleDate) & "/" & Day(QuelleDate)
Exit Function
End If
If IsDate("29/" & Month(QuelleDate) & "/" & Day(QuelleDate)) Then
CalculFinMois = "31/" & Month(QuelleDate) & "/" & Day(QuelleDate)
Exit Function
End If
If IsDate("28/" & Month(QuelleDate) & "/" & Day(QuelleDate)) Then
CalculFinMois = "31/" & Month(QuelleDate) & "/" & Day(QuelleDate)
Exit Function
End If
End Function

' Cette fonction retourne le dernier jour du mois d'une date :

' X = DernierJourMois (me![DateDeTransport])

Function DernierJourMois(cettedate)
Dim TempDate As Date
TempDate = cettedate
While Month(cettedate) = Month(TempDate)
TempDate = TempDate + 1
Wend
DernierJourMois = TempDate - 1
End Function

Donner une longueur stricte à un texte, et compléter à gauche ou à droite par un caractère de son choix

'Admettons l 'exemple Baton à remplir dans une zone de 10 caracteres avec des X à gauche. Le résultat serait : XXXXXBaton
' Texte : Texte à utiliser EXEMPLE : Baton
' Longueur : Longueur totale EXEMPLE : 10
' Cote : Doit-il être aligné à gauche ou à droite ? EXEMPLE : "Droite"
' CaractereRemplissage : avec quoi complète-t-on ? EXEMPLE : "X"
Function Remplissage(Texte As String, Longueur As Integer, Cote As String, CaractereRemplissage As String) As String
Dim QteARemplir As Integer
Dim Ctr As Integer
Dim SuiteCaractere As String
' Si le texte est supérieur à la zone à remplir, on prend la partie de gauche du texte :
If Len(Texte) >= Longueur Then
Texte = Left$(Texte, Longueur)
Remplissage = Texte
Exit Function
End If
QteARemplir = Longueur - Len(Texte)
If Cote = "gauche" Then
For Ctr = 1 To QteARemplir
Texte = Texte & CaractereRemplissage
Next
Else
For Ctr = 1 To QteARemplir
SuiteCaractere = SuiteCaractere & CaractereRemplissage
Next
Texte = SuiteCaractere & Texte
End If
Remplissage = Texte
End Function

L'utilisateur courant fait il partie d'un certain groupe ?

' Exemple d'appel :

' If FaitPartieGroupe ("Direction") then

' MsgBox "L'utilisateur courant fait partie de la direction"

' End If

Function FaitPartieGroupe(VARGroupe As String) As Boolean
Dim USRUtilisateur As User
Dim GRPGroupe As Group
FaitPartieGroupe = False
For Each USRUtilisateur In DBEngine.Workspaces(0).Groups(VARGroupe).Users
If CurrentUser = USRUtilisateur.Name Then
FaitPartieGroupe = True
End If
Next USRUtilisateur
End Function

Remarque : CurrentUser est équivalent à DBEngine.Workspaces(0).UserName

Calcul de tarif selon un barême horaire

Cette fonction permet de calculer automatiquement le tarif à appliquer a partir d'un certain temps passé, à un certain barême horaire.

' PARAMETRES :

' Heure : une variable de type Date/Heure, telle que : #02:30:00 AM#.
' en admettant qu'on aie une chaîne de caractère telle que "2:30",
' il faut d'abord la transformer en Date/Heure avec CDate.
' TarifHoraire : Le prix demandé à l'heure
' EXEMPLES D'APPELS :
' X = CalculMontantSelonBaremeHoraire(#02:30:00 AM#, 80) ' X vaudra 200
' X = CalculMontantSelonBaremeHoraire(CDate("2:30"), 80) ' X vaudra aussi 200

Function CalculMontantSelonBaremeHoraire(Heure, TarifHoraire) As Single
CalculMontantSelonBaremeHoraire = Heure * 60 * 24 * (TarifHoraire / 60)
End Function

Transformation d'un montant Chiffres en lettres

Function NBenLettres (nb)
'
Dim varnum, varnumD, varnumU, varlet, résultat
'
'varnum : pour stocker les parties du nombre que l'on va découper
'varlet : pour stocker la conversion en lettres d'une partie du nombre
'varnumD : pour stocker la partie dizaine d'un nombre à 2 chiffres
'varnumU : pour stocker la partie unité d'un nombre à 2 chiffres
'résultat : pour stocker les résultats intermédiaires des différentes étapes
'
Static chiffre(1 To 19) '*** tableau contenant le nom des 16 premiers nombres en lettres
chiffre(1) = "un"
chiffre(2) = "deux"
chiffre(3) = "trois"
chiffre(4) = "quatre"
chiffre(5) = "cinq"
chiffre(6) = "six"
chiffre(7) = "sept"
chiffre(8) = "huit"
chiffre(9) = "neuf"
chiffre(10) = "dix"
chiffre(11) = "onze"
chiffre(12) = "douze"
chiffre(13) = "treize"
chiffre(14) = "quatorze"
chiffre(15) = "quinze"
chiffre(16) = "seize"
chiffre(17) = "dix-sept"
chiffre(18) = "dix-huit"
chiffre(19) = "dix-neuf"
Static dizaine(1 To 8) '*** tableau contenant les noms des dizaines
dizaine(1) = "dix"
dizaine(2) = "vingt"
dizaine(3) = "trente"
dizaine(4) = "quarante"
dizaine(5) = "cinquante"
dizaine(6) = "soixante"
dizaine(8) = "quatre-vingt"
'
'*** Traitement du cas zéro franc
If nb >= 1 Then
résultat = ""
Else
résultat = "zéro"
GoTo fintraitementfrancs
End If
'*** Traitement des millions
varnum = Int(nb / 1000000)
If varnum > 0 Then
GoSub centaine_dizaine
résultat = varlet + " million"
If varlet <> "un" Then résultat = résultat + "s"
End If
'
'*** Traitement des milliers
varnum = Int(nb) Mod 1000000
varnum = Int(varnum / 1000)
If varnum > 0 Then
GoSub centaine_dizaine
If varlet <> "un" Then résultat = résultat + " " + varlet
résultat = résultat + " mille"
End If
'
'*** Traitement des centaines et dizaines
varnum = Int(nb) Mod 1000
If varnum > 0 Then
GoSub centaine_dizaine
résultat = résultat + " " + varlet
End If
résultat = LTrim(résultat)
varlet = Right$(résultat, 4)
'
'*** Traitement du "s" final pour vingt et cent et du "de" pour million
Select Case varlet
Case "cent", "ingt"
résultat = résultat + "s"
Case "lion", "ions"
résultat = résultat + " de"
End Select
fintraitementfrancs: '*** Etiquette de branchement pour le cas "zéro franc"
'
'*** Indication du terme franc
résultat = résultat + " franc"
If nb >= 2 Then résultat = résultat + "s"
'
'*** Traitement des centimes
varnum = Int((nb - Int(nb)) * 100 + .5) '*** On additionne 0,5
'*** afin de compenser
'*** les erreurs de calcul
'*** dues aux arrondis
If varnum > 0 Then
GoSub centaine_dizaine
résultat = résultat + " et " + varlet + " centime"
If varnum > 1 Then résultat = résultat + "s"
End If
'
'*** Conversion 1ère lettre en majuscule
résultat = UCase(Left(résultat, 1)) + Right(résultat, Len(résultat) - 1)
'
'*** renvoie du résultat de la fonction et fin de la fonction
NBenLettres = résultat
Exit Function
'
centaine_dizaine: '*** Sous-programme de conversion en lettres
'*** des centaines et dizaines
varlet = ""
'
'*** Traitement des centaines
If varnum >= 100 Then
varlet = chiffre(Int(varnum / 100))
varnum = varnum Mod 100
If varlet = "un" Then
varlet = "cent "
Else
varlet = varlet + " cent "
End If
End If
'
'*** Traitement des dizaines
If varnum <= 19 Then '*** Cas où la dizaine est <20
If varnum > 0 Then varlet = varlet + chiffre(varnum)
Else '*** Autres cas
varnumD = Int(varnum / 10) '*** chiffre des dizaines
varnumU = varnum Mod 10 '*** chiffre des unités
Select Case varnumD '*** génération des dizaines en lettres
Case Is <= 5
varlet = varlet + dizaine(varnumD)
Case 6, 7
varlet = varlet + dizaine(6)
Case 8, 9
varlet = varlet + dizaine(8)
End Select
'
'*** traitement du séparateur des dizaines et unités
If varnumU = 1 And varnumD < 8 Then
varlet = varlet + " et "
Else
If varnumU <> 0 Or varnumD = 7 Or varnumD = 9 Then
varlet = varlet + "-"
End If
End If
'*** génération des unités
If varnumD = 7 Or varnumD = 9 Then varnumU = varnumU + 10
If varnumU <> 0 Then varlet = varlet + chiffre(varnumU)
End If
'
'*** Suppression des espaces à gauche et retour
varlet = RTrim(varlet)
Return
End Function

Arrondissement d'un montant à 5 centimes

Function Arrondi5Ct(Montant)
Arrondi5Ct = CLng(Montant * 20) / 20
End Function

Mise à 0 du contrôle actif en cas d'effacement

Sub ZeroSiNul()
If IsNull(Screen.ActiveControl) Then
Screen.ActiveControl = 0
End If
End Sub

Calcul d'un montant SANS TVA (depuis TTC)

' Exemple : X = CalculMontantSansTVA 106.5, 0.065

Function CalculMontantSansTVA(MontantAvecTVA, TauxTVA)
CalculMontantSansTVA = (MontantAvecTVA / (100 + (TauxTVA * 100))) * 100
End Function

Suppression de toutes les barres d'outils

DoCmd.ShowToolbar "Base de données", acToolbarNo
DoCmd.ShowToolbar "Relation", acToolbarNo
DoCmd.ShowToolbar "Création de table", acToolbarNo
DoCmd.ShowToolbar "Feuille de données de table", acToolbarNo
DoCmd.ShowToolbar "Création de requête", acToolbarNo
DoCmd.ShowToolbar "Requête feuille de données", acToolbarNo
DoCmd.ShowToolbar "Création de formulaire", acToolbarNo
DoCmd.ShowToolbar "Mode Formulaire", acToolbarNo
DoCmd.ShowToolbar "Filtrer/trier", acToolbarNo
DoCmd.ShowToolbar "Créer un état", acToolbarNo
DoCmd.ShowToolbar "Aperçu avant impression", acToolbarNo
DoCmd.ShowToolbar "Boîte à outils", acToolbarNo
DoCmd.ShowToolbar "Mise en forme (Formulaire/État)", acToolbarNo
DoCmd.ShowToolbar "Mise en forme (Feuille de données)", acToolbarNo
DoCmd.ShowToolbar "Création de macros", acToolbarNo
DoCmd.ShowToolbar "Visual Basic", acToolbarNo
DoCmd.ShowToolbar "Utilitaire 1", acToolbarNo
DoCmd.ShowToolbar "Utilitaire 2", acToolbarNo
DoCmd.ShowToolbar "Web", acToolbarNo
DoCmd.ShowToolbar "Contrôle de code source", acToolbarNo
DoCmd.ShowToolbar "Barre de menus", acToolbarNo
DoCmd.ShowToolbar "Menus contextuels", acToolbarNo