Aide modif code vba pour liaison base

Version imprimable

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:

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

Salut

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

16/11/2012, 18h14
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

Salut

Code:

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

19/11/2012, 10h59
Aladin_23

Bonjour alassanediakite
Désolé mais la verification des liaisons ne fonctionne pas
Aladin
19/11/2012, 13h22
alassanediakite

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

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:

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

20/11/2012, 17h44
alassanediakite
Salut
Entre les lignes...
Code:

1 2 3 liaison: RefreshLinks
tu place...

Code:

Msgbox err.description

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