Discussion :

[Kittenland]

Bonjour,


J'avais besoin de récupérer dans un excel des données de mail, j'ai "écris" un petit script (un peu à l'arrache n'étant pas du tout formé à cela).

C'est fonctionnel, mais cela prend du temps et parfois cela bug, je pense que ca vient du code qui dit ouvrir et fermer excel à chaque écriture de mail.

Je n'ai pas réussit à faire qu'excel s'ouvre une fois, que tous les mails soient écrient et ensuite excel se ferme.


Voilà donc ma demande, comment arriver à faire ouvrir et fermer excel au début et à la fin

merci d'avance

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
   Dim MonOutlook As Outlook.Application
    Dim LeMail As Object
    Dim LesMails As Outlook.Selection
        Dim nbremail As String
     nbremail = "0"
 
    Set MonOutlook = Outlook.Application
 
    Set LesMails = MonOutlook.ActiveExplorer.Selection
 
    For Each LeMail In LesMails
        EcritDansExceloutING LeMail
          nbremail = nbremail + 1
    Next LeMail
 
    Set LesMails = Nothing
          MsgBox nbremail & " traités"
End Sub
 
 
 
 
Sub EcritDansExceloutING(Optional objCurrentMessage As Object)
 
 
 
Dim XlApp, XlClas
    'Création d'un Excel
    Set XlApp = CreateObject("Excel.Application")
    'Ouverture du classeur
    Set XlClas = XlApp.Workbooks.Open("D:\Suivi\SUIVI.xls")
    'Ecriture d'une valeur en A1 de Feuil1
 
 
 
  With XlClas.Worksheets("Mail")
Ligne = .Range("A65536").End(-4162).Row + 1
 
 
.Range("A" & Ligne).Value = "Courriel"
.Range("D" & Ligne).Value = objCurrentMessage.EntryID
.Range("E" & Ligne).Value = objCurrentMessage.CreationTime
 
 
 
If objCurrentMessage.Class = olMail Then
'pour les mails
.Range("G" & Ligne).Value = objCurrentMessage.Sender
 
 
 
.Range("H" & Ligne).Value = objCurrentMessage.To
'test pour savoir si c'est un mail de Bull
 
If objCurrentMessage.Sender = "aeh@bull" Then
 
.Range("P" & Ligne).Value = "Notification"
 
Else
 
If objCurrentMessage.Sender = "support@bl.com" Then
 
.Range("P" & Ligne).Value = "support "
 
Else
 
 
 
'pour couper message
 
Dim bodycoupe() As String
 
bodycoupe = Split(objCurrentMessage.Body, "De" & Chr(160))
 
 
bodycoupe(0) = Replace(bodycoupe(0), Chr(160), "")
  bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
  bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
    bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
       bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
        bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
         bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
          bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
        bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf, vbCrLf)
        bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf, vbCrLf)
        bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf, vbCrLf)
 
.Range("P" & Ligne).Value = bodycoupe(0)
 
 End If
 End If
 
 
 Else
   'pour les réunions
 
.Range("G" & Ligne).Value = "REUNION"
.Range("H" & Ligne).Value = "I"
.Range("P" & Ligne).Value = "Convocation"
 
  End If
 
 
 
.Range("L" & Ligne).Value = objCurrentMessage.ConversationTopic
 
 
 
 Dim pj
Dim lesPJ
lesPJ = ""
 
    For Each pj In objCurrentMessage.Attachments
       lesPJ = "    " & lesPJ & pj.FileName & "    "
    Next pj
 
.Range("Q" & Ligne).Value = lesPJ
 
 
End With
    'Sauvegarde des modifications et fermeture du classeur
    XlClas.Close True
    'On quitte Excel
 
        XlApp.Quit
        'On libère la mémoire des variables
    Set XlClas = Nothing
    Set XlApp = Nothing
 
 
 
End Sub

[Oliv-]

Bonjour,
Essaye comme cela

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
Dim XlApp, XlClas
 
Sub kittenland()
    Dim MonOutlook As Outlook.Application
    Dim LeMail As Object
    Dim LesMails As Outlook.Selection
    Dim nbremail As String
    nbremail = "0"
 
    Set MonOutlook = Outlook.Application
 
    Set LesMails = MonOutlook.ActiveExplorer.Selection
 
 
 
 
    'Création d'un Excel
    Set XlApp = CreateObject("Excel.Application")
    'pour voir EXCEL
    XlApp.Visible = True
    'Ouverture du classeur
    Set XlClas = XlApp.Workbooks.Open("D:\Suivi\SUIVI.xls")
 
 
    For Each LeMail In LesMails
        EcritDansExceloutING LeMail
        nbremail = nbremail + 1
    Next LeMail
 
    'Sauvegarde des modifications et fermeture du classeur
    XlClas.Close True
    'On quitte Excel
 
    XlApp.Quit
    'On libère la mémoire des variables
    Set XlClas = Nothing
    Set XlApp = Nothing
 
    Set LesMails = Nothing
    MsgBox nbremail & " traités"
End Sub
 
 
 
 
Sub EcritDansExceloutING(Optional objCurrentMessage As Object)
 
 
'Ecriture d'une valeur en A1 de Feuil1
 
 
 
    With XlClas.Worksheets("Mail")
        Ligne = .Range("A65536").End(-4162).Row + 1
 
 
        .Range("A" & Ligne).Value = "Courriel"
        .Range("D" & Ligne).Value = objCurrentMessage.EntryID
        .Range("E" & Ligne).Value = objCurrentMessage.CreationTime
 
 
 
        If objCurrentMessage.Class = olMail Then
            'pour les mails
            .Range("G" & Ligne).Value = objCurrentMessage.Sender
 
 
 
            .Range("H" & Ligne).Value = objCurrentMessage.To
            'test pour savoir si c'est un mail de Bull
 
            If objCurrentMessage.Sender = "aeh@bull" Then
 
                .Range("P" & Ligne).Value = "Notification"
 
            Else
 
                If objCurrentMessage.Sender = "support@bl.com" Then
 
                    .Range("P" & Ligne).Value = "support "
 
                Else
 
 
 
                    'pour couper message
 
                    Dim bodycoupe() As String
 
                    bodycoupe = Split(objCurrentMessage.Body, "De" & Chr(160))
 
 
                    bodycoupe(0) = Replace(bodycoupe(0), Chr(160), "")
                    bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
                    bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
                    bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
                    bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
                    bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
                    bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
                    bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf & vbCrLf, vbCrLf)
                    bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf & vbCrLf, vbCrLf)
                    bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf, vbCrLf)
                    bodycoupe(0) = Replace(bodycoupe(0), vbCrLf & vbCrLf, vbCrLf)
 
                    .Range("P" & Ligne).Value = bodycoupe(0)
 
                End If
            End If
 
 
        Else
            'pour les réunions
 
            .Range("G" & Ligne).Value = "REUNION"
            .Range("H" & Ligne).Value = "I"
            .Range("P" & Ligne).Value = "Convocation"
 
        End If
 
 
 
        .Range("L" & Ligne).Value = objCurrentMessage.ConversationTopic
 
 
 
        Dim pj
        Dim lesPJ
        lesPJ = ""
 
        For Each pj In objCurrentMessage.Attachments
            lesPJ = "    " & lesPJ & pj.Filename & "    "
        Next pj
 
        .Range("Q" & Ligne).Value = lesPJ
 
 
    End With
 
 
 
 
End Sub

[Kittenland]

Bonjour, merci pour l'aide

Le programme bloque à la ligne 53

With XlClas.Worksheets("Mail")


J'ai bien un onglet intitulé Mail

[Oliv-]

as tu bien

Code :

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

Dim XlApp, XlClas

en t^te de module avant toute sub ?

[Kittenland]

ca venait de là

encore désolé

merci pour l'aide ca marche