Discussion :

[Olive912]

Bonjour à tous,

Je travaille sous Outlook 2000.
Je stocke dans un dossier les rapports des emails non remis aux destinataires (cause : email non valide ou n'existe plus).

Je souhaite donc récupérer l'adresse mail qui se trouve dans le corps du message de ce rapport de non remise et enregistrer toutes ces adresses emails erronées dans Excel.

Voici le corps de message "type" :
Échec de la remise pour ces destinataires ou groupes :
XXXXX@XXXXX.com
Le système de messagerie du destinataire est actuellement occupé et ne peut pas accepter de messages. Essayez de renvoyer ce message ultérieurement.

Voici le code que j'ai récupéré sur un autre topic mais qui ne fonctionne pas :

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
Sub Recup_adresse_mail()
'
''---------------------------------------------------------------------------------------
' Procedure : Recup_adresse_mail
' Auteur    : Erwan
' Date      : 16/09/2008
' https://www.developpez.net/forums/d615449/logiciels/microsoft-office/outlook/vba-outlook/recuperer-adresse-mail-corps-message/
' Récupére dans une feuille Excel les addresses email contenues dans le corps de message des mails du dossier en cours
'---------------------------------------------------------------------------------------
 
 
'Déclaration des variables
Dim MonOutlook As Outlook.Application
Dim LesMails As Object
Dim appExcel As Excel.Application    'Application Excel
Dim wbExcel As Excel.Workbook    'Classeur Excel
Dim wsExcel As Excel.Worksheet    'Feuille Excel
Dim ligne As Integer
Dim strTemp As String
Dim intpos As Integer
Dim intpos_space As Integer
Dim intpos_bracket As Integer
Dim intpos_temp As Integer
Dim bool_trouv As Boolean
 
 
    'Ouverture de l'application
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Visible = True
    appExcel.Workbooks.Add
    Set wbExcel = appExcel.ActiveWorkbook
    Set wsExcel = wbExcel.ActiveSheet
 
    wsExcel.Range("a1").Value = "Adresse Expediteur"
 
 
    ligne = 2
 
    Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
    Set LesMails = MonOutlook.ActiveExplorer.CurrentFolder.Items
 
 
    For Each lemail In LesMails
 
            If (InStr(lemail.Body, "Échec de la remise pour ces destinataires ou groupes :") <> 0) Then
 
                bool_trouv = True
 
                'Extract email address from body
                intpos = InStr(lemail.Body, "@")
                If intpos <> 0 Then
                    'Get right of @
                    intpos_space = InStr(intpos, lemail.Body, " ")
                    intpos_bracket = InStr(intpos, lemail.Body, ">")
                    If (intpos_space < intpos_bracket) Or (intpos_bracket = 0) Then
                        intpos_temp = intpos_space
                    Else
                        intpos_temp = intpos_bracket
                    End If
                    strTemp = Left(lemail.Body, intpos_temp - 1)
                    'Get left of @
                    intpos_space = InStrRev(strTemp, " ", -1)
                    intpos_bracket = InStrRev(strTemp, "<", -1)
                    If (intpos_space > intpos_bracket) Or (intpos_bracket = 0) Then
                        intpos_temp = intpos_space
                    Else
                        intpos_temp = intpos_bracket
                    End If
                    strTemp = Mid(strTemp, intpos_temp + 1)
 
                End If
            End If
 
            If bool_trouv = True Then
                wsExcel.Cells(ligne, 1).Value = strTemp
                ligne = ligne + 1
            End If
 
    Next lemail
 
    MsgBox "Opération terminée"
 
End Sub

Je me place sur le dossier archivé où sont stockés mes emails en question et exécute la macro.
Excel s'ouvre et seul "Adresse Expediteur" s'affiche en A1.
Qu'est ce qui ne va pas dans le code ?

Merci d'avance de vos réponses.

[Oliv-]

Bjr ca doit etre le test instr qui ne match rien.
Tu peux ajouter un paramètre pour qu il ne tient pas compte de.la CASSE.



Ou ajoute en haut du module
Option compare text

[Olive912]

Bonjour Oliv' !

J'ai refait un test avec un email contenant uniquement le texte ci-dessous et cela fonctionne :

Échec de la remise pour ces destinataires ou groupes :
XXX@XXX.com
Le système de messagerie du destinataire est actuellement occupé et ne peut pas accepter de messages. Essayez de renvoyer ce message ultérieurement.

Après vérif, le code VNA ne fonctionne pas car l y a des répétitions de l'email en dessous de ce quote (dans le paragraphe "Informations de diagnostic pour les administrateurs")

Comment faire pour avoir comme résultat le premier email visible dans chaque email ?

Aussi, le résultat qui apparaît maintenant est le suivant : "mailto:XXX@XXX.com"XXX@XXX.com"
Est-ce possible de ne conserver que l'email "XXX@XXX.com"et non le "mailto:XXX@XXX.com" ?

[Jean-Philippe André]

Salut,

tu peux tres bien faire une etape intermediaire de "nettoyage"

Code :

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

1
2
3
4
5
6
7
Dim strTonBlocMail as String
 
'alimentation de la variable strTonBlocMail
 
If Instr(1,strTonBlocMail,"mailto:")=1 Then
 'traitement de nettoyage entre le mailto et le reste du texte
End if