[XL-2003] Extraire données mails Outlook vers Excel [Résolu]

[sdispro]

Salut à tous,

Voilà un moment que je cherche ce type de macro qui pourrait reprendre les informations d'un mail, et cette macro s'approche a 80% de mes attentes.

Je pense que Daniel.C peut être mon sauveur.

Puis-je crée une macro qui:

1-Ouvre outlook
2-copie mes mails du dossier "TEST" situé dans la boite de reception (sachant que les mails ont toujours la même configuration c'est à dire:
TEST: XXXXXX
MAIL: XXXXXX)
3-Copié coller ce mail en cellule A1/A2 (2 ligne du mail)
4-Archiver avec un do until
5-classer le mail dans le dossier "TRAITES" de la boite de reception
6-passer au mail suivant

J'espere avoir été clair, merci par avance d'un retour.

A bientôt

[Daniel.C]

Bonjour,

Peux-tu donner quelques précisions ?

TEST: XXXXXX
MAIL: XXXXXX

Qu'est-ce que cela signifie ?

Copié coller ce mail en cellule A1/A2 (2 ligne du mail)

Est-ce je copie deux lignes du corps du message ou l'objet et le corps du message ?

[sdispro]

Merci Daniel pour la réponse.

Je vais essayer d'être plus précis dans ma demande.

Ma macro devrait:

1-lancer outlook
2-Aller chercher dans un dossier de ma boite de reception intitulé "essai"
3-Récupérer tous les mails envoyé de la manière suivante
a)copie l'adresse du destinataire en A1
b)copie l'objet du mail en A2
c)copie la première ligne du mail en A3
d)copie la seconde ligne du mail en A4
e) ect...

Ensuite la macro continue:
4)archive le mail sur une base de donnée excel avec un do until (de a1 a a4)
5)La macro s'execute jusqu'à ce que tous les mail du dossier ont été lu
6)Classe les mails dans le dossier traiter de la boite de reception

J'espere avoir été clair.

Si la solution est trouvé, tu deviens un Dieu pour moi

Merci encore et désolé pour la réponse tardive.

[Daniel.C]

4)archive le mail sur une base de donnée excel avec un do until (de a1 a a4)
5)La macro s'execute jusqu'à ce que tous les mail du dossier ont été lu

Juste une chose : le message suivant commence en A5 ? Je commence à travailler dessus. Le point que je n'ai jamais fait est de déplacer un mail d'un dossier à l'autre. A voir.

[sdispro]

Re,

Déplacer le dossier d'un mail à un autre ce n'est pas le plus important.

Le second mail ne doit pas se palcer en A5, une fois le premier mail insérer complétement dans le fichier excel, celui-ci s'archive automatiquement dans la feuille2, la feuille 1 étant réservé à la transition des données outlook à Excel.

Je me répète, mais si tu y arrive, tu peux te rajouter des étoiles!

[Daniel.C]

Regarde les commentaires dans le code. La définition des dossier source et cible doit changer suivant la définition des comptes dans Outlook. J'ai deux comptes qui utilisent la même boîte de réception. Je suppose que le cas normal serait :

Code :

1
2
 Set DossierSource = NS.Folders("Boîte de réception").Folders("essai")
    Set DossierDest = NS.Folders("Boîte de réception").Folders("traiter")

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub LireMessagesDUnDossierEtLeDeplacerVersUnAutre()
    Réf.sdispro.xlsm
    Dim olApp As Object, NS As Object, Dossier As Object
    Dim DossierDest As Object, DossierCible As Object
    Dim i As Object
    Set olApp = CreateObject("Outlook.Application")
    Set NS = olApp.GetNamespace("MAPI")
    Set DossierSource = NS.Folders(1).Folders("Boîte de réception").Folders("essai")
    Set DossierDest = NS.Folders(1).Folders("Boîte de réception").Folders("traiter")
    For Each i In DossierSource.Items
       Sheets.Add
       For Each r In i.Recipients
        [A1] = [A1] & ", " & r
       Next r
        [A1] = Right([A1], Len([A1]) - 2)
        '*** note : je n'ai pas la notion de "ligne dans le corps du message;
        ' e renvoi à la ligne est conservé mais tout est dans la cellule A2
        [A2] = i.Body
        Columns(1).AutoFit
        i.Move DossierDest
    Next i
    Set NS = Nothing
    Set olApp = Nothing
End Sub

[sdispro]

On y est presque mais tu m'épate...
Le seul problème c'est que la macro me crée des feuilles.
Il faudrait alors inverser l'ordre de mon Modop.
A1-A2-A3-A4-A5
se transforme en
B1-B2-B3-B4-B5

Le tout à chaque fois à la ligne

Je te tire mon chapeau Danie

[Daniel.C]

Ce que je ne comprends pas, OK pour le premier mail, mais en admettant que celui-ci soit en B1, B2:B5, où est-ce que j'écris les données du mail suivant ?
Donne-moi, s'il te plaît un exemple précis.

[sdispro]

Le mail arrive et se colle en B1
Donc les données sur la feuille 1 se mettre de A1 à B5
Une fois le mail arrivé et avant de passé au suivant, ce premier mail va se coller en feuille 2 mais de facon transposé:

A1 feuille 1 = A1 feuille2
A2 feuille 1 = B1 feuille 2
Ect...

Préfère tu un fichier excel?

[Daniel.C]

Si je comprends bien, le premier mail se met en feuil1, avant de traiter le second message, on copie les données du premier en feuille 2 et on met les données du second en feuille 1. Avant de traiter le troisième, on copie les données du second (feuille 1) où ? en écrasant les données de feuille 2 ?

Si tu crois q'un classeur peut aider à la compréhension, alors oui, poste-le.

[sdispro]

Daniel,

si cela est plus simple, voilà le résultat qe je dois avoir, peu importe si mon mail passe par la feuille 1 ou 2:


De: Objet : Mail :
de du mail 1 objet du mail 1 contenu mail 1
de du mail 2 objet du mail 2 contenu mail 2


Toutes ces infos se mettent à la suite les unes des autres.
Met tu as bioen compris mon dernier post.

[Daniel.C]

Voila; les données se copient sur la feuille Feuil1 :

Code :

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
Sub LireMessagesDUnDossierEtLeDeplacerVersUnAutre()
    'Réf.sdispro.xlsm
    Dim olApp As Object, NS As Object, Dossier As Object
    Dim DossierDest As Object, DossierCible As Object
    Dim i As Object, x As Long, R As Object, Ligne As Long
    Set olApp = CreateObject("Outlook.Application")
    Set NS = olApp.GetNamespace("MAPI")
    Set DossierSource = NS.Folders(1).Folders("Boîte de réception").Folders("essai")
    Set DossierDest = NS.Folders(1).Folders("Boîte de réception").Folders("traiter")
    With Sheets("Feuil1")
        For Each i In DossierSource.Items
            Ligne = Ligne + 1
            .Cells(Ligne, 1) = i.Subject
            Ligne = Ligne + 1
            For x = 0 To UBound(Split(i.Body, vbCrLf))
                Ligne = Ligne + 1
                .Cells(Ligne, 2) = Split(i.Body, vbCrLf)(x)
            Next x
            Ligne = Ligne + 1
            .Columns(2).AutoFit
            Var = ThisWorkbook.Path & "\" & i.CreationTime & " - " & i.Subject & ".msg"
            'sauvegarde du message sous forme de fichier. Possibilité de mettre un lien hypertexte pour l'ouvrir dans Outlook
            'i.SaveAs "c:temp\" & Format(i.CreationTime, "yyyy-mm-dd hh""h""mm") & " - " & i.Subject & ".msg", olMSG
            i.Move DossierDest
        Next i
    End With
    Set NS = Nothing
    Set olApp = Nothing
 
End Sub

Note: j'ai mis en commentaire une méthode pour sauvegarder les messages sous forme de fichiers au format msg. Il suffit de cliquer dessus pour les ouvrir dans Outlook. Au cas où tu serais intéressé...

[sdispro]

Re,

Tout d'abord merci pour ta réponse, on y est presque.
Cependant cela ne se colle pas de la sorte.
Je te joint un fichier excel pour eviter de te perdre et que tu me comprenne mieux.

[Daniel.C]

Tu auras un problème si tu as une version d'Excel antérieure à XL2007; dans ce cas, dis-le :

Code :

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
Sub LireMessagesDUnDossierEtLeDeplacerVersUnAutre()
    'Réf.sdispro.xlsm
    Dim olApp As Object, NS As Object, Dossier As Object
    Dim DossierDest As Object, DossierCible As Object
    Dim i As Object, x As Long, R As Object, Ligne As Long
    Set olApp = CreateObject("Outlook.Application")
    Set NS = olApp.GetNamespace("MAPI")
    Set DossierSource = NS.Folders(1).Folders("Boîte de réception").Folders("essai")
    Set DossierDest = NS.Folders(1).Folders("Boîte de réception").Folders("traiter")
    Ligne = .Cells(.Rows.Count, 3).End(xlUp).Row
    With Sheets("Feuil1")
        For Each i In DossierSource.Items
            Ligne = Ligne + 1
            .Cells(Ligne, 1) = i.sendername
            .Cells(Ligne, 2) = i.Subject
            Ligne = Ligne + 1
            For x = 0 To UBound(Split(i.Body, vbCrLf))
                Ligne = Ligne + 1
                .Cells(Ligne, 3) = Split(i.Body, vbCrLf)(x)
            Next x
            '.range(.[A2],.cells(ligne+1,3)).
            .Columns(3).AutoFit
 
            'sauvegarde du message sous forme de fichier. Possibilité de mettre un lien hypertexte pour l'ouvrir dans Outlook
            'i.SaveAs "c:temp\" & Format(i.CreationTime, "yyyy-mm-dd hh""h""mm") & " - " & i.Subject & ".msg", olMSG
            i.Move DossierDest
        Next i
    End With
    Set NS = Nothing
    Set olApp = Nothing
 
End Sub

[sdispro]

Je suis sur 2003

[Daniel.C]

C'est juste plus simple avec XL2003 :

Code :

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
Sub LireMessagesDUnDossierEtLeDeplacerVersUnAutre()
    'Réf.sdispro.xlsm
    Dim olApp As Object, NS As Object, Dossier As Object
    Dim DossierDest As Object, DossierCible As Object
    Dim i As Object, x As Long, R As Object, Ligne As Long
    Set olApp = CreateObject("Outlook.Application")
    Set NS = olApp.GetNamespace("MAPI")
    Set DossierSource = NS.Folders(1).Folders("Boîte de réception").Folders("essai")
    Set DossierDest = NS.Folders(1).Folders("Boîte de réception").Folders("traiter")
    With Sheets("Feuil1")
        Ligne = .Cells(.Rows.Count, 3).End(xlUp).Row
        For Each i In DossierSource.Items
            Ligne = Ligne + 1
            .Cells(Ligne, 1) = i.SenderName
            .Cells(Ligne, 2) = i.Subject
            Ligne = Ligne + 1
            For x = 0 To UBound(Split(i.Body, vbCrLf))
                Ligne = Ligne + 1
                .Cells(Ligne, 3) = Split(i.Body, vbCrLf)(x)
            Next x
            .Columns(3).ColumnWidth = 185
            .Columns(3).Cells.WrapText = True
            '*** bordures
        With .Range(.[A2], .Cells(Ligne, 3))
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .Weight = xlThin
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .Weight = xlThin
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .Weight = xlThin
            End With
        End With
            With .Range(.Cells(Ligne, 1), .Cells(Ligne, 3))
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .Weight = xlThin
                End With
            End With
            'sauvegarde du message sous forme de fichier. Possibilité de mettre un lien hypertexte pour l'ouvrir dans Outlook
            'i.SaveAs "c:temp\" & Format(i.CreationTime, "yyyy-mm-dd hh""h""mm") & " - " & i.Subject & ".msg", olMSG
            i.Move DossierDest
        Next i
    End With
    Set NS = Nothing
    Set olApp = Nothing
 
End Sub

[sdispro]

Presque mias je vais me debrouillé avec le reste.

Tu es un vrai pro, merci pour tout