Extraire des mails Outlook vers Excel

**secu_res_123** · 12/03/2015, 22h38

Bonsoir tout le monde,

Je suis débutant sur VBA et j'ai pour mission de développer un programme VBA qui permet d'extraire des mails Outlook vers Excel.
Les mails se présentent comme suit :

Type;Date;nb_ventes;nb_achats
ao;02/02/2015;12365;45698
co;03/02/2015;12216;4598

Je suis arrivé dans un 1er temps à afficher ces données mais le problème est que je ne sais pas comment faire pour obliger ma code à revenir à la ligne, par exemple, dès qu'il arrive à "nb_achats" ou 45698 ....
Aussi et après quelques tentatives, l'exécution de mon programme génére l'erreur suivante : "Erreur d'exécution 404 objet requis" et je ne sais toujours pas comment y remédier.

Si quelqu'un veut bien me sauver et me venir en aide, je lui serai reconnaissant

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
 
Option Explicit
 
Public CHR_SUP_A As String
Public CHR_SUP_B As String
Public CHR_SUP_C As String
 
Const NOM_FICHIER = "Classeur1"
Const EXT_FICHIER = ".xlsx"
Const REP_FICHIER = "C:\Users\Desktop\Classeur1.xlsx"
Const ADR_MAIL = "xxxx@yyyy.com"
Const DOSSIER_PERSONNEL = "Boîte aux lettres"
Const DOSSIER_RECEPTION = "Boîte de réception"
Const NOM_DOSSIER = "test"
 
Function Creation_Repertoire(cheminrepertoire As String)
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists(cheminrepertoire) = False Then
   fs.CreateFolder (cheminrepertoire)
   Creation_Repertoire = True
Else
   Creation_Repertoire = False
End If
End Function
Function ExistFile(strpath As String) As Boolean
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
ExistFile = fs.FileExists(strpath)
End Function
Function Fic_ouvert(fic_nom As String)
     Dim wb As Workbook
     Fic_ouvert = True
    On Error GoTo fin
    Set wb = Workbooks(fic_nom)
    Set wb = Nothing
    Exit Function
fin:
    Fic_ouvert = False
    On Error GoTo 0
End Function
Function SupprCar(msg As String) As String
Dim sc_supprcar1 As String, sc_supprcar2 As String
sc_supprcar1 = Replace(msg, CHR_SUP_A, "")
sc_supprcar2 = Replace(sc_supprcar1, CHR_SUP_B, " ")
SupprCar = Replace(sc_supprcar2, CHR_SUP_C, "")
 
End Function
 
Sub ConnexionOutlook()
 
Dim co_outlookapp As Object
Dim co_olnomdomaine As Object
Dim co_oldossier As Object
Dim co_olmailitem As Object
Dim co_cheminfichier As String
Dim co_flgoutlook As Boolean
Dim co_flgfic As Boolean
Dim co_xlbook As Workbook
Dim iRow As Integer
Dim i As Long, m As Long
Dim j As Long
Dim vText As Variant
Dim bXStarted As Boolean
Dim tabLignes() As Long, tmp As Long
Dim Debut As Byte
Dim Cell As Range
Dim tmpStr() As String
co_flgfic = True
co_flgoutlook = False
 
co_cheminfichier = ""
 
Set co_outlookapp = CreateObject("Outlook.Application")
 
If co_outlookapp.Explorers.Count = 0 Then
    co_flgoutlook = True
End If
Creation_Repertoire (REP_FICHIER)
co_cheminfichier = REP_FICHIER & "\" & NOM_FICHIER & EXT_FICHIER
If ExistFile(co_cheminfichier) Then
       If Fic_ouvert(co_cheminfichier) = False Then
         Set co_xlbook = Workbooks.Open(co_cheminfichier)
    Else
        MsgBox "Le fichier Excel est déjà ouvert.", vbOKOnly + vbInformation, _
        "Tentative d'ouverture du fichier Excel"
        co_flgfic = False
    End If
Else
        Set co_xlbook = Workbooks.Add
        FormatFicExcel co_xlbook
        co_xlbook.SaveAs co_cheminfichier
End If
If co_flgfic Then
    Set co_olnomdomaine = co_outlookapp.GetNamespace("MAPI")
    Set co_oldossier = co_olnomdomaine.Folders(DOSSIER_PERSONNEL).Folders(DOSSIER_RECEPTION)
    Set co_oldossier = co_oldossier.Folders(NOM_DOSSIER)
 
    For Each co_olmailitem In co_oldossier.Items
        If Trim(co_olmailitem.SenderEmailAddress) = ADR_MAIL Then
            For iRow = 1 To co_oldossier.Items.Count
                   vText = Split(CStr(co_oldossier.Items.item(iRow).Body), ";")
                          For j = 0 To UBound(vText)
                            co_xlbook.Sheets("TEST").Cells(iRow, j + 2) = vText(j)
                             For Each Cell In Range("A1:I" & Range("I65536").End(xlUp).Row)
                                Debut = InStr(1, vText, " " & StrReverse(Split(StrReverse(vText.Text), Chr(10))))
                                If Not Debut = 0 Then
                                  Cell = Left(Cell, Debut) & Chr(10) & Right(Cell, Len(Cell) - Debut)
                                End If
                                tmpStr = Split(vText.Text, Chr(10))
                                ReDim tabLignes(1 To UBound(tmpStr) + 1, 1 To 2)
 
                                For i = LBound(tmpStr) To UBound(tmpStr)
                                        tmp = 0
                                            For m = LBound(tmpStr) To i - 1
                                                tmp = tmp + Len(tmpStr(m))
                                            Next m
                                        tabLignes(i + 1, 1) = tmp + 1 + i
                                        tabLignes(i + 1, 2) = Len(tmpStr(i))
                                Next i
                                 Application.ScreenUpdating = True
                              Next Cell
                         Next j
 
                Next iRow
        End If
    Next co_olmailitem
 
    co_xlbook.Save
    co_xlbook.Close
 
End If
 If co_flgoutlook Then
    co_outlookapp.Quit
End If
Set co_oldossier = Nothing
Set co_olnomdomaine = Nothing
Set co_olmailitem = Nothing
Set co_outlookapp = Nothing
 
End Sub
Public Function FormatFicExcel(ff_classeur As Workbook)
 
ff_classeur.Worksheets("Feuil1").Activate
ff_classeur.Worksheets("Feuil1").Name = "TEST"
 
ff_classeur.Worksheets("TEST").Cells(1, 1) = "Type"
ff_classeur.Worksheets("TEST").Cells(2, 1) = "ao"
ff_classeur.Worksheets("TEST").Cells(3, 1) = "co"
ff_classeur.Worksheets("TEST").Cells(1, 2) = "DATE"
ff_classeur.Worksheets("TEST").Cells(1, 3) = "nb_ventes"
ff_classeur.Worksheets("TEST").Cells(1, 4) = "nb_achats"
ff_classeur.Worksheets("TEST").Range("A1:D1").Select
 
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
With Selection.Font
    .Bold = True
    .Name = "Cambria"
    .Size = 10
End With
 
End Function
 
Function ReplaceStr(rs_strch As String) As String
Dim rs_replacestr1 As String
 
rs_replacestr1 = Replace(rs_strch, CAR_SUP_A, "")
 
End Function

**Oliv-** · 13/03/2015, 09h49

Bonjour,
Ton code me semble bien complexe ! Il me semble qu'il y a des boucles qui ne servent à rien.
si j'ai bien compris tu veux parcourir tous les Emails du dossier NOM_DOSSIER
et si l'expéditeur = ADR_MAIL
tu insères dans une feuille Excel le BODY du mail avec une colonne à chaque fois que tu rencontres ;

**secu_res_123** · 13/03/2015, 11h12

Bonjour Oliv,

Je tiens tout d'abord à te remercier pour ton retour et tu as tout à fait bien compris ma problèmatique :
je souhaite parcourir les emails du dossier NOM_DOSSIER et qui sont expédier par ADR_MAIL. Ensuite, je voudrais insèrer le BODY du mail dans une feuille Excel avec une colonne à chaque fois que je rencontre un ";".

**Oliv-** · 13/03/2015, 11h56

essaye avec 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
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
 
Option Explicit
 
Public CHR_SUP_A As String
Public CHR_SUP_B As String
Public CHR_SUP_C As String
 
Const NOM_FICHIER = "Classeur1"
Const EXT_FICHIER = ".xlsx"
Const REP_FICHIER = "C:\Users\Desktop"
Const ADR_MAIL = "xxxx@yyyy.com"
Const DOSSIER_PERSONNEL = "Boîte aux lettres"
Const DOSSIER_RECEPTION = "Boîte de réception"
Const NOM_DOSSIER = "test"
 
Function Creation_Repertoire(cheminrepertoire As String)
'A CORRIGER !!!
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FolderExists(cheminrepertoire) = False Then
        fs.CreateFolder (cheminrepertoire)
        Creation_Repertoire = True
    Else
        Creation_Repertoire = False
    End If
End Function
Function ExistFile(strpath As String) As Boolean
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    ExistFile = fs.FileExists(strpath)
End Function
Function Fic_ouvert(fic_nom As String)
    Dim wb As Workbook
    Fic_ouvert = True
    On Error GoTo fin
    Set wb = Workbooks(fic_nom)
    Set wb = Nothing
    Exit Function
fin:
    Fic_ouvert = False
    On Error GoTo 0
End Function
Function SupprCar(msg As String) As String
    Dim sc_supprcar1 As String, sc_supprcar2 As String
    sc_supprcar1 = Replace(msg, CHR_SUP_A, "")
    sc_supprcar2 = Replace(sc_supprcar1, CHR_SUP_B, " ")
    SupprCar = Replace(sc_supprcar2, CHR_SUP_C, "")
 
End Function
 
Sub ConnexionOutlook()
 
    Const olMail = 43
 
 
    Dim co_outlookapp As Object
    Dim co_olnomdomaine As Object
    Dim co_oldossier As Object
    Dim co_olmailitem As Object
    Dim co_cheminfichier As String
    Dim co_flgoutlook As Boolean
    Dim co_flgfic As Boolean
    Dim co_xlbook As Workbook
    Dim iRow As Integer
    Dim i As Long, m As Long
    Dim j As Long
    Dim vText As Variant
    Dim bXStarted As Boolean
    Dim tabLignes() As Long, tmp As Long
    Dim Debut As Byte
    Dim Cell As Range
    Dim tmpStr() As String
    co_flgfic = True
    co_flgoutlook = False
 
    co_cheminfichier = ""
 
    Set co_outlookapp = CreateObject("Outlook.Application")
 
    If co_outlookapp.Explorers.Count = 0 Then
        co_flgoutlook = True
    End If
    Creation_Repertoire (REP_FICHIER)
    co_cheminfichier = REP_FICHIER & "\" & NOM_FICHIER & EXT_FICHIER
    If ExistFile(co_cheminfichier) Then
        If Fic_ouvert(co_cheminfichier) = False Then
            Set co_xlbook = Workbooks.Open(co_cheminfichier)
        Else
            MsgBox "Le fichier Excel est déjà ouvert.", vbOKOnly + vbInformation, _
                   "Tentative d'ouverture du fichier Excel"
            co_flgfic = False
        End If
    Else
        Set co_xlbook = Workbooks.Add
        FormatFicExcel co_xlbook
        co_xlbook.SaveAs co_cheminfichier
    End If
    If co_flgfic Then
        Set co_olnomdomaine = co_outlookapp.GetNamespace("MAPI")
        ' si tu veux parcourir la boite de réception courante
        Set co_oldossier = co_olnomdomaine.GetDefaultFolder(6)
        'Set co_oldossier = co_olnomdomaine.Folders(DOSSIER_PERSONNEL).Folders(DOSSIER_RECEPTION)
        Set co_oldossier = co_oldossier.Folders("a traiter")    'NOM_DOSSIER)
        iRow = 2
        For Each co_olmailitem In co_oldossier.Items
            If co_olmailitem.class = olMail Then
 
                If Trim(co_olmailitem.SenderEmailAddress) = ADR_MAIL Then
                    vText = Split(CStr(co_olmailitem.Body), ";")
                    For j = 0 To UBound(vText)
                        co_xlbook.Sheets("TEST").Cells(iRow, j + 2) = vText(j)
 
                        ' ca je sais pas ce que cela fait car je n'ai pas d'exemple de mail
                        '                            Debut = InStr(1, vText, " " & StrReverse(Split(StrReverse(vText.Text), Chr(10))))
                        '                            If Not Debut = 0 Then
                        '                                Cell = Left(Cell, Debut) & Chr(10) & Right(Cell, Len(Cell) - Debut)
                        '                            End If
                        '                            tmpStr = Split(vText.Text, Chr(10))
                        '                            ReDim tabLignes(1 To UBound(tmpStr) + 1, 1 To 2)
                        '
                        '                            For i = LBound(tmpStr) To UBound(tmpStr)
                        '                                tmp = 0
                        '                                For m = LBound(tmpStr) To i - 1
                        '                                    tmp = tmp + Len(tmpStr(m))
                        '                                Next m
                        '                                tabLignes(i + 1, 1) = tmp + 1 + i
                        '                                tabLignes(i + 1, 2) = Len(tmpStr(i))
                        '                            Next i
                        '                            Application.ScreenUpdating = True
 
                    Next j
 
                    iRow = iRow + 1
                End If
 
            End If
        Next co_olmailitem
 
        co_xlbook.Save
        co_xlbook.Close
 
    End If
    If co_flgoutlook Then
        co_outlookapp.Quit
    End If
    Set co_oldossier = Nothing
    Set co_olnomdomaine = Nothing
    Set co_olmailitem = Nothing
    Set co_outlookapp = Nothing
 
End Sub
Public Function FormatFicExcel(ff_classeur As Workbook)
 
    ff_classeur.Worksheets("Feuil1").Activate
    ff_classeur.Worksheets("Feuil1").Name = "TEST"
 
    ff_classeur.Worksheets("TEST").Cells(1, 1) = "Type"
    ff_classeur.Worksheets("TEST").Cells(2, 1) = "ao"
    ff_classeur.Worksheets("TEST").Cells(3, 1) = "co"
    ff_classeur.Worksheets("TEST").Cells(1, 2) = "DATE"
    ff_classeur.Worksheets("TEST").Cells(1, 3) = "nb_ventes"
    ff_classeur.Worksheets("TEST").Cells(1, 4) = "nb_achats"
    ff_classeur.Worksheets("TEST").Range("A1:D1").Select
 
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    With Selection.Font
        .Bold = True
        .Name = "Cambria"
        .Size = 10
    End With
 
End Function
 
Function ReplaceStr(rs_strch As String) As String
    Dim rs_replacestr1 As String
 
    rs_replacestr1 = Replace(rs_strch, CAR_SUP_A, "")
 
End Function

**secu_res_123** · 13/03/2015, 15h17

J'ai exécuté ce code, en prenant compte de tes remarques mais ça bogue sur la ligne suivante : [Erreur d'exécution '9' : L'indice n'appartient pas à la sélection]

Code :

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

co_xlbook.Sheets("TEST").Cells(iRow, j + 2) = vText(j)

**Oliv-** · 13/03/2015, 21h27

il faudrait que tu publis le code modifié que tu utilises + si possible le body d'Un Email type.

**secu_res_123** · 13/03/2015, 21h43

Le Body du mail se présente comme suit :

Type;Date;nb_ventes;nb_achats
ao;02/02/2015;12365;45698
co;03/02/2015;12216;4598

Au moment où tu commences à exécuter le code, pas à pas, et pour quelques valeurs de "j", t'as vText(j)="nb_achatsao" ou vText(j)="45698co" alors qu'il doit normalement afficher "ao" et "co" sur des lignes différentes. Too complicated

Voici le code : [et je te remercie énormément pour ton aide]

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
 
Option Explicit
 
Public CHR_SUP_A As String
Public CHR_SUP_B As String
Public CHR_SUP_C As String
 
Const NOM_FICHIER = "Classeur1"
Const EXT_FICHIER = ".xlsx"
Const REP_FICHIER = "C:\Users\Desktop\Classeur1.xlsx"
Const ADR_MAIL = "xxxx@yyyy.com"
Const DOSSIER_PERSONNEL = "Boîte aux lettres"
Const DOSSIER_RECEPTION = "Boîte de réception"
Const NOM_DOSSIER = "test"
 
Function Creation_Repertoire(cheminrepertoire As String)
 
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists(cheminrepertoire) = False Then
   fs.CreateFolder (cheminrepertoire)
   Creation_Repertoire = True
Else
   Creation_Repertoire = False
End If
End Function
Function ExistFile(strpath As String) As Boolean
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
ExistFile = fs.FileExists(strpath)
End Function
Function Fic_ouvert(fic_nom As String)
     Dim wb As Workbook
     Fic_ouvert = True
    On Error GoTo fin
    Set wb = Workbooks(fic_nom)
    Set wb = Nothing
    Exit Function
fin:
    Fic_ouvert = False
    On Error GoTo 0
End Function
Function SupprCar(msg As String) As String
Dim sc_supprcar1 As String, sc_supprcar2 As String
sc_supprcar1 = Replace(msg, CHR_SUP_A, "")
sc_supprcar2 = Replace(sc_supprcar1, CHR_SUP_B, " ")
SupprCar = Replace(sc_supprcar2, CHR_SUP_C, "")
 
End Function
Sub ConnexionOutlook()
 
Const olMail = 43
 
Dim co_outlookapp As Object
Dim co_olnomdomaine As Object
Dim co_oldossier As Object
Dim co_olmailitem As Object
Dim co_cheminfichier As String
Dim co_flgoutlook As Boolean
Dim co_flgfic As Boolean
Dim co_xlbook As Workbook
Dim iRow As Integer
Dim j As Long
Dim vText As Variant
 
co_flgfic = True
co_flgoutlook = False
 
co_cheminfichier = ""
 
Set co_outlookapp = CreateObject("Outlook.Application")
 
If co_outlookapp.Explorers.Count = 0 Then
    co_flgoutlook = True
End If
Creation_Repertoire (REP_FICHIER)
co_cheminfichier = REP_FICHIER & "\" & NOM_FICHIER & EXT_FICHIER
If ExistFile(co_cheminfichier) Then
       If Fic_ouvert(co_cheminfichier) = False Then
         Set co_xlbook = Workbooks.Open(co_cheminfichier)
    Else
        MsgBox "Le fichier Excel est déjà ouvert.", vbOKOnly + vbInformation, _
        "Tentative d'ouverture du fichier Excel"
        co_flgfic = False
    End If
Else
        Set co_xlbook = Workbooks.Add
        FormatFicExcel co_xlbook
        co_xlbook.SaveAs co_cheminfichier
End If
If co_flgfic Then
 
         iRow = 2
         Set co_olnomdomaine = co_outlookapp.GetNamespace("MAPI")
         Set co_oldossier = co_olnomdomaine.GetDefaultFolder(6)
         Set co_oldossier = co_oldossier.Folders("test")
 
         For Each co_olmailitem In co_oldossier.Items
            If co_olmailitem.Class = olMail Then
                If Trim(co_olmailitem.SenderEmailAddress) = ADR_MAIL Then
                    vText = Split(CStr(co_olmailitem.Body), ";")
                       For j = 0 To UBound(vText)
                            co_xlbook.Sheets("TEST").Cells(iRow, j + 2) = vText(j)     'Ligne où il y a l'erreur d'exécution 
                       Next j
                       iRow = iRow + 1
                End If
            End If
          Next co_olmailitem
 
    co_xlbook.Save
    co_xlbook.Close
 
End If
 If co_flgoutlook Then
    co_outlookapp.Quit
End If
Set co_oldossier = Nothing
Set co_olnomdomaine = Nothing
Set co_olmailitem = Nothing
Set co_outlookapp = Nothing
 
End Sub
Public Function FormatFicExcel(ff_classeur As Workbook)
 
ff_classeur.Sheets("Feuil1").Activate
ff_classeur.Sheets("Feuil1").Name = "TEST"
 
ff_classeur.Sheets("TEST").Cells(1, 1) = "Type"
ff_classeur.Sheets("TEST").Cells(2, 1) = "ao"
ff_classeur.Sheets("TEST").Cells(3, 1) = "co"
ff_classeur.Sheets("TEST").Cells(1, 2) = "Date"
ff_classeur.Sheets("TEST").Cells(1, 3) = "nb_ventes"
ff_classeur.Sheets("TEST").Cells(1, 4) = "nb_achats"
 
ff_classeur.Sheets("TEST").Range("A1:D1").Select
 
With Selections
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
With Selection.Font
    .Bold = True
    .Name = "Cambria"
    .Size = 10
End With
 
End Function

**Oliv-** · 13/03/2015, 22h45

comme cela ca doit être bon

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
 
Option Explicit
 
Public CHR_SUP_A As String
Public CHR_SUP_B As String
Public CHR_SUP_C As String
 
Const NOM_FICHIER = "Classeur1"
Const EXT_FICHIER = ".xlsx"
Const REP_FICHIER = "C:\Users\Desktop"    '\Classeur1.xlsx" ca ca doit pas être bon
Const ADR_MAIL = "xxxx@yyyy.com"
Const DOSSIER_PERSONNEL = "Boîte aux lettres"
Const DOSSIER_RECEPTION = "Boîte de réception"
Const NOM_DOSSIER = "test"
 
Function Creation_Repertoire(cheminrepertoire As String)
 
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FolderExists(cheminrepertoire) = False Then
        fs.CreateFolder (cheminrepertoire)
        Creation_Repertoire = True
    Else
        Creation_Repertoire = False
    End If
End Function
Function ExistFile(strpath As String) As Boolean
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    ExistFile = fs.FileExists(strpath)
End Function
Function Fic_ouvert(fic_nom As String)
    Dim wb As Workbook
    Fic_ouvert = True
    On Error GoTo fin
    Set wb = Workbooks(fic_nom)
    Set wb = Nothing
    Exit Function
fin:
    Fic_ouvert = False
    On Error GoTo 0
End Function
Function SupprCar(msg As String) As String
    Dim sc_supprcar1 As String, sc_supprcar2 As String
    sc_supprcar1 = Replace(msg, CHR_SUP_A, "")
    sc_supprcar2 = Replace(sc_supprcar1, CHR_SUP_B, " ")
    SupprCar = Replace(sc_supprcar2, CHR_SUP_C, "")
 
End Function
Sub ConnexionOutlook()
 
    Const olMail = 43
 
    Dim co_outlookapp As Object
    Dim co_olnomdomaine As Object
    Dim co_oldossier As Object
    Dim co_olmailitem As Object
    Dim co_cheminfichier As String
    Dim co_flgoutlook As Boolean
    Dim co_flgfic As Boolean
    Dim co_xlbook As Workbook
    Dim iRow As Integer
    Dim j As Long, k
    Dim vText As Variant
    Dim VLigne As Variant
 
    co_flgfic = True
    co_flgoutlook = False
 
    co_cheminfichier = ""
 
    Set co_outlookapp = CreateObject("Outlook.Application")
 
    If co_outlookapp.Explorers.Count = 0 Then
        co_flgoutlook = True
    End If
    Creation_Repertoire (REP_FICHIER)
    co_cheminfichier = REP_FICHIER & "\" & NOM_FICHIER & EXT_FICHIER
    If ExistFile(co_cheminfichier) Then
        If Fic_ouvert(co_cheminfichier) = False Then
            Set co_xlbook = Workbooks.Open(co_cheminfichier)
        Else
            MsgBox "Le fichier Excel est déjà ouvert.", vbOKOnly + vbInformation, _
                   "Tentative d'ouverture du fichier Excel"
            co_flgfic = False
        End If
    Else
        Set co_xlbook = Workbooks.Add
        FormatFicExcel co_xlbook
        co_xlbook.SaveAs co_cheminfichier
    End If
    If co_flgfic Then
 
        iRow = 2
        Set co_olnomdomaine = co_outlookapp.GetNamespace("MAPI")
        Set co_oldossier = co_olnomdomaine.GetDefaultFolder(6)
        Set co_oldossier = co_oldossier.Folders("test")
 
        For Each co_olmailitem In co_oldossier.Items
            If co_olmailitem.Class = olMail Then
                If Trim(co_olmailitem.SenderEmailAddress) = ADR_MAIL Then    ' =
                    VLigne = Split(CStr(co_olmailitem.Body), Chr(10))
                    For k = 0 To UBound(VLigne)
                        vText = Split(CStr(VLigne(k)), ";")
                        For j = 0 To UBound(vText)
                            co_xlbook.Sheets("TEST").Cells(iRow, j + 1) = vText(j)     'Ligne où il y a l'erreur d'exécution
                        Next j
                     iRow = iRow + 1
                    Next k
                End If
            End If
            iRow = iRow + 1
        Next co_olmailitem
 
        co_xlbook.Save
        co_xlbook.Close
 
    End If
    If co_flgoutlook Then
        co_outlookapp.Quit
    End If
    Set co_oldossier = Nothing
    Set co_olnomdomaine = Nothing
    Set co_olmailitem = Nothing
    Set co_outlookapp = Nothing
 
End Sub
Public Function FormatFicExcel(ff_classeur As Workbook)
 
    ff_classeur.Sheets("Feuil1").Activate
    ff_classeur.Sheets("Feuil1").Name = "TEST"
 
    ff_classeur.Sheets("TEST").Cells(1, 1) = "Type"
    ff_classeur.Sheets("TEST").Cells(2, 1) = "ao"
    ff_classeur.Sheets("TEST").Cells(3, 1) = "co"
    ff_classeur.Sheets("TEST").Cells(1, 2) = "Date"
    ff_classeur.Sheets("TEST").Cells(1, 3) = "nb_ventes"
    ff_classeur.Sheets("TEST").Cells(1, 4) = "nb_achats"
 
    ff_classeur.Sheets("TEST").Range("A1:D1").Select
 
    With Selections
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    With Selection.Font
        .Bold = True
        .Name = "Cambria"
        .Size = 10
    End With
 
End Function