Classe AccDB

Option Compare Database
Option Explicit

'-----------------------------------------------------------------------------------
'classes utilisee : clsAccDb (soit-même)
'                   clsAttachedTable
'-----------------------------------------------------------------------------------
'Cet object represente une Base-de-donnees Access, identifiee par son chemin complet.
'Ce chemin peut ne pas être valide, dans ce cas la propriete Exist retourne Faux.
'Le File peut ne pas être une base Access, dans ce cas la
'   propriete Version retourne "".
'Cette objet est utilise essentielement pour les bases des tables attachees.
'-----------------------------------------------------------------------------------

'infos sur les attaches (tables attachees et leur bases d'attaches
Public TableParent            As clsAttachedTable


'base access designees
Private clscolAttachedTables As New Collection
Private clsobjFile As New clsFile


Private infoAttachesInitalisees As Boolean

'prefixe de la propriete Connect
Const c_prefixeAttache = ";DATABASE="

Public Property Get FullPath() As String
    FullPath = clsobjFile.FullPath
End Property

Public Property Let FullPath(ByVal CheminBase As String)
    clsobjFile.Name = CheminBase
End Property

Public Property Get Exist() As Boolean
    Exist = clsobjFile.IsExist
End Property

Public Property Get Path() As String
    Path = clsobjFile.Path
End Property

Public Property Let Path(ByVal rep As String)
    clsobjFile.Path = Path

    'le Path a ete modifie donc le contenu des infos d'attaches sont faussees
    infoAttachesInitalisees = False

End Property

Public Property Get File() As String
    File = clsobjFile.Name

End Property

Public Property Let File(ByVal fic As String)

    clsobjFile.Name = fic
    'le Path a ete modifie donc le contenu des infos d'attaches sont faussees
    infoAttachesInitalisees = False

End Property

Public Property Get Version() As String

'retourne la version de la base access

Dim D As DataBase

    On Error Resume Next
    Set D = OpenDatabase(clsobjFile.FullPath, False, True)
    If Err = 0 Then
        Version = D.Version
    Else
        Version = ""
    End If
    D.Close
    Set D = Nothing
    On Error GoTo 0
End Property
Public Property Get DefaultAttachedDb() As clsAccDb

'Retourne le chemin complet de la base portant le même nom de File et se trouvant
'dans le Path de la base parent (ou de l'application en cours, si pas de base parent).
'Cette base peut ne pas Exister.

Dim bp  As New clsAccDb
Dim objf As New clsFile
    
    
    If TableParent Is Nothing Then
        objf.Name = CurrentDb.Name
    Else
        With TableParent.BaseDAttache
            objf.Name = .Path & .File
        End With
    End If

    bp.FullPath = objf.FullPath
    Set DefaultAttachedDb = bp

End Property

Public Property Get DB() As DataBase
    On Error Resume Next
    Set DB = OpenDatabase(clsobjFile.FullPath)
    If Err <> 0 Then MsgBox Err.Description
    On Error GoTo 0
End Property

Public Property Let DB(ByVal D As DataBase)

    clsobjFile.Name = D.Name
    'le Path a ete modifie donc le contenu des infos d'attaches sont faussees
    infoAttachesInitalisees = False

End Property
Public Function Create() As Boolean
    Create = True
End Function
Public Function Destroy() As Boolean
    Destroy = True
End Function

Public Function Compact(Optional messageSiErreur As Boolean, Optional Version As Integer) As Boolean

'Compacte la base ou une base d'attache, retourne Vrai si le compactage est reussie.
'Permet aussi de convertir une base-de-donnees en une autre version

Dim n        As Integer
Dim objf As New clsFile

    Compact = False

    '
    'Cree un fichier rempo
    With objf
        .Path = clsobjFile.Path
        .SetTemporyName f_NoCreate
    End With
    If Err <> 0 Then
        Exit Function
    End If
    
        
    '
    'compactage
    '
    DBEngine.CompactDatabase Trim(clsobjFile.FullPath), Trim(objf.FullPath), , Version
    If Err <> 0 Then
        Exit Function
    End If
    
    '
    'Supprime l'ancien fichier
    '
    clsobjFile.fDelete
    
    '
    ' Renomme le nouveau fichier comme l'ancien
    '
    objf.fRename clsobjFile.FullPath
    
    '
    ' A ce moment précis, F repointe sur un fichier existant.
    ' N'ayant pu me mettre d'accord avec Vincent quant à la necessite de supprimer ou non l'objet
    ' clsobjFile puis le recreer sur le fichier physique pointe par objf, le code ci apres est bien ;-)
    '
    Set objf = Nothing
    
    If Err = 0 Then
        Compact = True
    End If
End Function

Public Function Repair(Optional Silent As Boolean = False) As Boolean

'Repare la base ou une base attachee, retourne Vrai si la reparation est reussie.

    On Error Resume Next
    DBEngine.RepairDatabase clsobjFile.FullPath
    If Err = 0 Then
        Repair = True
    Else
        If Not Silent Then
            MsgBox clsobjFile.FullPath & "@@" & Err.Description, vbCritical, "Reparation"
        End If
        Repair = False
    End If

End Function

Public Property Get AttachedTables_Compte() As Long

    InitAttachesInf
    AttachedTables_Compte = clscolAttachedTables.Count

End Property
Public Property Get AttachedTables(ID) As clsAttachedTable

Dim index As Variant
    
    If IsNumeric(ID) Then
        index = ID + 1 'la collection commence à 1
    Else
        index = ID
    End If
    
    InitAttachesInf
    Set AttachedTables = clscolAttachedTables(index)

End Property

Public Sub InitAttachesInf(Optional force As Boolean)

Dim D      As DataBase       'base Access observee
Dim T      As TableDef       '
Dim ba      As clsAccDb    'object temporaire pour l'ajout et la lecture
Dim ta      As clsAttachedTable 'indexe pour le tableau des tables attachees
Dim chemin As String         'chemin de la base d'attache

'On Error GoTo Err_Rempli

If (Not infoAttachesInitalisees) Or force Then

    'on vide la collection
    Do Until clscolAttachedTables.Count = 0
        clscolAttachedTables.Remove 1
    Loop

    'on affecte la base
    Set D = OpenDatabase(clsobjFile.FullPath, False, True)

    'on recherche les tables attachees
    For Each T In D.TableDefs
        If (T.Attributes And dbAttachedTable) <> 0 Then
            
            'on recupère le chemin complet de la base attachee
            chemin = Mid$(T.Connect, Len(c_prefixeAttache) + 1)
            'on prepare l'objet TableAttachee à ajouter
            Set ta = New clsAttachedTable
            ta.NomTable = T.Name
            Set ta.BaseParent = Me
            'on defini l'objet BaseDAttache du nouvel objet TableAttachee
            Set ba = New clsAccDb
            ba.FullPath = chemin
            Set ba.TableParent = ta
            'on colle la DAttache à l'objet TableAttachee
            Set ta.BaseDAttache = ba
            Set ba = Nothing
            'ajout de la table à la collection des tables attachees
            clscolAttachedTables.Add ta, ta.NomTable
            Set ta = Nothing
            
        'fin de : If (t.Attributes And dbAttachedTable) <> 0 Then
        End If
    'Suivant de : For Each t In d.TableDefs
    Next T

    'on ferme la base
    D.Close

'fin de : If Not attachesInitalisees Then
End If

Fin_Rempli:
'-----------
infoAttachesInitalisees = True
Exit Sub

Err_Rempli:
'-----------
Resume Fin_Rempli

End Sub

Private Sub Class_Initialize()

clsobjFile.Name = CurrentDb.Name
infoAttachesInitalisees = False

End Sub

Public Function ManageAttach(Optional Quiet As Boolean = False, Optional RepRecherche As String, Optional BaseAChanger As String)

'Cette methode change les attcahes de toutes les bases attachees
'En option :
'RepRecherche :
'  Si specifie, les bases d'attaches sont recherchees uniqiement dans le
'  Path. Ne pas renseigne cet argument si vous desirer conserver les attaches vers un
'  Path du reseau dans le cas d'une application sur poste local.
'BaseAChanger :
'  Ne modifie que les bases d'attache de ce nom.
'
'Exemples :
'----------
'mabase.ManageAttach(,"-")
'refait toutes les attaches dans le même rep que la base mabase.

Dim T      As clsAttachedTable
Dim ok     As Boolean
Dim chemin As String
Dim of As New clsFile

InitAttachesInf
ok = True


For Each T In clscolAttachedTables
    With T.BaseDAttache
        'on regarde si la base correspond à celle qui doit être changee
        If (BaseAChanger = "") Or (BaseAChanger = .FullPath) Then
            'on determine la nouvelle base d'attache
            If RepRecherche = "" Then
                If .Exist Then
                    chemin = .FullPath
                    'l'attache ne sera pas effectuee car le chemin est le même
                Else
                    '
                    ' La base n'existe pas mais on va tenter de la prendre au même endroit que la base current
                    '
                    chemin = T.BaseParent.Path & "\" & .File
                End If
            Else
                chemin = RepRecherche & "\" & .File
                '
                'Verifie si le fichie rd'attache existe
                '
                With of
                    .Name = chemin
                    '
                    'Si fichier existe pas et que Quiet=False alors demande de retrouver le fichier
                    '
                    If Not .IsExist And Not Quiet Then
                        chemin = .fDlgOpen("Bases de données Access (*.mdb)|*.mdb|Tous les fichiers(*.*)|*.*", "*.mdb", "Veuillez localiser le fichier ", .Path, .Name)
                    End If
                End With
                Set of = Nothing
            End If
            T.ChangeAttache chemin
        End If
        ' verifie si l'attache est valide
        ' Peut ne pas l'etre car peut etre tentative d'utilsier le chemin de la currentdb
        '
        If Not .Exist Then
            ok = False
        End If
    End With
Next T

ManageAttach = ok

End Function

Classe clsAttachedTable

Option Compare Database
Option Explicit

'-----------------------------------------------------------------------------------
'classes utilisée : clsAccDb
'                   oTableAttachée (soit-même)
'-----------------------------------------------------------------------------------

Public BaseParent   As New clsAccDb
Public BaseDAttache As New clsAccDb
Public NomTable     As String

'préfixe de la propriété Connect
Const c_préfixeAttache = ";DATABASE="
Public Function Create() As Boolean
    Create = True
End Function
Public Function Destroy() As Boolean
    Destroy = True
End Function

Public Sub ChangeAttache(NouveauChemin As String, Optional NePasRafraîchir As Boolean)

'réattache la base d'attache sur une autre base valide ou non.
'si la base est la même, l'attache ne se fait pas.

Dim D As DataBase

With BaseDAttache
    If .FullPath <> NouveauChemin Then
        Set D = OpenDatabase(BaseParent.FullPath)
        D.TableDefs(NomTable).Connect = c_préfixeAttache & NouveauChemin
        If Not NePasRafraîchir Then
            D.TableDefs(NomTable).RefreshLink
        End If
        D.Close
        Set D = Nothing
        .FullPath = NouveauChemin
    End If
End With

End Sub