[VBA WORD+ACCESS] erreur d'éxécution '3343'

**tonnick** · 25/09/2007, 10h59

Bonjour, je travaille actuellement sur le fichier word normal.dot créé sous office 97.
Etant passé sous office 2007, celui-ci est devenu normal.dotm. Il est censé aller chercher des informations dans une base de données access. Jusque là tout va bien, mais dès que je lui met la version convertie 2007(.accdb) de cette base, il m'affiche:
erreur d'éxéction '3343' ("C:\....\base de donnée.accdb") non reconnu.

code vba de normal.dot:macro

Code :

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

1
2
3
4
5
6
7
8
9
10
11
 
Public Const conPath = "X:\01_dur_jour\COMMERCIAL\INFOCOM\INFOCOMDUR.accdb"
Global li$()
Global la$()
Global li2$()
Global la2$()
 
 
Sub Macroilaccess01()
UserForm1.Show                               <-erreur à ce niveau
End Sub

Code de la userform1:

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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
 
Private Sub CheckBox1_AfterUpdate()
    x = rempli2combo1
    Me.ComboBox1 = ""
    Me.ComboBox2 = ""
End Sub
 
 
Private Sub ComboBox1_Change()
    x = remplicombo2
    Me.ComboBox2 = ""
End Sub
 
 
Function remplicombo2()
    If ComboBox1 & "" = "" Then Exit Function
    Dim pp(0, 2)
    UserForm1.ComboBox2.List = pp()
    UserForm1.ComboBox2.RemoveItem 0
    Dim dbs As DAO.Database, rstp As Recordset
    Dim strSQL As String
    Set dbs = DBEngine.Workspaces(0).OpenDatabase(conPath)
    x = Me.ComboBox1.Column(1)
    y = IIf(Me.CheckBox1, -1, 0)
    strSQL = "SELECT * FROM Tpersonne WHERE (numsociete = " & x & ") AND (admin = " & y & " ) ;"
    Set rstp = dbs.OpenRecordset(strSQL, dbOpenSnapshot)
     Do Until rstp.EOF
        UserForm1.ComboBox2.AddItem rstp!nompersonne & ""
        UserForm1.ComboBox2.List(b, 1) = rstp!Typepersonne & ""
        UserForm1.ComboBox2.List(b, 2) = rstp!numpersonne
        rstp.MoveNext
        b = b + 1
    Loop
    rstp.Close
    dbs.Close
End Function
 
 
Private Sub CommandButton1_Click()
    numsoc = Me.ComboBox1.Column(1)
    numper = Me.ComboBox2.Column(2)
    ad = IIf(Me.CheckBox1, -1, 0)
    fax = IIf(Me.CheckBox2, -1, 0)
    telfax = IIf(Me.CheckBox3, -1, 0)
    x = okinfo(numsoc, numper, ad, fax, telfax)
    Me.Hide
End Sub
 
 
'contrôle+²
Function okinfo(numsoc, numper, ad, fax, telfax)
On Error GoTo err_okinfo
    z = numsoc
    If z = "" Then Exit Function
    Dim dbs As DAO.Database, rst As Recordset, rstp As Recordset
    Dim strSQL As String
    Set dbs = DBEngine.Workspaces(0).OpenDatabase(conPath)
    strSQL = "SELECT * FROM Tsociete " & "WHERE numsociete = " & z & " ;"
    Set rst = dbs.OpenRecordset(strSQL, dbOpenSnapshot)
    If ad = 0 Then
        s1 = rst!societe & ""
        s2 = rst!adresse1 & ""
        s3 = rst!adresse2 & IIf(rst!bp & "" <> "", " B.P: " & rst!bp, "") & ""
        s4 = IIf(rst!cp & "" <> "", rst!cp & " - ", "") & rst!ville & ""
    Else
        s1 = rst!adminsociete & ""
        s2 = rst!adminadresse1 & ""
        s3 = rst!adminadresse2 & IIf(rst!adminbp & "" <> "", " B.P: " & rst!adminbp, "") & ""
        s4 = IIf(rst!admincp & "" <> "", rst!admincp & " - ", "") & rst!adminville & ""
    End If
    x = numper
    strSQL = "SELECT * FROM Tpersonne WHERE numpersonne = " & x & " ;"
    Set rstp = dbs.OpenRecordset(strSQL, dbOpenSnapshot)
    p1 = "A l'attention de "
    p2 = IIf(rstp!nompersonne & "" <> "", rstp!Typepersonne & " " & rstp!nompersonne, "")
    p3 = rstp!telpersonne
    p4 = rstp!faxpersonne
    rstp.Close
    rst.Close
    dbs.Close
    Selection.Expand
    Selection.Delete
    If fax = 0 Then
        If telfax = 0 Then
            If s1 <> "" Then Selection.InsertAfter s1 & vbCrLf
            If p2 <> "" Then
            Selection.InsertAfter p1
            Selection.MoveRight
            Selection.InsertAfter p2 & vbCrLf
            Selection.Font.Bold = True
            Selection.MoveRight
            Selection.Font.Bold = False
            End If
            If s2 <> "" Then Selection.InsertAfter s2 & vbCrLf
            If s3 <> "" Then Selection.InsertAfter s3 & vbCrLf
            If s4 <> "" Then Selection.InsertAfter s4 & vbCrLf
        Else
            If s1 <> "" Then Selection.InsertAfter s1 & vbCrLf
            If p2 <> "" Then
            Selection.InsertAfter p1
            Selection.MoveRight
            Selection.InsertAfter p2 & vbCrLf
            Selection.Font.Bold = True
            Selection.MoveRight
            Selection.Font.Bold = False
            End If
            If s2 <> "" Then Selection.InsertAfter s2 & vbCrLf
            If s3 <> "" Then Selection.InsertAfter s3 & vbCrLf
            If s4 <> "" Then Selection.InsertAfter s4 & vbCrLf
            If s5 <> "" Then Selection.InsertAfter s5 & vbCrLf
            If p3 <> "" Then Selection.InsertAfter "Tel " & p3
            If p4 <> "" Then Selection.InsertAfter "  Fax " & p4
        End If
    Else
        If p2 <> "" Then Selection.InsertAfter "A : " & p2 & vbCrLf
        If s1 <> "" Then Selection.InsertAfter "Sté : " & s1 & vbCrLf
        If p3 <> "" Then Selection.InsertAfter "Fax " & p3
        Selection.Font.Size = 12
        Selection.Font.Position = 6
    End If
exit_okinfo:
    Exit Function
err_okinfo:
    MsgBox Erl & vbCrLf & Err.Number & vbCrLf & Err.Description
    Resume exit_okinfo
End Function
 
 
Private Sub CommandButton2_Click()
    Me.Hide
End Sub
 
 
Private Sub UserForm_Initialize()
x = rempli2array
x = rempli2combo1
End Sub
 
 
Function rempli2combo1()
    z = IIf(Me.CheckBox1, -1, 0)
    If z = 0 Then
        UserForm1.ComboBox1.List = li$()
    Else
        UserForm1.ComboBox1.List = la$()
    End If
End Function
 
 
Function rempli2array()
    Dim dbs As DAO.Database, rst As Recordset, rstp As Recordset
    Dim strSQL As String
    Set dbs = DBEngine.Workspaces(0).OpenDatabase(conPath)
    z = IIf(Me.CheckBox1, -1, 0)
    strSQL = "Rsociete"
    Set rst = dbs.OpenRecordset(strSQL)
    b = rst.RecordCount
    ReDim li$(b, 1)
    For a = 0 To b - 1
        li$(a, 0) = rst!societe & ""
        li$(a, 1) = rst!numsociete
        rst.MoveNext
    Next a
    strSQL = "Rsociete_admin"
    Set rst = dbs.OpenRecordset(strSQL)
    b = rst.RecordCount
    ReDim la$(b, 1)
    For a = 0 To b - 1
        la$(a, 0) = rst!adminsociete & ""
        la$(a, 1) = rst!numsociete
        rst.MoveNext
    Next a
    rst.Close
    dbs.Close
End Function

Merci d'avance

**Maxence HUBICHE** · 25/09/2007, 13h24

Je pense que tu n'as pas la bonne version de DAO de sélectionné dans la liste des références...
Microsoft Office 12.0 Access Database Engine Object Library
devrait plutôt faire l'affaire

**tonnick** · 25/09/2007, 13h44

Nikel, je te remercie grandement Maxence HUBICHE, pour ton efficacité, ta rapidité et ta gentillesse.

[VBA WORD+ACCESS] erreur d'éxécution '3343'

VBA

Discussions similaires

Partager

Partager