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
Sommaire→Exemple de code pour remplacer les fonctions non disponibles d'Access 97- Code de remplacement de la fonction InStrRev
- Code de remplacement de la fonction Replace
- Code de remplacement de la fonction Round
- Code de remplacement de la fonction Split
- Code de remplacement de la fonction PrevWeekDay
- Code de remplacement de la fonction AddressOf
- Exporter des données vers un fichier XML
Version : 97 principalement
Function TInstrRev(Texte As String, cherche As String, _
Optional Start As Integer = 0, _
Optional Comparaison As integer= vbTextCompare) _
As Integer
On Error GoTo err
If Start < 1 Then Start = Len(Texte)
Texte = Right(Texte, Start)
While InStr(TInstrRev + 1, Texte, cherche, Comparaison) > 0
TInstrRev = InStr(TInstrRev + 1, Texte, cherche, Comparaison)
Wend
Exit Function
err:
MsgBox "Vérifier vos paramètres", vbCritical, "Fonction TInstrRev"
End FunctionUtilisation :
MsgBox TInstrRev("Toto", "to", 2)Cet exemple affichera : 1
Versions : 97 principalement
Public Function ReplaceT(ByVal Expression As String, _
ByVal Find As String, _
ByVal Replace As String, _
Optional ByVal Start As Long = 1, _
Optional ByVal Count As Long = -1, _
Optional ByVal Compare As Integer = vbTextCompare) _
As String
Dim P As Long ' position 1er caractère à tester
Dim L As Long ' longueur de expression
Dim f As Long ' longueur de la chaîne à remplacer
Dim r As Long ' longueur chaîne de remplacement
' argument "Start" : élimination du début de chaîne
Let L = Len(Expression)
If Start > L Then
' parceque "Right$" n'accepte pas 1 taille négative
Let Expression = vbNullString
ElseIf Start > 1 Then
' troncature d'"Expression"
Let Expression = Right$(Expression, L - Start + 1)
End If
ReplaceT = Expression ' valeur retour par défaut
' argument "Find" : si chaîne vide, on retourne "Expression".
If Find = vbNullString Then Exit Function
Let f = Len(Find)
Let r = Len(Replace) ' Taille de la chaîne de remplacement
Let P = 1 ' on commence à la première position
If Count <> 0 Then
Do
' La taille d'"Expression" peut varier lors de chaque
' remplacement (si "Find" et "Replace" sont de longueurs
' différentes), c'est pourquoi l'instruction suivante
' est située DANS la boucle.
Let L = Len(Expression)
' position de la sous-chaîne à remplacer...
Let P = InStr(P, Expression, Find, Compare)
' ... si elle y figure bien
If P > 0 Then
Let Expression = Left$(Expression, P - 1) + _
Replace + _
Right$(Expression, (L - P - f + 1))
' décalage 1er caractère à comparer (position trouvée
' + taille de la chaîne de remplacement)
Let P = P + r
' Un remplacement de moins à effectuer (si "Count">0)
' on continue indéfiniment si "Count" < 0
Let Count = Count - 1
End If
' Si le compteur atteint zéro (cas où on voulait un nombre
' défini de substitutions), où s'il n'y a plus de
' remplacements possibles, on sort.
Loop Until (P <= 0) Or (Count = 0)
End If
ReplaceT = Expression ' retour..
End FunctionVersions : 97 principalement
Voici une fonction d'arrondi (spécialement utile pour la comptabilité) :
Parfois, certaines fonctions arrondissent 0,4450 a 0,44 au lieu de 0,45 comme c'est nécessaire parfois en comptabilité.
Avec celle-ci, il est même possible de choisir le chiffre qui induit un arrondi supérieur.
Function RoundCost(ByVal Nbr As Double, Optional ByVal Expo As Long = 2, _
Optional ByVal NextNumSup = 5) As Double
'Expo is the number of desired decimals
'NextNumSup is the min number after the Expo decimal which result in a Roundsup for Nbr
'Exemple : Roundcost(0.44X) = 0.45 if X >= NextNumSUp (5 by default)
'Correct bug for RoundSup(0.445) = 0.44
If Expo < 0 Then RoundCost = RoundCost(Nbr * 10 ^ Expo, Abs(Expo))
RoundCost = CLng(Nbr * 10 ^ Expo + (0.01 * (10 - NextNumSup))) / 10 ^ Expo
End FunctionVersions : 97 principalement
Public Function FctSplit(ByVal strg As String, Sep As String) As Variant
Dim i As Integer
Dim TblSplit() As String
i = 1
While InStr(1, strg, Sep) <> 0
ReDim Preserve TblSplit(i)
TblSplit(i - 1) = Left(strg, InStr(1, strg, Sep) - 1)
strg = Mid(strg, InStr(1, strg, Sep) + Len(Sep))
i = i + 1
Wend
If Len(strg) > 0 Then
ReDim Preserve TblSplit(i-1)
TblSplit(i - 1) = strg
End If
FctSplit = TblSplit
End FunctionUtilisation :
Dim T As Variant
T=FctSplit("Bonjour Monsieur Dupont"," ")Ce code renvoit un tableau contenant chaque mot de la phrase passée en paramètre.
Versions : 97 principalement
La fonction PrevWeekDay n'existe pas dans Access 97. Par contre la fonction Weekday existe. La fonction WeekDay renvoi le numéro du jour (consulter l'aide pour plus de précisions sur la fonction).
Rappel concernant les numéros de jour :
- Dimanche : 1 (valeur par défaut de la fonction WeekDay)
- Lundi : 2
- Mardi : 3
- Mercredi : 4
- Jeudi : 5
- Vendredi : 6
- Samedi : 7
En soustrayant 1 à la valeur obtenue par la fonction WeekDay, on obtient le numéro du jour précédent la date passée en paramètre.
Function PrevWeekDay(MaDate As Date) As Integer
PrevWeekDay = WeekDay(MaDate) - 1
End FunctionPour obtenir le nom du jour, il suffit d'utiliser la fonction Format(). Nous pouvons allez plus loin à l'aide de cette fonction et pouvoir déterminer le jour ouvré ou ouvrable suivant ou précédent.
Pour rappel : Un jour ouvrable est un jour de la semaine du lundi au samedi. Seuls les dimanches et les jours fériés officiels ne sont pas des jours ouvrables. Un jour ouvré est un jour de la semaine du lundi au vendredi.
' Fonction qui renvoi le jour ouvré précédent la date passée en paramètre.
Function PrevWeekDayOuvres(madate As Date) As Integer
' Si le jour est un samedi ou un dimanche ou un lundi : _
on renvoi le vendredi sinon le jour précédent
If WeekDay(madate) = 1 Or WeekDay(madate) = 2 Or WeekDay(madate) = 7 Then
PrevWeekDayOuvres = 6
Else
PrevWeekDayOuvres = PrevWeekDay(madate)
End If
End Function
' Fonction qui renvoi le jour ouvrable précédent la date passée en paramètre.
Function PrevWeekDayOuvrables(madate As Date) As Integer
' Si le jour est un dimanche ou un lundi : on renvoi le samedi sinon le jour précédent
If WeekDay(madate) = 1 Or WeekDay(madate) = 2 Then
PrevWeekDayOuvrables = 7
Else
PrevWeekDayOuvrables = PrevWeekDay(madate)
End If
End Function
' Fonction qui renvoi le jour suivant la date passée en paramètre.
Function NextWeekDay(madate As Date) As Integer
NextWeekDay = (WeekDay(madate)) + 1
End Function
' Fonction qui renvoi le jour ouvré suivant la date passée en paramètre.
Function NextWeekDayOuvres(madate As Date) As Integer
' Si le jour est un vendredi ou un samedi ou un dimanche : _
on renvoi le lundi sinon le jour suivant
If WeekDay(madate) = 1 Or WeekDay(madate) = 6 Or WeekDay(madate) = 7 Then
NextWeekDayOuvres = 2
Else
NextWeekDayOuvres = NextWeekDay(madate)
End If
End Function
' Fonction qui renvoi le jour ouvrable suivant la date passée en paramètre.
Function NextWeekDayOuvrables(madate As Date) As Integer
' Si le jour est un samedi ou un dimanche : on renvoi le lundi sinon le jour suivant
If WeekDay(madate) = 1 Or WeekDay(madate) = 7 Then
NextWeekDayOuvrables = 2
Else
NextWeekDayOuvrables = NextWeekDay(madate)
End If
End FunctionVous trouverez ci-dessous une procédure utilisant les différentes fonctions.
' Procédure pour tester les fonctions précédentes
Sub test_fonctions()
Dim madate(7) As Date
Dim i As Integer
madate(0) = "01/09/06"
madate(1) = "02/09/06"
madate(2) = "03/09/06"
madate(3) = "04/09/06"
madate(4) = "05/09/06"
madate(5) = "06/09/06"
madate(6) = "07/09/06"
For i = 0 To 6
' donne le jour précédent
Debug.Print "Jour précédent le " & Format(madate(i), "dddd dd mmmm yyyy") & " => " _
& Format(madate(i) - ((7 + (WeekDay(madate(i)) - PrevWeekDay(madate(i)))) Mod 7), "dddd dd mmmm yyyy")
' donne le jour ouvré précédent
Debug.Print "Jour ouvré précédent le " & Format(madate(i), "dddd dd mmmm yyyy") & " => " _
& Format(madate(i) - ((7 + (WeekDay(madate(i)) - PrevWeekDayOuvres(madate(i)))) Mod 7), "dddd dd mmmm yyyy")
' donne le jour ouvrable précédent
Debug.Print "Jour ouvrable précédent le " & Format(madate(i), "dddd dd mmmm yyyy") & " => " _
& Format(madate(i) - ((7 + (WeekDay(madate(i)) - PrevWeekDayOuvrables(madate(i)))) Mod 7), "dddd dd mmmm yyyy")
Debug.Print " "
' donne le jour suivant
Debug.Print "Jour suivant le " & Format(madate(i), "dddd dd mmmm yyyy") & " => " _
& Format(madate(i) + ((7 - WeekDay(madate(i)) + NextWeekDay(madate(i)))) Mod 7, "dddd dd mmmm yyyy")
' donne le jour ouvré suivant
Debug.Print "Jour ouvré suivant le " & Format(madate(i), "dddd dd mmmm yyyy") & " => " _
& Format(madate(i) + ((7 - WeekDay(madate(i)) + NextWeekDayOuvres(madate(i)))) Mod 7, "dddd dd mmmm yyyy")
' donne le jour ouvrable suivant
Debug.Print "Jour ouvrable suivant le " & Format(madate(i), "dddd dd mmmm yyyy") & " => " _
& Format(madate(i) + ((7 - WeekDay(madate(i)) + NextWeekDayOuvrables(madate(i)))) Mod 7, "dddd dd mmmm yyyy")
Debug.Print " "
Debug.Print "============================================================================="
Next i
End SubMaintenant, voici un exemple concrêt d'utilisation. Admettons que l'on souhaite procéder au lancement d'une procédure particulière
tous les 5 du mois, et si ce jour tombe un week end, on lance la procédure le vendredi. Il y a aussi la possibilité de lancer ce traitement
le lundi au lieu du vendredi. Dans ce cas, pensez à modifier la fonction.
Remarque : Cet exemple ne tient pas compte des jours fériés (cf lien vers la FAQ)
'***** Exemple Procédure à effectuer tous les 5 du mois sinon le jour ouvré précédent le 5
'***** Fonction de test
Sub envoi_le_5_du_mois()
Dim madate As Date
Dim i As Integer
Dim j As Integer
j = 1
While j < 13
i = 1
While i < 8
madate = "0" & i & "/0" & j & "/2006"
' Si madate = le 5 du mois et que le jour ouvré suivant n'est pas lundi _
ou madate n'est pas un vendredi
' ou si madate un vendredi et madate <> de 03/xx/xx ou 04/xx/xx
If (madate = "05/" & Month(madate) & "/" & Year(madate)) _
And (NextWeekDayOuvres(madate) <> 2 Or WeekDay(madate) = 6) _
Or (WeekDay(madate) = 6 And (madate = "03/" & Month(madate) & "/" & Year(madate) _
Or madate = "04/" & Month(madate) & "/" & Year(madate))) Then
MsgBox "traitement" & vbLf & madate
End If
i = i + 1
Wend
j = j + 1
Wend
End SubLien utile : Comment savoir si un jour est ouvré ?
La fonction AddressOf (disponible dans les versions supérieures à 97) renvoie l'adresse mémoire de la fonction passée en paramètre.
Cette fonction passée en paramètre doit être présente dans un module de la base de données.
L'adresse mémoire retournée est utilisée par une procédure API attendant un pointeur de fonction dans la liste d'arguments.
A déclarer dans un module :
Public Declare Function GetCurrentVbaProject Lib "vba332.dll" Alias _
"EbGetExecutingProj" (hProject As Long) As Long
Public Declare Function GetFuncID Lib "vba332.dll" Alias _
"TipGetFunctionId" (ByVal hProject As Long, _
ByVal strFunctionName As String, ByRef strFunctionId As String) As Long
Public Declare Function GetAddr Lib "vba332.dll" Alias _
"TipGetLpfnOfFunctionId" (ByVal hProject As Long, _
ByVal strFunctionId As String, ByRef lpfn As Long) As Long
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
Const NO_ERROR = 0
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
Call GetCurrentVbaProject(hProject)
If hProject <> 0 Then
lngResult = GetFuncID( _
hProject, strFuncNameUnicode, strID)
If lngResult = NO_ERROR Then
lngResult = GetAddr(hProject, strID, lpfn)
If lngResult = NO_ERROR Then
AddrOf = lpfn
End If
End If
End If
End FunctionVersions : Antérieures à 2002
Cet exemple permet d'exporter une requête ou une table vers un fichier XML en utilisant ADO.
Pour cela vous devez ajouter la référence Microsoft ActiveX Data Object à votre projet.
Public Function xmlXport(ByVal strTableorQuery As String)
Dim cnx As New ADODB.Connection
Dim rec As New ADODB.Recordset
cnx.Provider = "Microsoft.Jet.Oledb.4.0"
cnx.ConnectionString = CurrentDb.name
cnx.Open
rec.Open "SELECT * FROM [" & strTableorQuery & "]", cnx
rec.save "D:\temp\" & strTableorQuery & ".xml", adPersistXML
rec.Close
cnx.Close
Set rec = Nothing
Set cnx = Nothing
End FunctionExemple d'utilisation :
xmlXport "MaTable"