[XL-2010] Problemme de connexion a une base de donnée depuis excel en vba

Bonjour a vous tous
cela fait 2 jours que je tourne en rond sans trouver de solution a mon erreur
si quelqu'un aurait une idée
merci de votre aide

Je fais une connexion a une base données de puis Excel en vba
suivant le code suivant

avec BDD = "\\hihhstr003\data\CC\dat\GMAO\Test_BaseAccess.accdb", la connexion s'établis bien et pas d'erreur

avec BDD = "\\hihhstr003\data\CC\dat\GMAO\Gmao.accdb" plantage et message d'erreur Voir image

Pièce jointe 410629

Code:

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
 
Function Query(Req As String, Optional Head As Byte = 1) As Long
Dim Cnx As Object, Rst As Object
Dim T As Variant, Col_SQL As Integer, i As Long, j As Long
 
BDD = "\\hihhstr003\data\CC\dat\GMAO\Gmao.accdb"
'BDD = "\\hihhstr003\data\CC\dat\GMAO\Test_BaseAccess.accdb"
 
    On Error GoTo errhdlr
    Set Cnx = CreateObject("ADODB.Connection")
    Cnx.provider = "MSDASQL"
    Cnx.Open "DRIVER={Microsoft Access Driver (*.mdb, *.accdb)}; DBQ=" & BDD
 
    If Left(Req, 6) = "SELECT" Then
        Set Rst = CreateObject("ADODB.Recordset")
        Rst.Open Req, Cnx, 3
 
        Col_SQL = Rst.Fields.Count - 1
        If Head = 1 Then
            ReDim Rcd(Col_SQL, 0)
            For i = 0 To Col_SQL
                Rcd(i, 0) = Rst.Fields(i).Name
            Next i
        End If
 
        Query = Rst.RecordCount
        If Not Query = 0 Then
            If Head = 1 Then ReDim Preserve Rcd(Col_SQL, Query) _
            Else ReDim Rcd(Col_SQL, Query - 1)
            ReDim T(Col_SQL, Query - 1)
            Rst.MoveFirst
            T = Rst.GetRows
            For i = 0 To UBound(T, 1)
                For j = 0 To UBound(T, 2)
                    Rcd(i, j + Head) = IIf(IsNull(T(i, j)), "", T(i, j))
                Next j
            Next i
        End If
    Else
        Cnx.Execute Req
        Query = 0
    End If
 
    Cnx.Close
    Set Rst = Nothing
    Set Cnx = Nothing
    Exit Function
 
errhdlr:
    If Not Rst Is Nothing Then If Rst.State = 1 Then Rst.Close
    If Not Cnx Is Nothing Then If Cnx.State = 1 Then Cnx.Close
    Set Rst = Nothing
    Set Cnx = Nothing
    Query = -1
    MsgBox ("Code Erreur : " & Err.Number & vbCrLf & "Description : " & Err.Description)
End Function