Créer un planificateur de tâches avec Access

application.Run NomProcedure, ArgumentProcedure

Public Sub RunTasks()
    ' Procédure d'exécutions des tâches actives enregistrées
    Dim db As DAO.Database ' référence à la base courante
    Dim rs As DAO.Recordset ' référence au recordset lié à la table T_Tache
    Dim dateProchaineExecution As Date ' date de prochaine exécution de la tâche
    Dim DateExecution As Date ' date actuelle d'exécution
    
    Set db = CurrentDb ' référence à la base active
    
    ' ouverture du recordset lié aux tâches actives à planifier
    Set rs = db.OpenRecordset("select * from T_Tache where Active;", dbOpenDynaset)
    
    Do Until rs.EOF ' on parcourt les différentes tâches
    
        If IsNull(rs!dateProchaineExecution) Then ' si pas de date de prochaine exécution
            rs.Edit
            rs!dateProchaineExecution = rs!DateDebutPeriodicite ' on met à jour le champ avec la date de la 1re exécution
            rs.Update
        End If
        
        DateExecution = Now() ' on copie la date et l'heure actuelles dans la variable
        
        ' si la date et l'heure de prochaine exécution sont arrivées ou passées
        If (rs!dateProchaineExecution <= DateExecution) Then
            ' si la date prévue pour la dernière exécution n'est pas dépassée
            If (rs!DateFinPeriodicite >= Now) Or IsNull(rs!DateFinPeriodicite) Then
                
                ' On indique dans la barre d'état du programmateur le démarrage de la procédure à la date et à l'heure actuelles
                Me!txtEtatProg.Value = "Lancement de la tâche """ & rs!IntituleTache & """ |  " & Now()
                
                ' il faut lancer la tâche et recalculer la date de prochaîne exécution de la tâche
                If Nz(rs!ArgumentProcedure) = "" Then ' si pas d'argument à la procédure
                    Run (rs!NomProcedure) ' on exécute la procédure à l'aide de la méthode run
                Else ' sinon
                    ' on exécute la procédure à l'aide de la méthode run avec un argument supplémentaire
                    Run rs!NomProcedure, rs!ArgumentProcedure
                End If
            
                ' On indique dans la barre d'état du programmateur la fin de la procédure à la date et à l'heure actuelles
                Me!txtEtatProg.Value = "Fin de la tâche """ & rs!IntituleTache & """ |  " & Now()
            
            End If
            
            ' puis on recalcule la date de prochaîne exécution
            dateProchaineExecution = EvalDateProchaineExecution(rs!DateDebutPeriodicite, DateExecution, rs!Periodicite, rs!UniteTemps)
            
            ' si la date de prochaîne exécution de la tâche dépasse la date prévue pour sa dernière exécution
            If dateProchaineExecution > Nz(rs!DateFinPeriodicite, #1/1/3000#) Then
                rs.Edit
                rs!DateFinPeriodicite = rs!dateProchaineExecution ' on enregistre la date de la dernière exécution
                rs!Active = False ' on déactive la tâche
                rs.Update
            Else
                rs.Edit
                rs!dateProchaineExecution = dateProchaineExecution ' on enregistre la date de prochaine exécution
                rs.Update
            End If
                
            ' on enregistre dans le journal l'identifiant de la tâche et sa date d'exécution
            HistoriserTache rs!IdTache, DateExecution
        
        End If
        
    rs.MoveNext ' enregistrement suivant
        
    Loop
    
    ' libération des variables
    rs.Close
    Set rs = Nothing
    
    Set db = Nothing
    
End Sub

' il faut lancer la tâche et recalculer la date de prochaîne exécution de la tâche
            If Nz(rs!ArgumentProcedure) = "" Then ' si pas d'argument à la procédure
                Application.Run (rs!NomProcedure) ' on exécute la procédure à l'aide de la méthode run
            Else ' sinon
                ' on exécute la procédure à l'aide de la méthode run avec un argument supplémentaire
                Application.Run rs!NomProcedure, rs!ArgumentProcedure
            End IF

Private Sub Form_Timer()
    Me.txtEtatProg.Value = "Programmateur actif le  " & Date & " à " & Time() ' On affiche l'état actuel du programmateur
    RunTasks ' exécution des tâches sur timer
    Me.SF_Taches.Requery ' on rafraîchit le sous-formulaire des tâches
End Sub

Private Sub txtIntervalleMinuterie_AfterUpdate()
    ' définit l'intervalle de minuterie après mise à jour de la zone de texte
    ' si 0 arrêt du timer
    ' copie de la valeur de la zone de texte dans la propriété TimerInterval du formulaire
    Me.TimerInterval = Me.txtIntervalleMinuterie
    If Me.txtIntervalleMinuterie > 0 Then
        ' On affiche l'état actuel du programmateur : actif
        Me.txtEtatProg.Value = "Programmateur actif |  " & Now()
        Me.SF_Taches.Locked = True ' on verrouille les données durant l'exécution
    Else
        ' On affiche l'état actuel du programmateur : à l'arrêt
        Me.txtEtatProg.Value = "Programmateur arrêté |  " & Now()
        Me.SF_Taches.Locked = False ' on déverrouille les données
    End If
End Sub

Public Sub SaveDB()
    ' Procédure de sauvegarde des données Access
    Dim fso As Object ' référence à fso
    Dim cheminFichier As String ' variable pour le chemin complet du fichier sur le disque
    Dim nomFichier As String ' variable pour le nom du fichier
    Dim nomDossier As String ' variable pour le nom du dossier de sauvegarde
    Dim db As DAO.Database ' variable liée à la base de donnée
    Dim tb As TableDef ' variable pour faire référence à une table
    
    Set db = CurrentDb ' référence à la base active
    Set tb = db.TableDefs("T_Facture") ' table locale ou liée
    
    Set fso = CreateObject("Scripting.FileSystemObject") ' Création de l'objet fso
    
    nomDossier = CurrentProject.Path & "\Sauvegardes" ' dossier de sauvegarde
    
    If tb.Connect = "" Then ' pas de table liée
        cheminFichier = CurrentProject.FullName ' chemin complet du fichier Access
        nomFichier = Left(CurrentProject.Name, InStr(CurrentProject.Name, ".") - 1) ' nom du fichier Access sans l'extension
    Else ' une table liée
        ' la chaîne de connection est de la forme ;DATABASE=C:\...\NomBase.accdb"
        cheminFichier = Mid(tb.Connect, 11) ' on extrait le chemin complet du fichier de la base liée
        nomFichier = Mid(tb.Connect, InStrRev(tb.Connect, "\") + 1, InStr(tb.Connect, ".") - InStrRev(tb.Connect, "\") - 1) ' on extrait le nom de la base liée
    End If

    If Dir(nomDossier, vbDirectory) = "" Then ' si le dossier n'existe pas
        fso.CreateFolder nomDossier ' création du dossier de sauvegarde
    End If
        
    ' copie du fichier Access dans le dossier de sauvegarde
    fso.CopyFile cheminFichier, nomDossier & "\" & nomFichier & " - " & Format(Date, "yyyy-mm-dd") & ".accdb"
    
    ' Affichage du message de succès de la sauvegarde
    MsgBox "Sauvegarde du fichier réalisée avec succès !", vbExclamation
    
    ' On libère les variables objet
    Set fso = Nothing
    Set tb = Nothing
    Set db = Nothing

End Sub

Application.Run "SaveDB"

Public Sub TransferSpreadSheet()
    ' Procédure de transfert des données de la requête R_FactureMois dans un fichier Excel
    Dim fso As Object ' référence à fso
    Dim cheminFichier As String ' variable pour le chemin complet du fichier sur le disque
    Dim nomDossier As String ' variable pour le nom du dossier de sauvegarde
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    nomDossier = CurrentProject.Path & "\Factures mensuelles" ' dossier de sauvegarde
    cheminFichier = nomDossier & "\Factures " & Format(DateAdd("m", -1, Date), "yyyy-mm") & ".xlsx" ' chemin complet du fichier Access
    If Dir(nomDossier, vbDirectory) = "" Then ' si le dossier n'existe pas
        fso.CreateFolder nomDossier ' création du dossier de sauvegarde
    End If
    ' transfert de la table Access vers le fichier Excel
    DoCmd.TransferSpreadSheet acExport, acSpreadsheetTypeExcel12Xml, "R_FactureMoisPrecedent", cheminFichier, True
    ' Affichage du message de succès du transfert
    MsgBox "Transfert de la table réalisé avec succès !", vbExclamation
    ' On libère la variable fso
    Set fso = Nothing
End Sub

Application.Run "TransferSpreadSheet"

Public Sub DisplayAlert(msg As String)
    ' on affiche le message d'alerte passé en argument
    MsgBox msg, vbExclamation, "Alerte !"
End Sub

Application.Run "DisplayAlert", "Relance facture référence ""F-00003"" !"