Extraire des mails d'Outlook vers Excel

Signaler
Messages postés
1
Date d'inscription
mercredi 11 mars 2015
Statut
Membre
Dernière intervention
11 mars 2015
-
Bonsoir tout le monde,

Je suis débutant en programmation VBA et dans le cadre d'un projet, je dois exporter un mail de la forme ci-dessous vers une feuille Excel :

type;date;nb_ventes;nb_achats
ao;02/02/2014;1245;2365
co;03/02/2015;1425;2365

Toutefois, quand j'exécute mon code VBA, il ne prend pas en considération les données chiffrées et n'affiche que la chose suivante :

type date nb_ventes nb_achats
ao
co

A cet effet, je voudrai savoir qu'est ce qui bloque au niveau du code VBA et comment faire justement pour y remédier et arriver à exporter correctement ce mail vers Excel. En vous remerciant par avance pour vos retours, je vous souhaite une bonne soirée.


Option Explicit

Const NOM_FICHIER = "Test"
Const EXT_FICHIER = ".xlsx"
Const REP_FICHIER = "C:\Users\usere\Desktop\Test.xlsx"

Const ADR_MAIL = "XXXX@YYYY.com"

Const strpath As String = "C:\Users\usere\Desktop\Test.xlsx"

Sub CopyToExcel()

Dim MyAr() As String
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rcount As Long
Dim bXStarted As Boolean

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

Sub ConnexionOutlook()

Dim co_outlookapp As Object
Dim co_olnomdomaine As Object
Dim co_oldossier As Object
Dim co_olmailitem As Object
Dim co_orderinfo As String
Dim co_cheminfichier As String
Dim co_flgoutlook As Boolean
Dim co_flgfic As Boolean
Dim i As Long
Dim j As Long
Dim vItem As Variant
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rcount As Long
Dim vText As Variant
Dim sText As String
Dim bXStarted As Boolean

co_flgfic = True
co_flgoutlook = False
co_orderinfo = ""
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 xlWB = xlApp.Workbooks.Open(strpath)
Else
MsgBox "Le fichier Excel est déjà ouvert.", vbOKOnly + vbInformation, _
"Tentative d'ouverture du fichier Excel"
co_flgfic = False
End If
Else

Set xlSheet = xlWB.Sheets("Transfert")
FormatFicExcel (xlWB)
xlWB.SaveAs co_cheminfichier

End If

If co_flgfic Then

Set co_olnomdomaine = co_outlookapp.GetNamespace("MAPI")
Set co_oldossier = co_olnomdomaine.PickFolder

For Each co_olmailitem In co_oldossier.Items
If Trim(co_olmailitem.SenderEmailAddress) = ADR_MAIL Then
If co_olmailitem.UnRead = True Then
If Len(Trim(co_orderinfo)) > 0 Then
co_orderinfo = co_olmailitem.Body
rcount = xlSheet.UsedRange.Rows.Count
sText = co_olmailitem.Body
vText = Split(sText, Chr(13), ";")

rcount = rcount + 1

For i = UBound(vText) To 0 Step -1

If InStr(1, vText(i), "type") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rcount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "date") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rcount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "nb_ventes") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rcount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "nb_achats") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rcount) = Trim(vItem(1))
End If

Next i

xlWB.Save
xlWB.Close SaveChanges:=True
co_olmailitem.UnRead = False
End If
End If
End If
Next

xlWB.Save
xlWB.Close
End If


If bXStarted Then
xlApp.Quit
End If

Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set co_oldossier = Nothing
Set co_olnomdomaine = Nothing
Set co_olmailitem = Nothing
Set co_outlookapp = Nothing

End Sub

Sub FormatFicExcel(ff_classeur As Workbook)

ff_classeur.Worksheets("Feuil1").Activate
ff_classeur.Worksheets("Feuil1").Name = "Transfert"

ff_classeur.Worksheets("Transfert").Cells(1, 1) = "type"
ff_classeur.Worksheets("Transfert").Cells(1, 2) = "ao"
ff_classeur.Worksheets("Transfert").Cells(1, 3) = "co"
ff_classeur.Worksheets("Transfert").Cells(2, 1) = "date"
ff_classeur.Worksheets("Transfert").Cells(3, 1) = "nb_ventes"
ff_classeur.Worksheets("Transfert").Cells(4, 1) = "nb_achats"

End Sub

If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If

Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0

End Sub