Discussion :

[Aladin_23]

Bonjour le forum
Suite récupération de code pour relier 2 base de donnée, je cherche à le modifier afin de pouvoir ouvrir la boite de dialogue de windows afin de choisir le chemin et la base si une modification du chemin a été faite.

Ci joint 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
Function RefreshLinks() As Boolean
Dim collTbls As Collection
Dim i As Integer
Dim strTbl As String
Dim dbCurr As Database
Dim dbLink As Database
Dim tdfTables As TableDef
Dim strBeFile As String
Dim collTables As New Collection
Dim tdf As TableDef
Dim strMsg As String
 
    Set dbCurr = CurrentDb
    dbCurr.TableDefs.Refresh
 
    For Each tdf In dbCurr.TableDefs
        With tdf
            If Len(.Connect) > 0 Then
                    collTables.Add Item:=.Name & .Connect, Key:=.Name
            End If
        End With
    Next
    Set collTbls = collTables
 
'   strBeFile = CurrentProject.Path & "\Data\TestData.mdb"
 
     Set dbLink = DBEngine(0).OpenDatabase(strBeFile)
 
 
 
     For i = collTbls.Count To 1 Step -1
            strTbl = Left$(collTbls(i), InStr(1, collTbls(i), ";") - 1)
                Set tdfTables = dbCurr.TableDefs(strTbl)
                With tdfTables
                    .Connect = ";Database=" & strBeFile
                    .RefreshLink
                End With
      Next
 
        strMsg = "Reinitialisation liaison " & vbNewLine & vbNewLine
        strMsg = strMsg & "• La mise à jour des liaisons de l' application a été réalisé avec succès." & vbNewLine
        MsgBox strMsg, vbInformation, "Liaisons tables"
End Function

Merci d' avance pour toute aide
Aladin

[alassanediakite]

Salut

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
 
Function RefreshLinks() As Boolean
Dim collTbls As Collection
Dim i As Integer
Dim strTbl As String
Dim dbCurr As Database
Dim dbLink As Database
Dim tdfTables As TableDef
Dim strBeFile As String
Dim collTables As New Collection
Dim tdf As TableDef
Dim strMsg As String
 
    Set dbCurr = CurrentDb
    dbCurr.TableDefs.Refresh
 
    For Each tdf In dbCurr.TableDefs
        With tdf
            If Len(.Connect) > 0 Then
                    collTables.Add Item:=.Name & .Connect, Key:=.Name
            End If
        End With
    Next
    Set collTbls = collTables
 
'   strBeFile = CurrentProject.Path & "\Data\TestData.mdb"
'partie ajoutée (il faut ajouté la référence à Microsoft Office xx.x Library)
With Application.FileDialog(msoFileDialogFilePicker)
      .AllowMultiSelect = False
      .Title = "Choix de la base"
      .Filters.Clear
      .Filters.Add "BD access", "*.mdb, *.accdb"
            If .Show = True Then
         strBeFile  = Trim(.SelectedItems.item(1))
      Else
         MsgBox "Choix annulé!"
      End If
   End With
'fin partie ajoutée
     Set dbLink = DBEngine(0).OpenDatabase(strBeFile)
 
 
 
     For i = collTbls.Count To 1 Step -1
            strTbl = Left$(collTbls(i), InStr(1, collTbls(i), ";") - 1)
                Set tdfTables = dbCurr.TableDefs(strTbl)
                With tdfTables
                    .Connect = ";Database=" & strBeFile
                    .RefreshLink
                End With
      Next
 
        strMsg = "Reinitialisation liaison " & vbNewLine & vbNewLine
        strMsg = strMsg & "• La mise à jour des liaisons de l' application a été réalisé avec succès." & vbNewLine
        MsgBox strMsg, vbInformation, "Liaisons tables"
End Function

@+

[Aladin_23]

Bonsoir alassanediakite
Merci d' avoir répondu à mon appel, j' ai testé le code et il fonctionne correctement. Mais serait il possible de mettre un test je m' explique:
verifie si les liaisons sont ok en ce cas la fonction se termmine mais si les liaisons sont KO a ce moment on ouvre l' explorateur et on choisi la base
Aladin

[alassanediakite]

Salut

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
 
Private sub verifieliaison()
on error goto liaison
dim t as tabledef
'Tu tentes un accès à une des tables liées:
set t=currentdb.tabledefs("lenomdelatableliée")
set t=nothing
exit sub
liaison:
'si l'accès échoue on établi les liaisons avec l'appel à la fonction précédente
'à savoir que l'échec peut avoir une autre raison!
RefreshLinks 
end sub

@+

[Aladin_23]

Bonjour alassanediakite
Désolé mais la verification des liaisons ne fonctionne pas
Aladin

[alassanediakite]

Quel est le message d'erreur? et à quelle ligne ça bloque?
@+

[Aladin_23]

Bonjour alassanediakite
Pour l' utilisation je m' etais mélangé avec les 2 modules RefreshLinks, J' ai tout repris et et le test de la liaison et l' ouverture de la fenetre Windows est ok.

Code :

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

1
2
3
4
5
6
7
8
9
10
Public Sub verifieliaison()
On Error GoTo liaison
Dim t As TableDef
'Tu tentes un accès à une des tables liées:
Set t = CurrentDb.TableDefs("tbl")
Set t = Nothing
Exit Sub
liaison:
RefreshLinks
End Sub

Mais si dans la verification de la liaison le resultat est positif et il doit sortir et ne pas appeler le RefreshLink, il ne sort pas mais ouvre de nouveau l' explorateur de windows. Peux tu faire une modif dessus. Merci d' avance
Aladin

[alassanediakite]

Salut
Entre les lignes...

Code :

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

1
2
3
 
liaison:
RefreshLinks

tu place...

Code :

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

Msgbox err.description

Tu saura le problème qui l'envoie à ce point.
@+