Problème avec code table liée

**manutazounet** · 03/03/2013, 16h03

Bonjour,

J'ai trouver grâce à votre forum comment refaire la liaison de table, mais je me heurte a un soucis.

J'ai bien appliqué le code "Lier les tables" de Dolphy mais il me marque une erreur 3001 et me souligne le Refreshlink. Je suis débutant en Vba mais je ne comprend pas pourquoi une tel erreur???

Merci pour votre aide

Le code :

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
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("tblTablesAttachees", dbOpenDynaset)

    'Inhibe les messages d'alertes
    DoCmd.SetWarnings False
    
    'Vide la Tables contenant la liste des tables attachées
    DoCmd.RunSQL "DELETE * FROM tblTablesAttachees"
    
    '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 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 (c'est ca qu'il me marque en erreur???)
        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

**jimbolion** · 03/03/2013, 16h18

manutazounet,

Pour la partie code tout à l'air OK. Je viens de le valider sur mon PC.

Donc je crains que tu n'es un lien dans ta table actuelle qui pointe vers une table (ou un chemoin invalide) qui n'existerait plus dans la dorsale.

Afin de savoir laquelle rajoute un msgbox devant l'erreur :

Code :

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

1
2
3
4
.Connect = ";DATABASE =" & strChmFichier
'Remet à jour la liaison de la table
msgbox strChmFichier
.RefreshLink '(c'est ca qu'il me marque en erreur???)

Tiens moi au courant

JimBoLion

**manutazounet** · 03/03/2013, 17h15

Merci pour ta réponse. Je viens de mettre la MsgBox le soucis c'est qu'il me met toujours l'erreur et en plus la MsgBox s'affiche mais vide. Dans ma table tblTablesAttachees j'ai bien toutes les tables qui se trouvent dans la dorsale.

**LedZeppII** · 03/03/2013, 17h29

Bonjour,

Est-ce que tu appelles bien la fonction en lui donnant en paramètre le nouveau chemin complet vers la dorsale ?
Par exemple :

Code :

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

1
2
3
4
Dim strLaNouvelleDorsale As String
 
strLaNouvelleDorsale = "C:\Documents and Settings\Moi\Mes documents\La Dorsale.mdb"
LierTables strLaNouvelleDorsale

A+

**manutazounet** · 03/03/2013, 17h41

ah non car en fait je t'explique. J'ouvre ma base j'ai un code qui recherche si la liaison avec la dorsale est faite sinon cela n'ouvre une fenêtre pour que j'aille chercher l'emplacement de ma dorsale et faire la liaison.

Code au démarrage :

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
Private Sub Form_Timer()
'---------------------------------------------------------------------------------------
' Procédure      : Sub  ==> Form_Timer
' Auteur         : Dolphy           <a href="http://dolphy35.developpez.com/" target="_blank">http://dolphy35.developpez.com/</a>
' Commentaires   : Permet de contrôler et de proposer les mise à jour des tables
' Lien vers Faq  : néant
'---------------------------------------------------------------------------------------
'
On Error GoTo Err_Form_timer
 
'Déclaration variable
Dim strTemp As String
Dim strChemin As String
 
    'arrêt d timer
    Me.TimerInterval = 0
 
    If DLookup("VerrouAdmin", "tblAdmin") = False Then
 
        DoCmd.Close
        DoCmd.OpenForm ("MenuGeneral")
        Exit Sub
 
    End If
 
Err_Form_timer:
 
    Select Case Err.Number
 
        Case 3024, 3044  'Erreur lévée si Access ne trouve pas la base Principale ou le chemin n'est pas valide
 
            If MsgBox("La connexion à la base principale à échouée, " & vbCrLf & _
            "voulez-vous redéfinir les liaisons ?", vbYesNo + vbExclamation, "") = vbYes Then
 
annul:
                'Ouverture de la fenêtre Windows et stockage du chemin dans la variable
                strChemin = OuvrirUnFichier()
 
                '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
 
                        DoCmd.Close
                        'Code si la fonction c'est réalisée sans encombre
                        DoCmd.OpenForm ("MenuGeneral")
 
                    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
                        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
 
                    Else
                        'retour début proécédure d'appel des fonctions
                        GoTo annul
 
                    End If
 
 
                End If
 
            Else
                'Fermeture de l'application
                DoCmd.Quit
 
            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"
 
        Case 3049, 3428  'Base Principale corrompue
 
            MsgBox "La base principale est endommagée," & vbCrLf & _
            "veuillez contacter l'administrateur de cette base.", vbCritical, "Base Principale endommagée"
 
        Case Else
 
            MsgBox "Erreur N°" & Err.Number & vbCrLf & Err.Description
 
    End Select
End Sub

Code pour avoir une fenêtre qui s'ouvre pour chercher l'emplacement (peut être dans ce code ou il y a un soucis??)

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
Public Function OuvrirUnFichier()
Dim strFichier As String
Dim oFD As FileDialog
'Paramètre la fenêtre Ouvrir
Set oFD = Application.FileDialog(msoFileDialogOpen)
With oFD
'Ajoute les filtres pour fichiers images et tous
With .Filters
.Clear
.Add "Fichiers mdb", "*.mdb", 1
.Add "Tous", "*.*", 2
End With
'Renseignement du titre
.Title = "Insérer une liaison"
'Ouvre l'explorateur dans le fichier 'Mes documents' du User connecté.
.InitialFileName = ""
'Interdit la multi sélection
.AllowMultiSelect = False
'Permet de choisir le mode d'affichage dans l'explorateur (ici apperçu)
.InitialView = msoFileDialogViewPreview
'Permet de personnaliser le bouton.
.ButtonName = "Insérer"
'Affiche la fenêtre
.Show
End With
End Function

**LedZeppII** · 03/03/2013, 17h49

Il manquait deux ou trois petites choses dans OuvrirUnFichier().
Essaie avec ça:

Code vba :

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
Public Function OuvrirUnFichier()
Dim strFichier As String
Dim oFD As FileDialog
'Paramètre la fenêtre Ouvrir
Set oFD = Application.FileDialog(msoFileDialogOpen)
With oFD
'Ajoute les filtres pour fichiers images et tous
With .Filters
.Clear
.Add "Fichiers mdb", "*.mdb", 1
.Add "Tous", "*.*", 2
End With
'Renseignement du titre
.Title = "Insérer une liaison"
'Ouvre l'explorateur dans le fichier 'Mes documents' du User connecté.
.InitialFileName = ""
'Interdit la multi sélection
.AllowMultiSelect = False
'Permet de choisir le mode d'affichage dans l'explorateur (ici apperçu)
.InitialView = msoFileDialogViewPreview
'Permet de personnaliser le bouton.
.ButtonName = "Insérer"
'Affiche la fenêtre
If .Show() = True Then
   strFichier = .SelectedItems(1)
End If
End With
 
'Renvoyer Fichier
OuvrirUnFichier = strFichier
End Function

Problème avec code table liée [AC-2007]

VBA Access

Vue hybride

Discussions similaires

Partager

Partager