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
| Function fgAttache() As String
'--------------------------------------------------------------------------------
' Procedure : pgAttache
' Author : Fabrice CONSTANS (MVP)
' Date : 18 / 07 / 2012
' Purpose : Procédure standard d'attachement des tables
' Vérifie l'attachement ou le refait
' Parametres: Utilise strlstTable qui contient les tables
' strFichierData qui contient le fichier des tables
' Return : chemin de la dorsale
'----------------------------------------------------------------------------------
'
On Error GoTo err_demarrage
Dim db As DAO.Database
Dim rst As DAO.Recordset ' pour le test d'attache
Dim lstTable() As String ' contient les tables
Dim i As Integer ' the Compteur
Dim tbl As DAO.TableDef
Dim strChemin As String
Dim eChemin As String
eChemin = "C"
' utilise le chemin de la table des paramètres
strChemin = CDropb.CheminPartage & strFichierData
' si le fichier Dorsal n'existe pas on le demande
If Not FichierExiste(strChemin) Then
MsgBox "La connexion à la base principale à échouée, " & vbCrLf & " Vous devez indiquer son nouvel emplacement.", vbInformation
strChemin = SelectionFichier01
Else
strChemin = strChemin
End If
' sauve le chemin dans la table des paramètres internes
CDropb.CheminPartage = fFichierExt(strChemin, eChemin)
' si user local n'est pas user courant
If CDropb.Occupe Then
MsgBox "La base est actuellement utilisée par : " & CDropb.UtilisateurConnecte & vbCrLf & "Faites une tentative ultérieurement.", vbExclamation + vbOKOnly
' libération de la classe
Set CDropb = Nothing
DoCmd.Quit 'quitte l'application
End If
' Création du fichier, réservation de l'application
CDropb.CreerFichier
' à partir de là on commence les procédures d'attachement sur la dorsale
lstTable = Split(strlstTable, ";") ' la liste des tables à traiter
Set db = CurrentDb
For i = 0 To UBound(lstTable) ' liste les tables et tente l'ouverture
Set rst = db.OpenRecordset(lstTable(i), dbOpenSnapshot)
rst.Close
Set rst = Nothing
Next
db.TableDefs.Refresh
If strChemin = "" Then
strChemin = db.TableDefs(lstTable(0)).Connect
strChemin = Right(strChemin, Len(strChemin) - InStr(1, strChemin, ";DATABASE=") - 9)
End If
fgAttache = fFichierExt(strChemin, eChemin)
Exit Function
err_demarrage:
If err.Number = 3078 Then ' ne trouve pas la table
Set tbl = db.CreateTableDef(lstTable(i))
tbl.Connect = "MS Access;PWD=" & strPassWordBD & ";DATABASE=" & strChemin 'Me.CheminBD '";DATABASE=" &
tbl.SourceTableName = lstTable(i)
db.TableDefs.Append tbl
db.TableDefs(tbl.Name).RefreshLink
Resume
End If
For Each tbl In db.TableDefs
If tbl.Attributes = dbAttachedTable Then
tbl.Connect = "MS Access;PWD=" & strPassWordBD & ";DATABASE=" & strChemin
db.TableDefs(tbl.Name).RefreshLink
End If
Next
Resume
End Function |
Partager