Discussion :

[Steph38GRE]

bonjour à tous,
Je souhaite activer des références VBA d'une base access par le module d'une autre base.
Merci de bien vouloir m'aider

[Tofalu]

Bonjour

Je propose ce module :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
86
87
Option Compare Database
 
'Enumeration permettant de supprimer
'par fichier ou par nom de références
Enum ReferenceBy
    FileName
    refname
End Enum
 
Function remRef(oAcc As Access.Application, strValue As String, typeValue As ReferenceBy)
On Error GoTo err
Dim oref As Reference
Dim strName As String
 
    If typeValue = FileName Then
        'Cas d'une recherche par nom de fichier
        With oAcc
            For Each oref In .References
 
                If oref.FullPath = strValue Then
                    strName = oref.Name
                    Exit For
                End If
            Next
        End With
        If strName = "" Then err.Raise 9
    Else
        strName = strValue
    End If
    'Supprime la référence
    oAcc.References.Remove oAcc.References(strName)
    remRef = True
fin:
 
Exit Function
 
err:
    Select Case err.Number
        Case 9
            MsgBox "Référence non trouvée", vbCritical
        Case 57101
            MsgBox "Impossible de supprimer la référence par défaut"
        Case Else
            MsgBox err.Number & vbCrLf & err.Description, vbCritical
    End Select
 
    Resume fin
 
End Function
Function addRef(oAcc As Access.Application, strFilename As String) As Boolean
On Error GoTo err
    'Ajoute les références
    oAcc.References.AddFromFile (strFilename)
    addRef = True
fin:
    Exit Function
 
err:
    Select Case err.Number
        Case 32813
            MsgBox "Référence existante dans le projet spécifié", vbCritical
        Case 29060
            MsgBox "Le fichier de référence n'existe pas ou n'est pas valide", vbCritical
        Case Else
            MsgBox err.Number & vbcrl & err.Description, vbCritical
    End Select
 
    Resume fin
End Function
 
 
Sub test()
'Ouvre une nouvelle base
Dim oAcc As Access.Application
Set oAcc = New Access.Application
 
oAcc.OpenCurrentDatabase ("D:\BDtest.accdb")
If remRef(oAcc, "C:\Program Files\Microsoft Office\Office12\Excel.exe", ReferenceBy.FileName) Then _
    MsgBox "Référence supprimée"
If addRef(oAcc, "C:\Program Files\Microsoft Office\Office12\Excel.exe") Then _
    MsgBox "Référence ajoutée"
If remRef(oAcc, "excel", ReferenceBy.refname) Then _
    MsgBox "Référence supprimée"
 
oAcc.Quit
Set oAcc = Nothing
End Sub