[AC-2010] Modification du path de la base de données

Bonsoir Nico820.
J'utilise une fonction de Dolphy:

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
Option Compare Database
Option Explicit
 
Function LierTables(strChmFichier As String) As Boolean
'---------------------------------------------------------------------------------------
' Procédure      : Function ==> LierTables
' Auteur         : Dolphy           http://dolphy35.developpez.com/
' Commentaires   : Permet de remettre les liaisons en fonction du chemin sélectionné
' Lien vers Faq  : néant
'---------------------------------------------------------------------------------------
'
'Déclaration des variables
    Dim dbBase As DAO.Database
    Dim tbdTables As DAO.TableDef
    Dim rst As DAO.Recordset
 
    'Initialise le retour de la Fonction
    LierTables = False
 
    'Instancie la base courrante
    Set dbBase = CurrentDb
    'charge la table dans le Recordset rst
    Set rst = dbBase.OpenRecordset("tblTablesAttachees2", dbOpenDynaset)
 
    'Inhibe les messages d'alertes
    DoCmd.SetWarnings False
 
    'Vide la Tables contenant la liste des tables attachées
    DoCmd.RunSQL "DELETE * FROM tblTablesAttachees2"
 
    'Boucle Parcourant toutes les tables de la Bdd en cours
    For Each tbdTables In dbBase.TableDefs
 
        'Teste l'attribut de la table pour savoir si c'est une table liée
        If tbdTables.Attributes And dbAttachedTable And Not (tbdTables.Name = "~TMPCLP431871") Then
            rst.AddNew                              'Ajoute un enregistrements
            rst!TablesAttachees = tbdTables.Name    'Ajoute la table dans le Champs
            rst.Update                              'Mise à jour
        End If
 
    Next tbdTables
 
    'Mise à jour du Recordset après ajout des tables
    rst.Requery
 
    'Test la position du pointeur si il ne se situe pas en début de table
    If Not rst.BOF Then
        rst.MoveFirst   'déplacement du pointeur sur le premier enregistrement
    End If
 
    'Boucle parcours de la table tant que l'on arrive pas sur le dernier.
    While Not rst.EOF
 
        'Définition de l'objet TableDefs avec table stockées dans TablesAttachees
        With dbBase.TableDefs(rst!TablesAttachees.Value)
            'Redéfini la propriété connect de la table avec la nouvelle base
            .Connect = ";DATABASE=" & strChmFichier
            'Remet à jour la liaison de la table
            .RefreshLink
        End With
        'Efface l'enregistrement de la Table
        rst.Delete
        'Enregistrement suivant
        rst.MoveNext
 
    Wend
 
    'Liberation des variables
    dbBase.Close
    Set dbBase = Nothing
    Set rst = Nothing
 
    'Re-active les messages d'alertes
    DoCmd.SetWarnings True
 
    'Affiche Message
    MsgBox ("mise à jour terminée")
 
    'Renvoi la fonction à true
    LierTables = True
 
End Function

et je l'appelle depuis un bouton sur un formulaire:

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
Private Sub ChangeBase_Click()
    Dim strChemin As String
 
 
    On Error GoTo ChangeBase_Click_Error
 
    Select Case MsgBox("Veux-tu pointer vers une autre base de données ?", vbOKCancel Or vbQuestion Or vbSystemModal Or vbDefaultButton1, Application.Name)
 
    Case vbOK
 
        'Ouverture de la fenêtre Windows et stockage du chemin dans la variable
        strChemin = OuvrirUnFichier(Me.hwnd, "Parcourir", 1, "Fichiers Access", "mdb")
 
        'Test si présence de caractères dans la variable au cas où l'utilisateur annule
        If Len(strChemin) <> 0 Then
 
            'Appel Fonction de Liaison table avce le chemin en paramètre et test retour de la fonction
            If LierTables(strChemin) = True Then
 
                'Code si la fonction c'est réalisée sans encombre
                Select Case MsgBox("Si c'est une base vierge, il faut peut etre redefinir les dates d'exploitation?", vbOKCancel Or vbQuestion Or vbSystemModal Or vbDefaultButton1, Application.Name)
 
                Case vbOK
 
                    Me.Fille9.Form!debfest.SetFocus
                    Exit Sub
 
                Case vbCancel
                    DoCmd.SetWarnings False
 
                    ' fonction de mise àjour des plannings
'                    Call crecal(2007, 6, 7)
'                    CalculPlanning
'                    Call crecal_horaire(2007, 6, 7)
'                    CocheeVehicule
'                    CocheeSalleHoraire
'                    CocheeSalleHoraireDemiHeure
'                    CocheeTechniciens
'
'                    Maj_fiche_techniciens
'                    DoCmd.SetWarnings True
                End Select
 
 
            Else
 
                'Message si la fonction n'a pas renvoyer le True
                MsgBox "Mise à jour des Tables non éffectuées, " & vbCrLf & _
                       "veuillez contacter l'administrateur de la base.", vbCritical, "Liaisons des tables"
                'Fermeture de l'application
                Exit Sub    'DoCmd.Quit
 
            End If
 
        Else
 
            'Message si l'utilisateur à annuler la sélection du chemin
            If MsgBox("Annulation par utilisateur." & vbCrLf & _
                      "Voulez-vous fermer l'application ?", vbYesNo + vbInformation, "Liaisons des tables") = vbYes Then
                'Fermeture de l'application
                DoCmd.Quit
 
 
            End If
 
 
        End If
 
 
    Case 3043   'Erreur levée si Access n'arrive ps à se connecter au réseau
 
        MsgBox "Il est impossible de se connecter au réseau," & vbCrLf & _
               "veuillez contacter votre administrateur réseau.", vbCritical, "Erreur réseau"
 
        Select Case Err.Number
        Case 3049, 3428  'Base Principale corrompue
 
            MsgBox "La base principale est endommagée," & vbCrLf & _
                   "veuillez contacter l'administreteur de cette base.", vbCritical, "Base Principale endommagée"
 
        Case Else
 
            MsgBox "Erreur N°" & Err.Number & vbCrLf & Err.description
        End Select
 
    Case vbCancel
 
 
    End Select
 
    On Error GoTo 0
    Exit Sub
 
ChangeBase_Click_Error:
 
    MsgBox "Error " & Err.Number & " (" & Err.description & ") in procedure ChangeBase_Click of Document VBA Form_ComDateHeureExploitation"
 
End Sub

Cdlt