Discussion :

[HDU71000]

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é]

Bonjour

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

Philippe

[HDU71000]

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]

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]

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]

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]

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