Créer copie de la base en cours

**HDU71000** · 21/01/2018, 01h27

Hello,

je désire, via un code vba, copier les tables de la base courante dans une autre base (vierge, qui prendra le nom de la date).

Bon, pour la date, la création du répertoire, tout roule. Mais je ne sais pas comment copier les tables de la base en cours (donc ouverte) dans une nouvelle base qui devrait être créée à la volée...

Voici la partie du code qui pose souci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
'On définit le nom de la base cible avec année-mois-jour-heure-seconde
annee_sauve = Format(Now, "yyyy")
mois_sauve = Format(Now, "mm")
jour_sauve = Format(Now, "dd")
heure_sauve = Format(Now, "hh")
minute_sauve = Format(Now, "nn")
seconde_sauve = Format(Now, "ss")
base_cible = dossier_sauvegarde_annee_mois & annee_sauve & "-" & mois_sauve & "-" & heure_sauve & "-" & minute_sauve & "-" & seconde_sauve & ".accdb"
 
'MsgBox base_cible
 
'MsgBox CurrentProject.FullName
FileCopy CurrentProject.FullName, base_cible

Evidemment, cela bloque sur la dernière ligne, puisque la base est ouverte.

Une idée please ?

Merci.

++

Invité · 21/01/2018, 05h07

Bonjour

Regardes du coté de la méthode : DoCmd.TransferDatabase

Philippe

**HDU71000** · 21/01/2018, 17h31

Envoyé par Philippe JOCHMANS

Bonjour

Regardes du coté de la méthode : DoCmd.TransferDatabase

Philippe

Merci,

mais c'était prévu, ensuite.

Pour utiliser TransferDatabase, il faut que la base cible existe, et c'est là mon souci.

A+

**HDU71000** · 22/01/2018, 01h30

J'ai beau chercher sur google,

je ne trouve que des manips pour fichier txt ou excel.

Je veux juste, dans un premier temps, créer un .accdb.

Merci

**Gabrieel** · 22/01/2018, 08h46

proprosition bête, mais si c'est pas trop long on essaiera pas des requêtes de créations de tables?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

docmd.openquery "tarequetedecreationdetable"

ou

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

docmd.runsql "SELECT tblPVE.* INTO tTablebkp FROM tTableSource;"

**Ric500** · 22/01/2018, 15h26

Bonjour,

Dans mon cas, j'ai une très vieille procédure qui fonctionne encore qui pourrait peut-être te servir si tu peux t'en inspirer.
Ma base contient invariablement des tables locales (temporaires ou autres) + des tables attachées (dorsale) + une table "Attached" qui les recense + une table TempSauve avec un booléen pour désigner celles qui sont à exporter (toutes, pour une sauvegarde). Cette dernière contient, bien sûr toutes les tables de "Attached"
Ma procédure importe temporairement les tables de la dorsale dans la frontale, les exporte dans la base créée, puis les supprime de la frontale; elle recrée ensuite les relations.
C'est très rapide.

Création base + export:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub BackupData()
    On Error GoTo ErrMan
    Dim tps, tps2: tps = Timer
    DoCmd.OpenForm ("Sauvegarde")
    'On alimente un fichier temporaire avec les tables à sauver
    Dim StrSQL As String, laps_mn As String, laps_s As String
    StrSQL = "SELECT Attached.LaTable, Yes AS Sauvegarde INTO TempSauve FROM Attached;"
    DoCmd.SetWarnings False
    DoCmd.RunSQL (StrSQL)
    DoCmd.SetWarnings True
    'Chemin du programme
    Dim chemProg As String
    chemProg = Nz(DLookup("Chemin", "CHEMINS", "Fonction='" & "Base de données locale" & "'"), "")
    'Chemin des données
    Dim chemData As String
    chemData = Nz(DLookup("Chemin", "CHEMINS", "Fonction='" & "Données" & "'"), "")
    'Chemin de sauvegarde
    Dim chem As String
    chem = Nz(DLookup("Chemin", "CHEMINS", "Fonction='" & "Sauvegarde" & "'"), "")
    If chem = "" Then
        MsgBox ("Veuillez créer un dossier de 'Sauvegarde' dans l'onglet 'Chemins' du module des paramètres...")
        Exit Sub
    End If
    'Assignation nom de la sauvegarde
    Dim NomFich As String
    Dim CRLF, laDate As String
    Dim rep
    CRLF = vbCrLf
    laDate = Format(Now(), "dd-mm-yy")
    NomFich = "Sauvegarde Data du " & laDate & ".mdb"
    'Procédure de sauvegarde
    ChDrive (Left(chem, 2))
    ChDir (chem)
    rep = Dir(chem & NomFich)
    If rep <> "" Then
        rep = MsgBox("Le système a trouvé une sauvegarde du même nom dans le dossier de sauvegarde." & CRLF & CRLF & _
            "Voulez-vous la remplacer ?", vbQuestion + vbOKCancel)
        If rep = 2 Then
            Exit Sub
            Else
        End If
        Kill (chem & NomFich)
    End If
 
    'Création de la nouvelle base
    Dim wrkDefault As Workspace
    Dim dbsNew As Database
    Dim MyTableDef As TableDef
    Set wrkDefault = DBEngine.Workspaces(0)
    Set dbsNew = wrkDefault.CreateDatabase(NomFich, dbLangGeneral)
    DoEvents
    Set dbsNew = Nothing
    'Recense les tables à exporter de Data.mdb vers chem & NomFich
    Dim mabd As Database
    Dim Rec As Recordset
    Dim NomTable, NomChamp, Typ, Siz, Attrib
    Dim DefTable As TableDef
    Dim IdxTableD, IdxTableS, IdxTableS2 As Index
    Dim fld As Field
    Set mabd = CodeDb()
    Dim x, y As Integer
    StrSQL = "SELECT TempSauve.LaTable, TempSauve.Sauvegarde FROM TempSauve WHERE (((TempSauve.Sauvegarde)=Yes));"
    Set Rec = mabd.OpenRecordset(StrSQL)
    Rec.MoveLast
    x = Rec.RecordCount: y = 1
    Rec.MoveFirst
    'Tant qu'il y a des tables à créer...
        Do While Rec.EOF = False
            NomTable = Rec!laTable
            Forms!Sauvegarde!Msg.Caption = "Sauvegarde en cours...   " & NomTable
            'Gestion de la navette
            Select Case y
                Case 1 To 9: Call BougeNavette("Img1")
                Case 10 To 19: Call BougeNavette("Img2")
                Case 20 To 29: Call BougeNavette("Img3")
                Case Is >= 30: Call BougeNavette("Img4")
            End Select
 
                    DoCmd.TransferDatabase acImport, "Microsoft Access", chemData, acTable, NomTable, NomTable & "Temp"
                    DoEvents
                    DoCmd.TransferDatabase acExport, "Microsoft Access", chem & "\" & NomFich, acTable, NomTable & "Temp", NomTable
                    DoEvents
                    Call SupprimerTable(NomTable & "Temp")
                    DoEvents
            y = y + 1
            Rec.MoveNext
        Loop
        Forms!Sauvegarde!Msg.Caption = ""
        Forms!Sauvegarde!Shuttle1.Visible = True
        Forms!Sauvegarde!Msg.Caption = "Mise en place de l'intégrité relationnelle..."
        Forms!Sauvegarde!Img1.Visible = 0
        Forms!Sauvegarde!Img2.Visible = 0
        Forms!Sauvegarde!Img3.Visible = 0
        Forms!Sauvegarde!Img4.Visible = 0
        Forms!Sauvegarde!Msg2.Visible = 0
        Forms!Sauvegarde.Repaint
    'Création des relations dans le fichier de sauvegarde
    Call CréeRelSauvegarde(chemData, chem & "\" & NomFich)
    tps2 = Timer
    laps_mn = Trim(str(Minutes(tps2 - tps)))
    laps_s = Trim(str(Secondes(tps2 - tps)))
 
    StrSQL = "Sauvegarde effectuée en : " & laps_mn & " mn  " & laps_s & " s"
    Forms!Sauvegarde!Msg.Caption = StrSQL
    Forms!Sauvegarde.Repaint
 
    tps = Timer
    Do While Timer < tps + 5
    Loop
 
    DoCmd.Close acForm, "Sauvegarde"
Fin:
    Exit Sub

Création relations:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub CréeRelSauvegarde(sour, Dest)
On Error GoTo ErrMan
Dim wrkDefault As Workspace
Set wrkDefault = DBEngine.Workspaces(0)
Dim mabdData As Database
Dim mabdSauve As Database
Dim relData As Relation
Dim relSauve As Relation
Dim fldData As Field
Dim fldSauve As Field
 
Dim leNom, Tabl, FTabl, Attrib As String
Set mabdData = wrkDefault.OpenDatabase(sour)
Set mabdSauve = wrkDefault.OpenDatabase(Dest)
With mabdData
    For Each relData In .Relations
        leNom = relData.Name
        Tabl = relData.Table
        FTabl = relData.ForeignTable
        Attrib = relData.Attributes
        Set relSauve = mabdSauve.CreateRelation(leNom, Tabl, FTabl, Attrib)
        For Each fldData In relData.Fields
            leNom = fldData.Name
            FTabl = fldData.ForeignName
            relSauve.Fields.Append relSauve.CreateField(leNom)
            relSauve.Fields(leNom).ForeignName = FTabl
        Next fldData
        mabdSauve.Relations.Append relSauve
    Next relData
End With
Fin:
Exit Sub
ErrMan:
MsgBox (Error(err))
Resume Next
End Sub

Enjoy

**HDU71000** · 22/01/2018, 16h44

Envoyé par Gabrieel

proprosition bête, mais si c'est pas trop long on essaiera pas des requêtes de créations de tables?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

docmd.openquery "tarequetedecreationdetable"

ou

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

docmd.runsql "SELECT tblPVE.* INTO tTablebkp FROM tTableSource;"

Bonjour et merci,

mais vu le nombre de tables et que ce nombre évolue de temps en temps, cette solution ne me semble pas appropriée.

Merci

**HDU71000** · 22/01/2018, 16h46

Envoyé par Ric500

Bonjour,

Dans mon cas, j'ai une très vieille procédure qui fonctionne encore qui pourrait peut-être te servir si tu peux t'en inspirer.
Ma base contient invariablement des tables locales (temporaires ou autres) + des tables attachées (dorsale) + une table "Attached" qui les recense + une table TempSauve avec un booléen pour désigner celles qui sont à exporter (toutes, pour une sauvegarde). Cette dernière contient, bien sûr toutes les tables de "Attached"
Ma procédure importe temporairement les tables de la dorsale dans la frontale, les exporte dans la base créée, puis les supprime de la frontale; elle recrée ensuite les relations.
C'est très rapide.

Création base + export:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub BackupData()
    On Error GoTo ErrMan
    Dim tps, tps2: tps = Timer
    DoCmd.OpenForm ("Sauvegarde")
    'On alimente un fichier temporaire avec les tables à sauver
    Dim StrSQL As String, laps_mn As String, laps_s As String
    StrSQL = "SELECT Attached.LaTable, Yes AS Sauvegarde INTO TempSauve FROM Attached;"
    DoCmd.SetWarnings False
    DoCmd.RunSQL (StrSQL)
    DoCmd.SetWarnings True
    'Chemin du programme
    Dim chemProg As String
    chemProg = Nz(DLookup("Chemin", "CHEMINS", "Fonction='" & "Base de données locale" & "'"), "")
    'Chemin des données
    Dim chemData As String
    chemData = Nz(DLookup("Chemin", "CHEMINS", "Fonction='" & "Données" & "'"), "")
    'Chemin de sauvegarde
    Dim chem As String
    chem = Nz(DLookup("Chemin", "CHEMINS", "Fonction='" & "Sauvegarde" & "'"), "")
    If chem = "" Then
        MsgBox ("Veuillez créer un dossier de 'Sauvegarde' dans l'onglet 'Chemins' du module des paramètres...")
        Exit Sub
    End If
    'Assignation nom de la sauvegarde
    Dim NomFich As String
    Dim CRLF, laDate As String
    Dim rep
    CRLF = vbCrLf
    laDate = Format(Now(), "dd-mm-yy")
    NomFich = "Sauvegarde Data du " & laDate & ".mdb"
    'Procédure de sauvegarde
    ChDrive (Left(chem, 2))
    ChDir (chem)
    rep = Dir(chem & NomFich)
    If rep <> "" Then
        rep = MsgBox("Le système a trouvé une sauvegarde du même nom dans le dossier de sauvegarde." & CRLF & CRLF & _
            "Voulez-vous la remplacer ?", vbQuestion + vbOKCancel)
        If rep = 2 Then
            Exit Sub
            Else
        End If
        Kill (chem & NomFich)
    End If
 
    'Création de la nouvelle base
    Dim wrkDefault As Workspace
    Dim dbsNew As Database
    Dim MyTableDef As TableDef
    Set wrkDefault = DBEngine.Workspaces(0)
    Set dbsNew = wrkDefault.CreateDatabase(NomFich, dbLangGeneral)
    DoEvents
    Set dbsNew = Nothing
    'Recense les tables à exporter de Data.mdb vers chem & NomFich
    Dim mabd As Database
    Dim Rec As Recordset
    Dim NomTable, NomChamp, Typ, Siz, Attrib
    Dim DefTable As TableDef
    Dim IdxTableD, IdxTableS, IdxTableS2 As Index
    Dim fld As Field
    Set mabd = CodeDb()
    Dim x, y As Integer
    StrSQL = "SELECT TempSauve.LaTable, TempSauve.Sauvegarde FROM TempSauve WHERE (((TempSauve.Sauvegarde)=Yes));"
    Set Rec = mabd.OpenRecordset(StrSQL)
    Rec.MoveLast
    x = Rec.RecordCount: y = 1
    Rec.MoveFirst
    'Tant qu'il y a des tables à créer...
        Do While Rec.EOF = False
            NomTable = Rec!laTable
            Forms!Sauvegarde!Msg.Caption = "Sauvegarde en cours...   " & NomTable
            'Gestion de la navette
            Select Case y
                Case 1 To 9: Call BougeNavette("Img1")
                Case 10 To 19: Call BougeNavette("Img2")
                Case 20 To 29: Call BougeNavette("Img3")
                Case Is >= 30: Call BougeNavette("Img4")
            End Select
 
                    DoCmd.TransferDatabase acImport, "Microsoft Access", chemData, acTable, NomTable, NomTable & "Temp"
                    DoEvents
                    DoCmd.TransferDatabase acExport, "Microsoft Access", chem & "\" & NomFich, acTable, NomTable & "Temp", NomTable
                    DoEvents
                    Call SupprimerTable(NomTable & "Temp")
                    DoEvents
            y = y + 1
            Rec.MoveNext
        Loop
        Forms!Sauvegarde!Msg.Caption = ""
        Forms!Sauvegarde!Shuttle1.Visible = True
        Forms!Sauvegarde!Msg.Caption = "Mise en place de l'intégrité relationnelle..."
        Forms!Sauvegarde!Img1.Visible = 0
        Forms!Sauvegarde!Img2.Visible = 0
        Forms!Sauvegarde!Img3.Visible = 0
        Forms!Sauvegarde!Img4.Visible = 0
        Forms!Sauvegarde!Msg2.Visible = 0
        Forms!Sauvegarde.Repaint
    'Création des relations dans le fichier de sauvegarde
    Call CréeRelSauvegarde(chemData, chem & "\" & NomFich)
    tps2 = Timer
    laps_mn = Trim(str(Minutes(tps2 - tps)))
    laps_s = Trim(str(Secondes(tps2 - tps)))
 
    StrSQL = "Sauvegarde effectuée en : " & laps_mn & " mn  " & laps_s & " s"
    Forms!Sauvegarde!Msg.Caption = StrSQL
    Forms!Sauvegarde.Repaint
 
    tps = Timer
    Do While Timer < tps + 5
    Loop
 
    DoCmd.Close acForm, "Sauvegarde"
Fin:
    Exit Sub

Création relations:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub CréeRelSauvegarde(sour, Dest)
On Error GoTo ErrMan
Dim wrkDefault As Workspace
Set wrkDefault = DBEngine.Workspaces(0)
Dim mabdData As Database
Dim mabdSauve As Database
Dim relData As Relation
Dim relSauve As Relation
Dim fldData As Field
Dim fldSauve As Field
 
Dim leNom, Tabl, FTabl, Attrib As String
Set mabdData = wrkDefault.OpenDatabase(sour)
Set mabdSauve = wrkDefault.OpenDatabase(Dest)
With mabdData
    For Each relData In .Relations
        leNom = relData.Name
        Tabl = relData.Table
        FTabl = relData.ForeignTable
        Attrib = relData.Attributes
        Set relSauve = mabdSauve.CreateRelation(leNom, Tabl, FTabl, Attrib)
        For Each fldData In relData.Fields
            leNom = fldData.Name
            FTabl = fldData.ForeignName
            relSauve.Fields.Append relSauve.CreateField(leNom)
            relSauve.Fields(leNom).ForeignName = FTabl
        Next fldData
        mabdSauve.Relations.Append relSauve
    Next relData
End With
Fin:
Exit Sub
ErrMan:
MsgBox (Error(err))
Resume Next
End Sub

Enjoy

Merci,

je vais regarder cela à tête reposée.

Je reviens vous dire.

A+

**HDU71000** · 22/01/2018, 21h21

C'est OK,

de ton bazooka complet, j'ai juste gardé la partie qui m'intéressait : créer un fichier accdb.

Ensuite je fais le transfert des tables de la base en cours dans ce fichier nouvellement créé.

Parfait, je vais mettre le code ici pour ceux qui chercheraient à faire ce que je voulais :
1/ création d'un dossier "sauvegarde" dans le dossier de la base en cours
2 / création d'un sous-dossier nommé "anneeMois"
3/ création d'une base nommée annee-mois-jour-heure-minute-seconde.accdb
4/ copie des tables de la base en cours dans cette base de sauvegarde
5/ zip de la base de sauvegarde
6/ suppression du fichier non zippé.

Le temps de tout tester, et je reviens !

**HDU71000** · 22/01/2018, 22h08

Voici le code complet :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Dim dossier_sauvegarde As String
dossier_sauvegarde = CurrentProject.Path & "\sauvegardes\" 'on définit le dossier des sauvegardes
 
If Dir(dossier_sauvegarde, vbDirectory) = "" Then 'on regarde si le sous-répertoire "sauvegardes" existe
's'il n'existe pas, on le crée
  MkDir dossier_sauvegarde
End If
 
mois_systeme = Year(Now) & Month(Now) 'on récupere l'année et le mois du système concaténés
Dim dossier_sauvegarde_annee_mois As String
dossier_sauvegarde_annee_mois = CurrentProject.Path & "\sauvegardes\" & mois_systeme & "\"
 
If Dir(dossier_sauvegarde_annee_mois, vbDirectory) = "" Then 'on regarde si le sous-dossier année et mois du dossier "sauvegardes" existe
's'il n'existe pas, on le crée
  MkDir dossier_sauvegarde_annee_mois
End If
 
'maintenant, le sous-dossier existe
'on passe à la suite
 
'------------------ copie des tables ---------------------
 
'On définit le nom de la base cible avec année-mois-jour-heure-seconde
annee_sauve = Format(Now, "yyyy")
mois_sauve = Format(Now, "mm")
jour_sauve = Format(Now, "dd")
heure_sauve = Format(Now, "hh")
minute_sauve = Format(Now, "nn")
seconde_sauve = Format(Now, "ss")
base_cible = dossier_sauvegarde_annee_mois & annee_sauve & "-" & mois_sauve & "-" & jour_sauve & "-" & heure_sauve & "-" & minute_sauve & "-" & seconde_sauve & ".accdb"
 
 
'MsgBox CurrentProject.FullName
 
'Création de la nouvelle base ----------------------------------
    Dim wrkDefault As Workspace
    Dim dbsNew As Database
    Dim MyTableDef As TableDef
    Set wrkDefault = DBEngine.Workspaces(0)
    Set dbsNew = wrkDefault.CreateDatabase(base_cible, dbLangGeneral)
    DoEvents
    Set dbsNew = Nothing
 
'transfert des tables dans la nouvelle base ----------------------
 
Dim oTbl As TableDef 'on définit la variable oTbl comme objet de base de données
 
For Each oTbl In CurrentDb.TableDefs 'pour chaque objet de la base courante
    If oTbl.Attributes = 0 Then   ' Si l'objet est une table
    DoCmd.TransferDatabase acExport, "Microsoft Access", base_cible, acTable, oTbl.Name, oTbl.Name 'on copie
    End If 'sinon, on ne fait rien
Next
 
'la base est créée
 
' On va la zipper ----------------------------
 
' -----> ceci est l'algorithme de zip
Dim oShell As Object, Fso As Object
    Dim i As Long
    Dim Fichier As String, MyBinary As String
    Dim LeZip As Variant
    Dim MyHex As Variant
 
    Fichier = base_cible
    LeZip = base_cible & ".zip"
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    MyHex = _
        Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
 
    For i = 0 To UBound(MyHex)
        MyBinary = MyBinary & Chr(MyHex(i))
    Next
 
    With Fso.CreateTextFile(LeZip, True)
        .Write MyBinary
        .Close
    End With
 
    Set oShell = CreateObject("Shell.Application")
' -----< fin du zip
 
    oShell.Namespace(LeZip).CopyHere (Fichier)
 
' le fichier zip est créé
 
 
MsgBox "Sauvegarde des tables effectuée dans le fichier " & LeZip 'un petit message de confirmation...
 
 
Set Fso = Nothing
Set oShell = Nothing
 
Kill (Fichier) 'on supprime le fichier non zippé, pas besoin de le conserver
 
End Sub

En espérant qu'il serve.

A+ et merci

Créer copie de la base en cours [AC-2013]

VBA Access

Discussions similaires

Partager

Partager