[Access]auto copie d'une base access.

[benoit_iund]

Salut,

je souhaite copier ma base dans un repertoire de sauvegarde a son lancement en vba.
Je testais filecopy mais cet instruction ne fonctionne pas avec un fichier ouvert.

Ya t'il une autre methode?
Sinon je vais passer par un VBscript indépendant. Mais c moins clean.

[LedZeppII]

Bonsoir,

un exemple VBScript qui fonctionne dans VBA

Code :

1
2
3
4
5
6
7
Dim fso As Object, strDest As String
strDest = CurrentProject.Path & "\" & _
          Left(CurrentProject.Name, Len(CurrentProject.Name) - 4) & _
          ".bak." & Right(CurrentProject.Name, 3)
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile CurrentProject.FullName, strDest
Set fso = Nothing

A+

[christrabin]

j'utilises ce tutoriel

http://www.actionaccess.fr/tutorial1b.php

Cependant, il est à adapter (erreur sur le recorset vide).

Voir le forum pour les erreurs.

Au pire, voila mon code il est fonctionnel et à mettre dans un module mais il faudra l'adapter à ton cas

J'ai rajouté une fonction de choix du répertoire de sauvegarde, modifié les procédures si un formulaire est chargé, fait en sorte que la sauvegarde soit directe des la procédure appelée et non plus au bout de huit jours.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
 
Option Compare Database
Option Explicit
 
Public sCheminRépertoire As String
 
Public Function ContrôleSauvegarde()
    'On Error GoTo GestionErreur
    Dim rs As DAO.Recordset
 
 
    Set rs = CurrentDb.OpenRecordset("Paramètres", dbOpenDynaset)
 
        If Application.CurrentProject.AllForms("Réinitialisation des bases").IsLoaded Then
            Forms![Réinitialisation des bases].ComReinitCheminAcces.Visible = False
        End If
 
 
'ouverture du recordset de la table Paramètres
 
    If IsNull(rs![RepSauv].Value) = True Then
    MsgBox "Veuillez indiquez le chemin répertoire de sauvegarde", vbExclamation + vbOKOnly
 
    sCheminRépertoire = SelectFolder("Sélectionnez un répertoire :", Forms![Réinitialisation des bases].Hwnd)
 
        With rs
             .Edit
                rs![RepSauv] = sCheminRépertoire
            .Update
        End With
    End If
    rs.MoveFirst
 
'lors de la première utilisation de la base, la date de dernière sauvegarde est non renseignée
'ce qui veut dire aussi qu'il n'y a jamais eu de sauvegarde de faite donc on effectue la première sauvegarde
 
    If IsNull(rs!DateDernièreSauvegarde.Value) = True Then
    Call SauvegardeBase 'appel de la fonction SauvegardeBase
    End If
 
'Contrôle que la date de dernière sauvegarde est antérieure
'de plus d' UNE JOURNEE à la date d'aujourd'hui:
 
    'If DateDiff("d", rs!DateDernièreSauvegarde, Date) > 1 Then
    Call SauvegardeBase 'appel de la fonction SauvegardeBase
    'End If
 
GestionErreur:
 
Exit Function
'les erreurs seront traitées dans le module
    End Function
 
Public Function SauvegardeBase()
On Error GoTo GestionErreur
 
'Référence nécessaire : Microsoft Scripting Runtime
    Dim fs As New Scripting.FileSystemObject
    Set fs = CreateObject("Scripting.FileSystemObject")
 
DoCmd.Hourglass True
DoCmd.Echo True, "Sauvegarde en cours...."
 
Dim rs As DAO.Recordset
    Set rs = CurrentDb.OpenRecordset("Paramètres", dbOpenDynaset)
 
Dim Destination As String 'répertoire de sauvegarde
Dim Source As String 'Répertoire où se trouve la base de donnée courante
Dim NOMBASE As String 'nom de la base frontale (base de donnée courante)
Dim NomSauv As String 'nom de sauvegarde de la base de donnée
 
    rs.MoveFirst
    Source = Left(CurrentDb.Name, InStr(CurrentDb.Name, Dir(CurrentDb.Name)) - 1)
    NOMBASE = Left(Dir(CurrentDb.Name), Len(Dir(CurrentDb.Name)) - 4)
 
'Contrôle que le chemin indiqué dans RepSauvse termine bien par un \
    If Right(rs!RepSauv.Value, 1) <> "\" Then
        Destination = rs!RepSauv.Value & "\"
    Else
    Destination = rs!RepSauv.Value
    End If
 
'Format de sauvegarde : Nom de la base de donnée jj mm aa
    NomSauv = NOMBASE + " " + CStr(Day(Now())) + " " + CStr(Month(Now())) + " " + CStr(Year(Now()))
 
    If Dir(Destination, vbDirectory) = "" Then
            If MsgBox("Le chemin indiqué n'existe pas! Souhaitez-vous le créer?", vbQuestion + vbYesNo, "Tentative de sauvegarde automatique:") = vbYes Then
                fs.CreateFolder CStr(Destination)
 
'création du répertoire indiqué dans RepSauv
                GoTo Suite1
 
            Else
                MsgBox "La sauvegarde n'a pas pu être effectuée!", vbExclamation, "Tentative de sauvegarde automatique:"
                rs.Close
                Set rs = Nothing
 
                        If Application.CurrentProject.AllForms("Réinitialisation des bases").IsLoaded Then
                            Forms![Réinitialisation des bases].ComReinitCheminAcces.Visible = True
                        End If
 
                Exit Function
            End If
 
     Else
 
        GoTo Suite1
    End If
 
Suite1:
    'Copie du fichier source vers le répertoire de destination
 
        fs.CopyFile CStr(Source) + CStr(NOMBASE) + ".mdb", CStr(Destination) + CStr(NomSauv) + ".mdb", True
 
    'vérification que le fichier de sauvegarde existe bien dans le
    'répertoire prévu avec le nom prévu:
        If Dir(CStr(Destination) + CStr(NomSauv) + ".mdb", vbDirectory) = "" Then
            MsgBox "La sauvegarde ne s'est pas faite!!", vbExclamation, "Tentative de sauvegarde automatique:"
            rs.Close
            Set rs = Nothing
        Else
            If Application.CurrentProject.AllForms("Réinitialisation des bases").IsLoaded Then
            MsgBox "Sauvegarde effectuée avec succès!", vbInformation, "Tentative de sauvegarde automatique:"
            End If
 
'Mise à jour de la date de dernière sauvegarde:
            rs.Edit
            rs!DateDernièreSauvegarde = Date
            rs.Update
            rs.Close
            Set rs = Nothing
        End If
 
        DoCmd.Echo True
        DoCmd.Hourglass False
 
                If Application.CurrentProject.AllForms("Réinitialisation des bases").IsLoaded Then
                    Forms![Réinitialisation des bases].ComReinitCheminAcces.Visible = True
                End If
 
        Exit Function
 
GestionErreur:
        Select Case err.Number
        Case 3021
        MsgBox "Aucun enregistrement dans la base", vbCritical + vbOKOnly, "Information"
        Case 3044
        MsgBox "Le chemin d'accès n'est pas valide. Assurez-vous que le nom du chemin d'accès est correct et qu'une connexion est établie avec le serveur sur lequel vous souhaitez effectuer la sauvegarde.", vbExclamation + vbOKOnly, "Tentative de sauvegarde automatique:"
 
        Case 76
        MsgBox "Chemin d'accès introuvable.", vbExclamation + vbOKOnly, "Tentative de sauvegarde automatique:"
 
        Case Else
        MsgBox "Une erreur non traitée s'est produite (" & err.Number & "-" & err.Description & ")", vbExclamation + vbOKOnly, "Tentative de sauvegarde automatique:"
 
        End Select
 
            If Application.CurrentProject.AllForms("Réinitialisation des bases").IsLoaded Then
                Forms![Réinitialisation des bases].ComReinitCheminAcces.Visible = True
            End If
 
End Function

la procédure selectfolder appellée permet de choisir le répertoire de sauvegarde

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
 
 
Option Compare Database
 
'###########################################Module d'ouverture de répertoire#####################################"
 
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
 
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
 
Private Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
     ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
 
'La fonction suivante ouvre la fenêtre de sélection de répertoire standard de Windows et renvoie le chemin du répertoire sélectionné. Les paramètres attendus sont le titre à afficher et l'identifiant de la fenêtre parente.
Public Function SelectFolder(Titre As String, Handle As Long) As String
 
Dim lpIDList As Long
Dim strBuffer As String
Dim strTitre As String
Dim tBrowseInfo As BrowseInfo
 
strTitre = Titre
With tBrowseInfo
    .hWndOwner = Handle
    .lpszTitle = lstrcat(strTitre, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
 
lpIDList = SHBrowseForFolder(tBrowseInfo)
 
If (lpIDList) Then
    strBuffer = String(260, vbNullChar)
    SHGetPathFromIDList lpIDList, strBuffer
    SelectFolder = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
 
End If
 
End Function

[benoit_iund]

je suis passer par un vb script

mais je te remerci le tutoriel est interressant.

[Maxence HUBICHE]

Mouaip !

sinon, un bon vieil xcopy sous DOS fonctionne aussi *(à lancer en shell