Developpez.com

Plus de 2 000 forums
et jusqu'à 5 000 nouveaux messages par jour

Les meilleures sources AccessConsultez toutes les sources

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

 
OuvrirSommaireExemple de code pour remplacer les fonctions non disponibles d'Access 97

Version : 97 principalement

 
Sélectionnez

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 Function

Utilisation :

 
Sélectionnez
MsgBox TInstrRev("Toto", "to", 2)

Cet exemple affichera : 1

Créé le 5 mars 2005  par Tofalu

Page de l'auteur

Versions : 97 principalement

 
Sélectionnez

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  on voulait un nombre
        ' défini de substitutions),  s'il n'y a plus de
        ' remplacements possibles, on sort.
        Loop Until (P <= 0) Or (Count = 0)
    End If
ReplaceT = Expression        ' retour..
End Function
Créé le 28 janvier 2005  par Shwin

Versions : 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.

 
Sélectionnez

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 Function 
Créé le 28 janvier 2005  par extros

Versions : 97 principalement

 
Sélectionnez

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 Function

Utilisation :

 
Sélectionnez

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.

Mis à jour le 15 novembre 2006  par Tofalu

Page de l'auteur

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.

 
Sélectionnez

Function PrevWeekDay(MaDate As Date) As Integer
 
PrevWeekDay = WeekDay(MaDate) - 1 
 
End Function

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

 
Sélectionnez

' 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 Function

Vous trouverez ci-dessous une procédure utilisant les différentes fonctions.

 
Sélectionnez

' 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 Sub

Maintenant, 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)

 
Sélectionnez

'***** 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 Sub

Lien utile : Comment savoir si un jour est ouvré ?

Créé le 15 novembre 2006  par Lou Pitchoun

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 :

 
Sélectionnez

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 Function
Créé le 16 janvier 2007  par cafeine

Versions : 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.

 
Sélectionnez

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 Function

Exemple d'utilisation :

 
Sélectionnez

xmlXport "MaTable"
Créé le 12 novembre 2005  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.