Dans ce chapitre, découvrez ce que j'ai moi-même découvert au fur et à mesure de mes besoins en programmation Access.
Declare Function RecupNomOrdinateur Lib "Kernel32.dll" Alias "GetComputerNameA" (ByVal lpbuffer As String, nsize As Long) As Long
Dim NomOrdinateur As String
Dim Resultat As Long
NomOrdinateur = String$(255, 32)
Resultat = RecupNomOrdinateur(NomOrdinateur, 255)
MsgBox NomOrdinateur
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 :
Declare Function RecupNomUtilisateur Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
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
Sub Test()
MsgBox NomUtilisateur
End Sub
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
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
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
' 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
'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
' 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
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
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
Function Arrondi5Ct(Montant)
Arrondi5Ct = CLng(Montant * 20) / 20
End Function
Sub ZeroSiNul()
If IsNull(Screen.ActiveControl) Then
Screen.ActiveControl = 0
End If
End Sub
' Exemple : X = CalculMontantSansTVA 106.5, 0.065
Function
CalculMontantSansTVA(MontantAvecTVA, TauxTVA)
CalculMontantSansTVA = (MontantAvecTVA / (100 + (TauxTVA * 100))) * 100
End Function
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