Ecrire dans classeur excel fermé depuis OutLook [Résolu]

francky74 · 27/09/2011, 10h20

Bonjour,

Je souhaite écrire des données dans un classeur Excel sans l'ouvrir. Ces données, je les récupère du dernier mail arrivé et je les mets dans des variables de type string.
Tout d'abord, est-il possible d'écrire dans Excel (fermé) depuis OL ?

Voici mon code :

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
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
 
Public Sub Application_NewMail()
 
Dim myOlApp As New Outlook.Application
Dim myNamespace As Outlook.NameSpace
'Dim myInbox As Outlook.Folder
'Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Dim strgText As String
Dim oMail As MailItem
Dim strgIncNum As String
Dim intLetterIncNum As Integer
Dim strgOpDate As String
Dim strgForGr As String
Dim strgUrg As String
Dim strgImp As String
Dim strgSub As String
Dim intLetterSub As Integer
Dim strgProg As String
Dim strgClient As String
Dim strgPos As String
Dim strgDueDate As String
Dim strgHTTP As String
Dim strgGP3 As String
Dim intLetterRank As Integer
 
Dim Cn As ADODB.Connection
Dim Fichier As String
Fichier = "C:\Home\ng10BEC\DataL2.xls"
Set Cn = New ADODB.Connection
 
 
 
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myNamespace.Folders("Dossiers d'archivage").Folders("L2")
Set myDestFolderGood = myNamespace.Folders("Dossiers d'archivage").Folders("L2").Folders("Good")
Set myDestFolderBad = myNamespace.Folders("Dossiers d'archivage").Folders("L2").Folders("Bad")
 
Dim PauseTime, Start
PauseTime = 0.5    ' Définit la durée.
Start = Timer    ' Définit l'heure de début.
Do While Timer < Start + PauseTime
    DoEvents    ' Donne le contrôle à d'autres processus.
Loop
 
Set myItem = myItems.GetLast
'Dim ItemSubject As myItem.Subject
 
If Mid(myItem, 1, 53) = "Service Desk : Assignment notification for incident (" Then
    strgText = myItem.Body
    'strgIncNum = Mid(strgText, 1, 16)
    'strgOpDate = Mid(strgText, 1, 10)
    'strgForGr = Mid(strgText, 1, 10)
    'strgUrg = Mid(strgText, 1, 8)
    'strgImp = Mid(strgText, 1, 7)
    'strgProg = Mid(strgText, 1, 9)
    'strgClient = Mid(strgText, 1, 7)
    'strgDueDate = Mid(strgText, 1, 9)
    'strgHTTP = Mid(strgText, 1, 4)
    'strgGP3 = Mid(strgText, 1, 5)
 
    intLetterRank = 1
 
Ret1:
 
    If Mid(strgText, intLetterRank, 16) <> "Incident Number:" Then
        intLetterRank = intLetterRank + 1
        GoTo Ret1
    Else
        intLetterIncNum = intLetterRank
        intLetterRank = intLetterRank + 16
Ret2:
        If Mid(strgText, intLetterRank, 1) = " " Then
            intLetterRank = intLetterRank + 1
            GoTo Ret2
        Else
            strgIncNum = Mid(strgText, intLetterRank, 7)
            intLetterRank = intLetterRank + 7
Ret3:
            If Mid(strgText, intLetterRank, 10) <> "Open Date:" Then
                intLetterRank = intLetterRank + 1
                GoTo Ret3
            Else
                intLetterOpDate = intLetterRank
                intLetterRank = intLetterRank + 10
Ret4:
                If Mid(strgText, intLetterRank, 1) = " " Then
                    intLetterRank = intLetterRank + 1
                    GoTo Ret4
                Else
                    strgOpDate = Mid(strgText, intLetterRank, 19)
                    intLetterRank = intLetterRank + 19
Ret5:
                    If Mid(strgText, intLetterRank, 10) <> "For Group:" Then
                        intLetterRank = intLetterRank + 1
                        GoTo Ret5
                    Else
                        intLetterRank = intLetterRank + 10
Ret6:
                        If Mid(strgText, intLetterRank, 1) = " " Then
                            intLetterRank = intLetterRank + 1
                            GoTo Ret6
                        Else
                            strgForGr = Mid(strgText, intLetterRank, 30)
                            intLetterRank = intLetterRank + 30
Ret7:
                            If Mid(strgText, intLetterRank, 8) <> "Urgency:" Then
                                intLetterRank = intLetterRank + 1
                                GoTo Ret7
                            Else
                                intLetterRank = intLetterRank + 8
Ret8:
                                If Mid(strgText, intLetterRank, 1) = " " Then
                                    intLetterRank = intLetterRank + 1
                                    GoTo Ret8
                                Else
                                    strgUrg = Mid(strgText, intLetterRank, 3)
                                    intLetterRank = intLetterRank + 3
Ret9:
                                    If Mid(strgText, intLetterRank, 7) <> "Impact:" Then
                                        intLetterRank = intLetterRank + 1
                                        GoTo Ret9
                                    Else
                                        intLetterRank = intLetterRank + 7
Ret10:
                                        If Mid(strgText, intLetterRank, 1) = " " Then
                                            intLetterRank = intLetterRank + 1
                                            GoTo Ret10
                                        Else
                                            strgImp = Mid(strgText, intLetterRank, 3)
                                            intLetterRank = intLetterRank + 3
Ret11:
                                            If Mid(strgText, intLetterRank, 9) <> "Program :" Then
                                                intLetterRank = intLetterRank + 1
                                                GoTo Ret11
                                            Else
                                            intLetterRank = intLetterRank + 9
Ret12:
                                                If Mid(strgText, intLetterRank, 1) = " " Then
                                                    intLetterRank = intLetterRank + 1
                                                    GoTo Ret12
                                                Else
                                                    strgProg = Mid(strgText, intLetterRank, 4)
                                                    intLetterRank = intLetterRank + 4
Ret13:
                                                    If Mid(strgText, intLetterRank, 8) <> "Subject:" Then
                                                        intLetterRank = intLetterRank + 1
                                                        GoTo Ret13
                                                    Else
                                                        intLetterRank = intLetterRank + 8
Ret14:
                                                        If Mid(strgText, intLetterRank, 1) = " " Then
                                                            intLetterRank = intLetterRank + 1
                                                            GoTo Ret14
                                                        Else
                                                            intLetterSub = intLetterRank
Ret15:
                                                            If Mid(strgText, intLetterRank, 7) <> "Client:" Then
                                                                intLetterRank = intLetterRank + 1
                                                                GoTo Ret15
                                                            Else
                                                                strgSub = Mid(strgText, intLetterSub, intLetterRank - 1 - intLetterSub)
                                                                intLetterRank = intLetterRank + 7
Ret17:
                                                                If Mid(strgText, intLetterRank, 1) = " " Then
                                                                    intLetterRank = intLetterRank + 1
                                                                    GoTo Ret17
                                                                Else
                                                                    intLetterClient = intLetterRank
Ret18:
                                                                    If Mid(strgText, intLetterRank, 9) <> "Position:" Then
                                                                        intLetterRank = intLetterRank + 1
                                                                        GoTo Ret18
                                                                    Else
                                                                        strgClient = Mid(strgText, intLetterClient, intLetterRank - intLetterClient - 1)
                                                                        intLetterRank = intLetterRank + 9
Ret19:
                                                                        If Mid(strgText, intLetterRank, 1) = " " Then
                                                                            intLetterRank = intLetterRank + 1
                                                                            GoTo Ret19
                                                                        Else
                                                                            strgPos = Mid(strgText, intLetterRank, 2)
                                                                            intLetterRank = intLetterRank + 3
Ret20:
                                                                            If Mid(strgText, intLetterRank, 9) <> "Due Date:" Then
                                                                                intLetterRank = intLetterRank + 1
                                                                                GoTo Ret20
                                                                            Else
                                                                                intLetterRank = intLetterRank + 9
Ret21:
                                                                                If Mid(strgText, intLetterRank, 1) = " " Then
                                                                                    intLetterRank = intLetterRank + 1
                                                                                    GoTo Ret21
                                                                                Else
                                                                                    strgDueDate = Mid(strgText, intLetterRank, 19)
                                                                                    intLetterRank = intLetterRank + 19 + 92
                                                                                    intLetterHTTP = intLetterRank
Ret22:
                                                                                    If Mid(strgText, intLetterRank, 3) = "GP3" Then
                                                                                        strgHTTP = Mid(strgText, intLetterHTTP, intLetterRank - intLetterHTTP - 4)
                                                                                    Else
                                                                                        intLetterRank = intLetterRank + 1
                                                                                        GoTo Ret22
                                                                                    End If
                                                                                End If
                                                                            End If
                                                                        End If
                                                                    End If
                                                                End If
                                                            End If
                                                        End If
                                                    End If
                                                End If
                                            End If
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If
End If
 
Select Case Mid(strgSub, 1, 4)
Case PDML, CATI
    myItem.Move myDestFolderBad
Case ESDC
    myItem.Move myDestFolderGood
Case Else
    myItem.Move myDestFolder
End Select
 
With Cn
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Data Source=" & Fichier & _
        ";Extended Properties=Excel 8.0;"
    .Open
End With
 
 
 
End Sub

J'ai l'erreur "Type défini par l'utilisateur non défini", sur la ligne suivante :

Code :

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

Dim Cn = New ADOB.Connection

Grandmerci à vous

PS : oui, j'ai regardé le tuto de silkyroad : http://silkyroad.developpez.com/VBA/...sFermes/#LIV-D

francky74 · 27/09/2011, 14h06

Bonjour,

J'ai réussi à envoyer des données résupérées d'un mail OL dans un classeur fermé Xl.
Voici le code secret ......

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
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
 
Public Sub Application_NewMail()
 
Dim myOlApp As New Outlook.Application
Dim myNamespace As Outlook.NameSpace
'Dim myInbox As Outlook.Folder
'Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Dim strgText As String
Dim oMail As MailItem
Dim strgIncNum As String
Dim intLetterIncNum As Integer
Dim strgOpDate As String
Dim strgForGr As String
Dim strgUrg As String
Dim strgImp As String
Dim strgSub As String
Dim intLetterSub As Integer
Dim strgProg As String
Dim strgClient As String
Dim strgPos As String
Dim strgDueDate As String
Dim strgHTTP As String
Dim intLetterRank As Integer
 
'Dim Cn As ADODB.Connection
Dim Fichier As String
Fichier = "C:\Home\ng10BEC\DataL2.xls"
'Set Cn = New ADODB.Connection
 
 
 
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myNamespace.Folders("Dossiers d'archivage").Folders("L2")
Set myDestFolderGood = myNamespace.Folders("Dossiers d'archivage").Folders("L2").Folders("Good")
Set myDestFolderBad = myNamespace.Folders("Dossiers d'archivage").Folders("L2").Folders("Bad")
 
Dim PauseTime, Start
PauseTime = 0.5    ' Définit la durée.
Start = Timer    ' Définit l'heure de début.
Do While Timer < Start + PauseTime
    DoEvents    ' Donne le contrôle à d'autres processus.
Loop
 
Set myItem = myItems.GetLast
'Dim ItemSubject As myItem.Subject
 
If Mid(myItem, 1, 53) = "Service Desk : Assignment notification for incident (" Then
    strgText = myItem.Body
 
    strgIncNum = ""
    strgOpDate = ""
    strgForGr = ""
    strgUrg = ""
    strgImp = ""
    strgProg = ""
    strgSub = ""
    strgClient = ""
    strgPos = ""
    strgDueDate = ""
    strgHTTP = ""
 
    intLetterSub = 0
    intLetterIncNum = 0
    intLetterRank = 1
 
Ret1:
 
    If Mid(strgText, intLetterRank, 16) <> "Incident Number:" Then
        intLetterRank = intLetterRank + 1
        GoTo Ret1
    Else
        intLetterIncNum = intLetterRank
        intLetterRank = intLetterRank + 16
Ret2:
        If Mid(strgText, intLetterRank, 1) = " " Then
            intLetterRank = intLetterRank + 1
            GoTo Ret2
        Else
            strgIncNum = Mid(strgText, intLetterRank, 7)
            intLetterRank = intLetterRank + 7
Ret3:
            If Mid(strgText, intLetterRank, 10) <> "Open Date:" Then
                intLetterRank = intLetterRank + 1
                GoTo Ret3
            Else
                intLetterOpDate = intLetterRank
                intLetterRank = intLetterRank + 10
Ret4:
                If Mid(strgText, intLetterRank, 1) = " " Then
                    intLetterRank = intLetterRank + 1
                    GoTo Ret4
                Else
                    strgOpDate = Mid(strgText, intLetterRank, 19)
                    intLetterRank = intLetterRank + 19
Ret5:
                    If Mid(strgText, intLetterRank, 10) <> "For Group:" Then
                        intLetterRank = intLetterRank + 1
                        GoTo Ret5
                    Else
                        intLetterRank = intLetterRank + 10
Ret6:
                        If Mid(strgText, intLetterRank, 1) = " " Then
                            intLetterRank = intLetterRank + 1
                            GoTo Ret6
                        Else
                            strgForGr = Mid(strgText, intLetterRank, 30)
                            intLetterRank = intLetterRank + 30
Ret7:
                            If Mid(strgText, intLetterRank, 8) <> "Urgency:" Then
                                intLetterRank = intLetterRank + 1
                                GoTo Ret7
                            Else
                                intLetterRank = intLetterRank + 8
Ret8:
                                If Mid(strgText, intLetterRank, 1) = " " Then
                                    intLetterRank = intLetterRank + 1
                                    GoTo Ret8
                                Else
                                    strgUrg = Mid(strgText, intLetterRank, 3)
                                    intLetterRank = intLetterRank + 3
Ret9:
                                    If Mid(strgText, intLetterRank, 7) <> "Impact:" Then
                                        intLetterRank = intLetterRank + 1
                                        GoTo Ret9
                                    Else
                                        intLetterRank = intLetterRank + 7
Ret10:
                                        If Mid(strgText, intLetterRank, 1) = " " Then
                                            intLetterRank = intLetterRank + 1
                                            GoTo Ret10
                                        Else
                                            strgImp = Mid(strgText, intLetterRank, 3)
                                            intLetterRank = intLetterRank + 3
Ret11:
                                            If Mid(strgText, intLetterRank, 9) <> "Program :" Then
                                                intLetterRank = intLetterRank + 1
                                                GoTo Ret11
                                            Else
                                            intLetterRank = intLetterRank + 9
Ret12:
                                                If Mid(strgText, intLetterRank, 1) = " " Then
                                                    intLetterRank = intLetterRank + 1
                                                    GoTo Ret12
                                                Else
                                                    strgProg = Mid(strgText, intLetterRank, 4)
                                                    intLetterRank = intLetterRank + 4
Ret13:
                                                    If Mid(strgText, intLetterRank, 8) <> "Subject:" Then
                                                        intLetterRank = intLetterRank + 1
                                                        GoTo Ret13
                                                    Else
                                                        intLetterRank = intLetterRank + 8
Ret14:
                                                        If Mid(strgText, intLetterRank, 1) = " " Then
                                                            intLetterRank = intLetterRank + 1
                                                            GoTo Ret14
                                                        Else
                                                            intLetterSub = intLetterRank
Ret15:
                                                            If Mid(strgText, intLetterRank, 7) <> "Client:" Then
                                                                intLetterRank = intLetterRank + 1
                                                                GoTo Ret15
                                                            Else
                                                                strgSub = Mid(strgText, intLetterSub, intLetterRank - 1 - intLetterSub)
                                                                intLetterRank = intLetterRank + 7
Ret17:
                                                                If Mid(strgText, intLetterRank, 1) = " " Then
                                                                    intLetterRank = intLetterRank + 1
                                                                    GoTo Ret17
                                                                Else
                                                                    intLetterClient = intLetterRank
Ret18:
                                                                    If Mid(strgText, intLetterRank, 9) <> "Position:" Then
                                                                        intLetterRank = intLetterRank + 1
                                                                        GoTo Ret18
                                                                    Else
                                                                        strgClient = Mid(strgText, intLetterClient, intLetterRank - intLetterClient - 2)
                                                                        intLetterRank = intLetterRank + 9
Ret19:
                                                                        If Mid(strgText, intLetterRank, 1) = " " Then
                                                                            intLetterRank = intLetterRank + 1
                                                                            GoTo Ret19
                                                                        Else
                                                                            strgPos = Mid(strgText, intLetterRank, 2)
                                                                            intLetterRank = intLetterRank + 3
Ret20:
                                                                            If Mid(strgText, intLetterRank, 9) <> "Due Date:" Then
                                                                                intLetterRank = intLetterRank + 1
                                                                                GoTo Ret20
                                                                            Else
                                                                                intLetterRank = intLetterRank + 9
Ret21:
                                                                                If Mid(strgText, intLetterRank, 1) = " " Then
                                                                                    intLetterRank = intLetterRank + 1
                                                                                    GoTo Ret21
                                                                                Else
                                                                                    strgDueDate = Mid(strgText, intLetterRank, 19)
                                                                                    intLetterRank = intLetterRank + 19 + 92
                                                                                    intLetterHTTP = intLetterRank
Ret22:
                                                                                    If Mid(strgText, intLetterRank, 3) = "GP3" Then
                                                                                        strgHTTP = Mid(strgText, intLetterHTTP, intLetterRank - intLetterHTTP - 4)
                                                                                    Else
                                                                                        intLetterRank = intLetterRank + 1
                                                                                        GoTo Ret22
                                                                                    End If
                                                                                End If
                                                                            End If
                                                                        End If
                                                                    End If
                                                                End If
                                                            End If
                                                        End If
                                                    End If
                                                End If
                                            End If
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If
End If
 
Select Case Mid(strgSub, 1, 4)
Case "PDML", "CATI", "PRIM", "DMUT", "EPD-", "ECDB", "MDMR", "OPTE", "COLI", "SPRI", "VPM-"
    myItem.Move myDestFolderBad
    myItem.UnRead = False
    Set AppXl = CreateObject("Excel.Application")
    Set Wb = AppXl.Workbooks.Open("C:\Home\ng10BEC\DataL2.xls")
    'AppXl.Visible = True
 
    intX = 2
    While Wb.Sheets("Bad").Cells(intX, "A") <> ""
        intX = intX + 1
    Wend
 
    Wb.Sheets("Bad").Cells(intX, "A") = strgIncNum
    Wb.Sheets("Bad").Cells(intX, "B") = strgOpDate
    Wb.Sheets("Bad").Cells(intX, "C") = strgForGr
    Wb.Sheets("Bad").Cells(intX, "D") = strgUrg
    Wb.Sheets("Bad").Cells(intX, "E") = strgImp
    Wb.Sheets("Bad").Cells(intX, "F") = strgProg
    Wb.Sheets("Bad").Cells(intX, "G") = strgSub
    Wb.Sheets("Bad").Cells(intX, "H") = strgClient
    Wb.Sheets("Bad").Cells(intX, "I") = strgPos
    Wb.Sheets("Bad").Cells(intX, "J") = strgDueDate
    Wb.Sheets("Bad").Cells(intX, "K") = strgHTTP
 
Case "ESDC", "CIRC", "OTHE"
    myItem.Move myDestFolderGood
 
    Set AppXl = CreateObject("Excel.Application")
    Set Wb = AppXl.Workbooks.Open("C:\Home\ng10BEC\DataL2.xls")
    'AppXl.Visible = True
 
    intX = 2
    While Wb.Sheets("Good").Cells(intX, "A") <> ""
        intX = intX + 1
    Wend
 
    Wb.Sheets("Good").Cells(intX, "A") = strgIncNum
 
    Wb.Sheets("Bad").Cells(intX, "A") = strgIncNum
    Wb.Sheets("Bad").Cells(intX, "B") = strgOpDate
    Wb.Sheets("Bad").Cells(intX, "C") = strgForGr
    Wb.Sheets("Bad").Cells(intX, "D") = strgUrg
    Wb.Sheets("Bad").Cells(intX, "E") = strgImp
    Wb.Sheets("Bad").Cells(intX, "F") = strgProg
    Wb.Sheets("Bad").Cells(intX, "G") = strgSub
    Wb.Sheets("Bad").Cells(intX, "H") = strgClient
    Wb.Sheets("Bad").Cells(intX, "I") = strgPos
    Wb.Sheets("Bad").Cells(intX, "J") = strgDueDate
    Wb.Sheets("Bad").Cells(intX, "K") = strgHTTP
 
Case Else
    myItem.Move myDestFolder
End Select
 
Wb.Save
Wb.Close
Set Wb = Nothing
AppXl.Quit
Set AppXl = Nothing
 
 
'With Cn
    '.Provider = "Microsoft.Jet.OLEDB.4.0"
    '.ConnectionString = "Data Source=" & Fichier & ";Extended Properties=Excel 8.0;"
    '.Open
'End With
 
 
 
End Sub

Ca vaut bien un vote de votre part ca non ?

Outils de la discussion
Afficher une version imprimable Envoyer un lien vers cette page par email