openaccess/test/source/modules/CtrlLiens.bas

Option Compare Database

'Option Explicit
Dim i As Long
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim Tbl As TableDef
Dim chemin As String
Dim Connection(20), ConnectionGood(20) As String
Dim iMax As Byte

Public strFiltre As String
Public strFile As String
Public strNomFile As String
Public RetVal As Long

Public Function Controler_Liens() 'Fonction de contrôle des liens
Dim ConnectOK As Boolean
Dim Phrase, nomFichier As String
Dim j As Byte
iMax = 0
DoCmd.OpenForm "frm_TablesAttachees", acNormal, , , , acWindowNormal
On Error Resume Next
 Set db = CurrentDb()
 For i = 0 To db.TableDefs.Count - 1
  Set Tbl = db.TableDefs(i)
  If (Left(Tbl.Name, 4) <> "Msys") And (Tbl.Attributes = dbAttachedTable) Then
   Message "Table : " & Tbl.Name & "..."
   Set rs = db.OpenRecordset(Tbl.Name)
   DoEvents
     err.Clear
     j = 0
     ConnectOK = False
     'Cherche le nom de la base à connecter
     nomFichier = ExtraitNomFichier(ExtraitNomDb(Tbl.Connect))
     If IsNull(DLookup("valeur", "tbl_parametre", "parametre='" & nomFichier & "'")) Then
        MsgBox "Attention, Problème de définition des paramètres pour la base " & nomFichier & ", Vérifier tbl_parametre et recommencez"
        Sclose
        DoCmd.Close acForm, "TablesAttachees"
        Exit Function
    End If
    'Cherche l'adresse de la base dans les parametres
     nomFichier = DLookup("valeur", "tbl_parametre", "parametre='" & nomFichier & "'") & nomFichier
     'Lie à cette base
     If TestExisteFichier(nomFichier) Then
        nomFichier = ";DATABASE=" & nomFichier & ";UID="""";PWD="""""
        Rafraichir_Liens Tbl.Name, nomFichier
        ConnectOK = True
     End If
     'Sinon recherche manuellement
     If Not ConnectOK Then
        Phrase = "La table " & Tbl.Name & " ne peut plus être liée à la base " & ExtraitNomDb(Tbl.Connect) & vbNewLine _
            & "La manipulation est stoppée, Vérifiez vos paramètres et recommencez..."
       MsgBox Phrase, , "Tables attachée en erreur"
       Sclose
        DoCmd.Close acForm, "frm_TablesAttachees"
        Exit Function
     End If
   End If
  rs.Close
 ' End If
 Next i
 Sclose
 DoCmd.Close acForm, "frm_TablesAttachees"
End Function

Private Sub Sclose()
 db.Close
 Set rs = Nothing
 Set Tbl = Nothing
 Set db = Nothing
End Sub

Private Sub Rafraichir_Liens(TableName As String, CheminConnu As String, Optional AncienChemin As String)  'Sub pour rétablir les liens des tables entre les 2 bases
Dim i2 As Long
On Error GoTo Err_Rafraichir_Liens
 If CheminConnu = "" Then
    chemin = OpenFile("Recherche de la base " & ExtraitNomFichier(ExtraitNomDb(AncienChemin)), , True)
    ConnectionGood(iMax - 1) = ";DATABASE=" & chemin & ";UID="""";PWD="""""
 Else
    chemin = CheminConnu
 End If
 
 For i2 = 0 To db.TableDefs.Count - 1
  Set Tbl = db.TableDefs(i2)
   If Tbl.Name = TableName Then
    If CheminConnu = "" Then
        Tbl.Connect = ";DATABASE=" & chemin & ";UID="""";PWD="""""
    Else
        Tbl.Connect = CheminConnu
    End If
    Tbl.RefreshLink
   End If
 Next i2
 Message "Lien de la table " & TableName & " réparé."
 Exit Sub
Err_Rafraichir_Liens:
 MsgBox "La Table " & Tbl.Name & " liée à votre base principale " & _
         ExtraitNomDb(chemin) & " ne peut pas être réparée.", vbCritical
 Message "La Table " & Tbl.Name & " -> " & ExtraitNomDb(AncienChemin) & " n'est pas plus attachée."
 err.Clear
End Sub
Private Sub Message(texte As String)
forms("frm_TablesAttachees").tbMessage = forms("frm_TablesAttachees").tbMessage & texte & vbNewLine
End Sub


Public Function TestExisteFichier(Path As String) As Boolean
 If dir(Path) = "" Then
     TestExisteFichier = False
 Else
     TestExisteFichier = True
 End If
End Function



Function ExtraitNomDb(strNomConnect As String) As String
Dim i As Long
i = InStr(11, strNomConnect, ";")
ExtraitNomDb = Mid(strNomConnect, 11, Len(strNomConnect) - i + 12)
End Function

'Renvoi le nom du répertoire de la base de données
Function fCurrentDBDir() As String

Dim strDBPath As String
Dim strDBFile As String

strDBPath = CurrentDb.Name
strDBFile = dir(strDBPath)
fCurrentDBDir = Left(strDBPath, Len(strDBPath) - Len(strDBFile))

End Function


Public Function OpenFile(Optional strTitle As Variant, _
                         Optional strInitialDir As Variant, _
                         Optional MultiSelect As Boolean = False) As String

If IsMissing(strTitle) Then
strTitle = "Ouvrir..."
End If

If IsMissing(strInitialDir) Then
    strInitialDir = CurDir
End If

OpenFile = ""
strFiltre = "Fichiers Access" & Chr$(0) & "*.mdb"

With Dialogue
    .lStructSize = Len(Dialogue)
    .lpstrFilter = strFiltre
    .lpstrFile = Space(254)
    .nMaxFile = 255
    .lpstrFileTitle = Space(254)
    .nMaxFileTitle = 255
    .lpstrInitialDir = strInitialDir
    .lpstrTitle = strTitle
  If MultiSelect = False Then
    .flags = OFN_FileMustExist + _
             OFN_HideReadOnly + _
             OFN_PathMustExist
  Else
    .flags = OFN_FileMustExist + _
             OFN_HideReadOnly + _
             OFN_PathMustExist + _
             OFN_AllowMultiSelect + _
             OFN_LongNames + _
             OFN_EXPLORER
  End If
End With

'RetVal = GetOpenFileName(Dialogue)

'If RetVal >= 1 Then
'    OpenFile = fMultiSelect(Dialogue.lpstrFile)
'Else
'    OpenFile = ""
'    Exit Function
'End If

End Function