LIER DES TABLES PAR LE CODE

Bonjour Severine,

La fonction ci-dessous va te permettre d'attacher toutes
les tables d'une base "Source" dans une base "Cible".

Il y a un peu de GoTo (beurk ;-)) mais c'est une maquette.

De plus, il faudrait prévoir de répondre "Supprimer tous",
et éventuellement continuer si une erreur est rencontrée.

------------------------------------------
Option Compare Database
Option Explicit

Function AttacherToutesTables(strNomBdCible As String,
strNomBdSource As String) As Boolean
'Attacher toutes les tables d'une base de données dans
une autre
' Paramètres:
' strNomBdCible : Nom de la base de données dans
laquelle on créé les attaches
' strNomBdSource : Nom de la base de données
contenant les tables sources

Const cstTitreBoiteDialogue = "Création des Tables
Attachées"

Dim dBaseSource As Database
Dim dBaseCible As Database

Dim TblDefSource As TableDef
Dim TblDefCible As TableDef

Dim strTxtMsg As String

On Error Resume Next
AttacherToutesTables = False 'Signaler
traitement incomplet

Access.Application.SysCmd acSysCmdSetStatus, "Création
des tables attachées en cours..."

'Vérifier disponibilité Base source
If Dir(strNomBdSource) = "" Then
strTxtMsg = "Base Source '" & strNomBdSource & "'
introuvable."
GoTo AttacherToutesTables_Erreur
End If

Err.Number = 0
Set dBaseSource = DBEngine.Workspaces(0).OpenDatabase
(strNomBdSource)
If Err.Number <> 0 Then
strTxtMsg = "Impossible d'ouvrir Base Source '" &
strNomBdSource & "'." & vbCrLf & vbCrLf & Err.Description
GoTo AttacherToutesTables_Erreur
End If

'Vérifier disponibilité Base cible
If Dir(strNomBdCible) = "" Then
strTxtMsg = "Base Source '" & strNomBdCible & "'
introuvable."
GoTo AttacherToutesTables_Erreur
End If

Err.Number = 0
Set dBaseCible = DBEngine.Workspaces(0).OpenDatabase
(strNomBdCible)
If Err.Number <> 0 Then
strTxtMsg = "Impossible d'ouvrir Base Cible '" &
strNomBdCible & "'." & vbCrLf & vbCrLf & Err.Description
GoTo AttacherToutesTables_Erreur
End If

'Parcourir la liste des tables de la base Source et
créer attache dans base Cible
For Each TblDefSource In dBaseSource.TableDefs

Access.Application.SysCmd acSysCmdSetStatus, "Création
Table attachée '" & TblDefSource.Name & "'"

'On n'attache pas les tables systèmes, ni les tables
attachée non ODBC, ni les tables attachées ODBC
If (TblDefSource.Attributes And dbSystemObject) <> 0
Or _
(TblDefSource.Attributes And dbAttachedTable) <> 0
Or _
(TblDefSource.Attributes And dbAttachedODBC) <> 0
Then
GoTo AttacherToutesTables_TableSuivante
End If

Err.Number = 0
Set TblDefCible = dBaseCible.TableDefs
(TblDefSource.Name)

'Vérifier si table existe déjà
If Err.Number = 0 Then 'Table Existe

Select Case MsgBox("La table '" & TblDefSource.Name
& " existe déjà dans" & vbCrLf & _
"Base Cible '" & strNomBdCible & "'." &
vbCrLf & vbCrLf & _
"Supprimer la table existante?", _
vbCritical + vbYesNoCancel +
vbDefaultButton2, cstTitreBoiteDialogue)
Case vbYes
dBaseCible.TableDefs.Delete TblDefSource.Name
Case vbNo
GoTo AttacherToutesTables_TableSuivante
Case vbCancel
strTxtMsg = "Procédure interrompue par
l'utilisateur."
GoTo AttacherToutesTables_Erreur
End Select

End If

Err.Number = 0

Set TblDefCible = dBaseCible.CreateTableDef
(TblDefSource.Name)

If Err.Number <> 0 Then
strTxtMsg = "Impossible de créer la table '" &
TblDefSource.Name & "'" & vbCrLf & _
"dans la Base '" & strNomBdCible & "'."
& vbCrLf & vbCrLf & Err.Description
GoTo AttacherToutesTables_Erreur
End If

TblDefCible.Connect = ";DATABASE=" & strNomBdSource
TblDefCible.SourceTableName = TblDefSource.Name

dBaseCible.TableDefs.Append TblDefCible
If Err.Number <> 0 Then
strTxtMsg = "Impossible d'ajouter la table '" &
TblDefSource.Name & "' à la collection TableDefs" & vbCrLf
& _
"dans la Base '" & strNomBdCible & "'."
& vbCrLf & vbCrLf & Err.Description
GoTo AttacherToutesTables_Erreur
End If
AttacherToutesTables_TableSuivante:
Next TblDefSource


AttacherToutesTables = True

AttacherToutesTables_Fin:
On Error Resume Next
Set TblDefSource = Nothing
Set dBaseSource = Nothing
Set dBaseCible = Nothing

Access.Application.SysCmd acSysCmdClearStatus
Exit Function

AttacherToutesTables_Erreur:
MsgBox strTxtMsg, vbCritical + vbOKOnly,
cstTitreBoiteDialogue
GoTo AttacherToutesTables_Fin

End Function

Espérant que cela t'aidera.
Cordialement.

PS: Enlever blurg de l'adresse mail.