Quelques procédures VBA pour Microsoft Access comme la réduction, la fermeture de la base ou bien sa copie, l'effacement des données, l'exécution d'une requête.
Manipulation de la base
Manipulation d'un formulaire
Manipulation d'un contrôle de formulaire
Requêter avec VBA
Manipulation d'une table
Sortir d'Access vers une autre application


Pour des macros de manipulation d'Access à partir d'excel, regarder xl_et_autres_applis.htm


Manipulation de la base
Fermeture d'une base Microsoft Access
 docmd.quit
docmd.close
Réduction de la base Microsoft Access dans l'application Microsoft Access
 docmd.minimize
Chemin d'accès à une base Microsoft Access currentdb.name
Répertoire où figure une base Microsoft Access Left(CurrentDb.Name, Len(CurrentDb.Name) - Len(Dir$(CurrentDb.Name)))
utilisé pour créer des chemins relatifs et faire référence à la base Function CheminBase()
pos = 1
Do Until pos = 0
SavePos = pos: pos = InStr(pos + 1, CurrentDb.Name, "\")
Loop
CheminBase = Left(CurrentDb.Name, SavePos)
FName = Mid(CurrentDb.Name, SavePos + 1)
End Function
Copie d'une version compactée d'une base Microsoft Access Function CopierCompacterBase()
Dim FS As New FileSystemObject
ChDir CheminBase 'changement du répertoire courant
If FS.FileExists(CheminBase & "NomBase.mdb") Then
   Kill CheminBase & "NomBase_Backup.mdb"
Endif.

'Copie intermédiaire de la base
FS.CopyFile CurrentDb.Name, CheminBase & "NomBase_Backup_Old.mdb", True

'Compactage de la copie sous un autre nom
Application.DBEngine.CompactDatabase CheminBase & "NomBase_Backup_old", _
CheminBase & "NomBase_Backup"

'Effacement de la copie interrmédiaire
FS.DeleteFile CheminBase & "BackUp_BasePuce_old.mdb"
End Function
Ouvrir  une autre base On Error Resume Next
Static ac As Access.Application: Set ac = New Access.Application
    ac.Visible = True
    ac.OpenCurrentDatabase (CheminBase & "Base.mdb")
    ac.DoCmd.RunMacro "macro_a_lancer": DoEvents
    ac.DoCmd.Quit:
Set ac = Nothing
Suppression des messages d'alertes de Microsoft Access DoCmd.SetWarnings False 'comme displayalerts pour Excel
Suppression d'un objet, ici une table "tableExport" DoCmd.DeleteObject acTable, "tableExport"


  

Manipulation d'un formulaire
Ouverture d'un formulaire Microsoft Access nommé "Général" DoCmd.OpenForm "Général", acNormal, , , , acWindowNormal
Action à l'ouverture d'un formulaire Microsoft Access Private Sub Form_Open(Cancel As Integer)
msgbox "coucou"
End Sub
Action à la fermeture d'un formulaire Microsoft Access Private Sub Form_Unload(Cancel As Integer)
msgbox "au revoir"
End Sub
DoCmd.OutputTo acOutputForm,
     Me.uncontroledetypeliste.Name, acFormatXLS, "tempFile.xls", True
Manipulation d'un contrôle de formulaire
Le contrôle est-il sélectionné ?
 Function ContrôleSélectionné(frm As Form, chNomCtrl As String) As Integer
    Dim entI As Integer, ctl As Control
    If frm.CurrentView <> 0 Then
        ' Le formulaire n'est pas en mode Création.
        Exit Function
    Else
        For entI = 0 To frm.Count - 1
            Set ctl = frm(entI)
            If ctl.InSelection = True Then
                ' Le contrôle est-il sélectionné ?
                If UCase(ctl.Name) = UCase(chNomCtrl) Then

ContrôleSélectionné = True
                    Exit Function
                End If
            Else
                ContrôleSélectionné = False
            End If
        Next entI
    End If
End Function
Eléments sélectionnés d'un contrôle de type liste Dim frm As Form
Dim ctl As Control
Set frm = Me 'contient le formulaire en cours
Set ctl = frm!uncontroledetypeliste
For Each varElt In ctl.ItemsSelected
    If IsNull(ctl.ItemData(varElt)) = False Then
     msgbox ctl.ItemData(varElt)
    End If
Next varElt
Déselection des éléments d'un contrôle de type liste For i = 0 To Me.uncontroledetypeliste.ListCount
Me.uncontroledetypeliste.Selected(i) = False
Next i
Page sélectionnée d'un contrôle onglet nommé CtlTab0 Private Sub CtlTab0_Change()
Select Case CtlTab0.Pages(CtlTab0.Value).Name
Case "Nomdelapage1": form_statusbar.Caption = "Page 1 sélectionnée"
Case "Nomdelapage2": msgbox "Page 2 sélectionnée"
End Select
End Sub
Spécifier la requête d'un contrôle Lecontrole.rowsource = "select distinctrow latable.champ1 from latable;"
Charger ou rafraîchir un contrôle Lecontrole.requery

Manipulation d'un état
Afficher un état Microsoft Access DoCmd.OpenReport "Fax_Suivi", acViewPreview
Imprimer un état Microsoft Access DoCmd.PrintOut acPrintAll
Fermer un  état Microsoft Access DoCmd.Close acReport, "Fax_Suivi"


       
      

Requêter avec VBA
Ouvrir une requête
 DoCmd.OpenQuery "Nomdelarequete", acNormal, acEdit
Exécuter une requête et l'analyser
 dim  marequete as recordset, nombreEnreg as integer
Set marequete = CurrentDb.QueryDefs("Nomdelarequete").OpenRecordset
On Error Resume Next
marequete.MoveLast
nombreEnreg = marequete.RecordCount
    If nombreEnreg <> 0 Then
        analyse.MoveFirst
        compteur = 1
        Do While Not analyse.EOF
        analyse.Delete          "suppression
        analyse.MoveNext   "passage à l'enreg suivant
        Loop
    End If
Spécifier une requête à la  volée, l'exécuter et contrôler son succès dim sqlInfos As String, marequete as recordset
sqlInfos = "select distinctrow latable.date from latable group by latable.date" & _
        " having (((latable.date)=Date()-1))"
set marequete = CurrentDb.OpenRecordset(sqlInfos)
If marequete.RecordCount <> 0 Then
continuer = False:MsgBox ("Fin")
Else
continuer = True
End if
marequete.Close
Autre exécution à la volée DoCmd.RunSQL (sqlInfos)
Effacer X jours de données 'Fonction non éprouvée, construite à la volée à partir d'une macro que j'avais rédigée

Function EffacerXEtPlus(NomTable As String, NomChampDate As String, NbJoursaEffacer As Integer)
On Error GoTo gest_erreur:

Dim sqlInfos As String
sqlInfos = "DELETE Date()-[" & NomTable & "]![" & NomChampDate & "] AS Expr1, " & NomTable & "."
sqlInfos = sqlInfos & " FROM " & NomTable
sqlInfos = sqlInfos & " WHERE (((" & NomChampDate & "()-[" & NomTable & "]![" & NomChampDate & "])> " & NbJoursaEffacer & "));"

DoCmd.SetWarnings False
DoCmd.RunSQL (sqlInfos) 'lance l'exécution de la chaîne sql
'MsgBox "Table " & NomTable & " nettoyée de " & NbJoursaEffacer & "jour(s)"
DoCmd.SetWarnings True

gest_erreur: If Err Then CreateObject("WScript.Shell").PopUp "Erreur, Interruption !" _
& Chr(13) & "Erreur n° :" & Err.Number & Chr(13) & Chr(13) & _
"Description :" & Err.Description, 10, "Fin": End

End Function

Manipulation d'une table
Transfert d'une table dans un fichier
 DoCmd.TransferText , "nom_du_fichier_de_parametres", "matable", _
    CheminBase & "unrepertoire\" & "nom_du_fichier_exporté" & Format(Date, "yy-mm-dd") & ".csv", False, ""
DoCmd.TransferSpreadsheet acExport, 5, "essai export", "Monfichier.xls", True, ""
DoCmd.TransferSpreadsheet acImport, 5, "essai import", "Monfichier.xls", True, ""
Existence d'une table Function Table_Existe(nomTable) As Boolean
Dim db As Database
Set maBase = DBEngine(0)(0)
For i% = 0 To maBase.TableDefs.Count - 1
If (maBase.TableDefs(i%).Name = nomTable) Then Table_Existe = True: Exit For
Next i%
End Function
Lecture de  ses enregistrements et mise  à jour Dim test As Recordset
Set test = CurrentDb.OpenRecordset("test", dbOpenTable, dbAppendOnly)
Do While Not test.EOF
With test
.Edit
!votrechamp = Date
.Update
End With
test.MoveNext
Loop
Valeur d'un champ donné du premier enregistrement Function GetParametre(NomParam As String, NomTable as String)
Dim laTable As Recordset
Set laTable = CurrentDb.OpenRecordset(NomTable, dbOpenTable)
GetParametre = laTable.Fields(NomParam).Value: Set maTable = Nothing
End Function
Par exemple tester l'existence d'une table et la vider si existante
If Table_Existe("votreTable") Then DoCmd.RunSQL "DELETE FROM votreTable"


Sortir  d'Access vers une autre application
Ouvrir un document quelconque Application.FollowHyperlink CheminBase & "documents\Controle Puce.doc", , , False
'suppose que le logiciel pour ouvrir le document X soit bien enregistré
Excel Dim XL As Excel.Application
Set XL = New Excel.Application
XL.Visible = True
XL.DisplayAlerts = False
Set myWbk = XL.Workbooks.Open(CheminBase & "tablox_bord\" & "classeurX.xls")
myWbk.run "mamacro", var1, var2
Set XL = Nothing    'excel reste ouvert mais plus pilotable par Access
End Sub
Existence d'un fichier Dim variablequelconque, reponse, FS As New FileSystemObject
If FS.FileExists(CheminBase & "BaseC.mdb") = False Then
CreateObject("WScript.Shell").PopUp "Base compactée inexistante", 1, "Annulation !!"
End if
Liste de fichiers dans un objet liste Function MaJ_Liste_Fichiers(chemin As String, maListe As Variant)
Dim i: i = 0
Dim ListeFichiers As String
Dim nomListe
Dim DirVar As String: DirVar = Dir(CheminBase & chemin)

Do While DirVar <> ""
If i < 1 Then ListeFichiers = DirVar Else ListeFichiers = ListeFichiers & ";" & DirVar
DirVar = Dir()
i = i + 1
Loop

Set nomListe = maListe
    nomListe.RowSourceType = "Liste valeurs"
    nomListe.RowSource = ListeFichiers
End Function

'Exemple d'utilisation :
'variablequelconque = MaJ_Liste_Fichiers("\tablox_bord\TBord_detail*.*", maListe:=Me.listeDetail)
Contrôle d'une log ftp Function CheckProcessusFTP() As Boolean

Dim FileNumber  'contient le numéro de fichier alloué par la méthode freefile
FileNumber = FreeFile   'le système aloue un numéro de fichier pour la méthode open

Dim WholeLine As String, DebutChaine As String
Dim loginOk As Boolean, connectOk As Boolean, transfertOk As Boolean, commandeGetOk As Boolean

'Ouverture en mode lecture du fichier de compte-rendu
Open CheminBase & "compterendu.txt" For Input As #FileNumber

Do While Not EOF(FileNumber)    'Boucler tant que ce n'est pas la fin de fichier
    Line Input #FileNumber, WholeLine   'stockage d'une ligne entière dans la variable WholeLine
    DebutChaine = Mid(WholeLine, 1, 3)  'stockage des trois premiers caractères de la ligne
    Select Case DebutChaine
        Case 230: loginOk = True
        Case 250: connectOk = True
        Case 200: commandeGetOk = True
        Case 226: transfertOk = True
    End Select
Loop

If loginOk = True And connectOk = True
    And commandeGetOk = True And transfertOk = True Then
CheckProcessusFTP = True
End If
Close #FileNumber
End Function
Envoi de mail Public Sub envoimail(Optional mytexte As String)
Dim myDestinataires, myObjet, myolApp, myNameSpace, myItem, i
    myDestinataires = Array(GetParametre("tableadmin","champdestinataire"))
    myObjet = "test mail"
   
    Set myolApp = CreateObject("Outlook.Application")
    Set myNameSpace = myolApp.GetNamespace("MAPI")
    Set myItem = myolApp.CreateItem(olMailItem)
   
    myItem.Display
    myItem.Subject = myObjet
    myItem.Body = mytexte
   
    For i = LBound(myDestinataires) To UBound(myDestinataires)
        myItem.Recipients.Add myDestinataires(i)
    Next
    SendKeys "^{enter}"
End Sub
Envoi d'un objet, ici une table DoCmd.SendObject acSendTable, "tableExport", acFormatXLS,
 "maildestinataire", "", "", "sujetMessage", "corpsMessage", False

 

 


Opérations sur date transposable sur les requêtes

'Lundi=1, Dimanche=7
mercrediencours = Format(DateAdd("d", (3 - (WeekDay(DateAdd("ww", 0, Now()), 2))), DateAdd("ww", 0, Now())))
mardiencours = Format(DateAdd("d", (x - (WeekDay(DateAdd("ww", 0, Now()), 2))), DateAdd("ww", 0, Now())), "dd/mm/yy")

dimanchedernier = Format(DateAdd("d", (x - (WeekDay(DateAdd("ww", 0, Now()), 7))), DateAdd("ww", 0, Now())), "dd/mm/yy")
lundidernier = Format(DateAdd("d", (x - (WeekDay(DateAdd("ww", -1, Now()), 1))), DateAdd("ww", -1, Now())), "dd/mm/yy")

semainederniere = Format(Format(Date, "ww", 2, 3), "00") - 1
=> nomdelabase = "semaine" & Format(semainederniere, "00") & "-an" & Format(Year(lundidernier), "0000")

 

 

'Une liste déroulante dont le contenu dépend d'une requête peut-être trié en croissant une décroissant

Private Sub Filtrer_Liste_Click()
If TriListeParClé1 = False Then
ListeDeroulante1.RowSource = "SELECT DISTINCTROW table_test.Clé1, table_test.Clé2, table_test.Clé3 FROM table_test ORDER BY table_test.Clé1;"
ListeDeroulante1.Requery 'demander à access de réexécuter la requête qui alimente la liste
TriListeParClé1 = True
Filtrer_Liste.Caption = "Trier par Clé2 & Clé3"
Else
ListeDeroulante1.RowSource = "SELECT DISTINCTROW table_test.Clé1, table_test.libelleClé2, table_test.Clé3 FROM table_caisseregionale ORDER BY table_test.Clé2, table_test.Clé3;"
ListeDeroulante1.Requery
TriListeParClé1 = False
Filtrer_Liste.Caption = "Trier par Clé1"
End If
End Sub

'Analyse d'une requête

Dim analyse As Recordset 'contiendra le résultat de la requête d'analyse du fichier puce
Dim nombreEnreg As Integer 'nombre des enregistrements de l'objet analyse
Dim compteur As Integer 'incrémenter un compteur pour boucler sur les enregistrements

'ouverture requête Analyse_Données_Importées_CPuce
Set analyse = CurrentDb.QueryDefs("Analyse_Données_Importées_CPuce").OpenRecordset
On Error Resume Next
analyse.MoveLast: nombreEnreg = analyse.RecordCount
If nombreEnreg <> 0 Then
'CreateObject("WScript.Shell").PopUp "Regardez la requête analyse, " & "Problème", 1, "il y a des problèmes"
analyse.MoveFirst
compteur = 1
Do While Not analyse.EOF
analyse.Delete
analyse.MoveNext
Loop
End If