Récupérer une adresse mail dans un corps de message [Résolu]

[wannie7777]

Bonjour tous le monde.

Voilà je n'ai pas souvent eu l'occasion de développer des macros sous Outlook et j'ai un petit problème pour l'une d'elle.

Je travaille sous Outlook 2000. Je stock dans un dossier tout les rapports de mail non remis aux destinataire (cause : email non valide ou n'existe plus).

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

Voici le code :

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
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
Sub Recup_adresse_mail()
'
''---------------------------------------------------------------------------------------
' Procedure : Recup_adresse_mail
' Auteur    : Erwan
' Date      : 16/09/2008
' Récupére dans une feuille Excel les addresses email contenues dans le corps de message des mails du dossier en cours
'---------------------------------------------------------------------------------------
 
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, "Impossible de contacter le(s) destinataire(s) suivant(s)") <> 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

Cette procédure fonctionne très bien pour les Emails mais pour les rapports je ne recupère rien dans la valeur Body.

Y a t'il une subtilité ou peut on contourner le problème car je commence à avoir un doute sur la faisabilité.

Merci d'avance de vos réponse et aide apporté.

[Oliv-]

Salut,

Le problème peut venir du caractère qui suis l'adresse Email ce n'est par forcèment un espace :

Regarde ce fil :
http://www.developpez.net/forums/d50...trouvant-mail/

Sinon il faudrait que tu fasses un copier coller d'un exemple de mail.

[wannie7777]

Merci de ton aide mais le problème ne viens pas de l'espace ou du caractère que ce trouve après l'adresse mail.

Je n'arrive pas encore à cette étape. Je suis bloqué pour récupérer l'ensemble du corps de message du rapport(fonction email.body). Donc après je ne pas traiter la recherche de l'adresse email.

Code :

1
2
3
4
5
6
7
8
9
10
Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
    Set LesMails = MonOutlook.ActiveExplorer.CurrentFolder.Items


    For Each lemail In LesMails
    strTemp = lemail.Body
            If (InStr(lemail.Body, "Impossible de contacter le(s) destinataire(s) suivant(s)") <> 0) Then

                bool_trouv = True

la variable strTemp retourne "" alors qu'il devarit me recupérer l'ensemble du corps du message.

Voici un exemple de rapport :




Merci d'avance si vous avez une idée

[Oliv-]

Salut,

Ajoute cette ligne avant la boucle For each :

Code :

 Dim lemail As Object

est ce que c'est ok ?

[wannie7777]

Désolé mais c'est toujours pareil.

En ne declarant pas la variable "lemail" il recupere le format de "lesemail" qui est une variable object. Ce qui reviens a la même chose si je déclare "lemail" en variable object. J'ai fais le test avec les deux et c'est pareil :

Code :

1
2
3
Dim LesMails As Object
 
For Each lemail In LesMails

Par contre je viens de remarquer une chose. La variable lemail possède l'object du message en valeur lors de la lecture du message.
La fonction "body" elle ne ramène toujours pas le corps du message.

En tout cas merci de te pencher sur mon problème.

A +

[Oliv-]

As tu un message d'erreur ?
Cela doit venir de ta version car avec outlook 2003 cela fonctionne, il faut que tu regardes les propriétés des élements ReportItem dans l'aide de ta version.

sinon tu peux essayer avec CDO ou redemption

[wannie7777]

Rebonjour,

Me revoilà

Je installé la macro sur une version outlook 2003 et effectivement cela fonctionne correctement.

Le problème viendrait de la fonction "body" qui ne fonctionne pas pour ce type de message.

Quelqu'un aurait une idée pour contourner le problème. Effectivement il y a la propriété reportitem mais je n'arrive pas à la gérer comme la propriété item.

Merci d'avance de votre aide

[wannie7777]

Je viens de trouver cette article :http://support.microsoft.com/kb/231292/fr

Je pense que j'aurais du mal à extraire l'adresse mail du corps du message.

Il me viens deux idées pour contourner le problème. Le soucis c'est que je n'est aucune idée pour les realiser

Première possiblité : recupéré les informations présent dans l'en-têtes Internet du rapport (On peut le voir si on fait un clique droit>option sur le rapport.

Deuxième possibilité : Faire comme si on clique sur le bouton "envoyer de nouveaux" et recupéré l'adresse mail du destinataire.

Si quelqu'un peut me guider ça m'aiderai beaucoup.

[Oliv-]

Salut,

Voici une solution avec REDEMPTION

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub REPORT_REDEMPTION()
'Redemption doit être installé
'http://www.dimastr.com/redemption/Redemption.zip
Dim INSP, Item, StrEntryID
Set INSP = ActiveInspector 'désigne la fenêtre de l'élement actif
Set Item = INSP.CurrentItem
If Item.Class = olReport Then
 
'Item.MessageClass = "REPORT.IPM.NOTE.NDR"
StrEntryID = Item.EntryID
Set REDSession = CreateObject("Redemption.RDOSession")
REDSession.MAPIOBJECT = Application.Session.MAPIOBJECT
Set Mail = REDSession.GetMessageFromID(Item.EntryID)
  MsgBox Mail.reporttext
 
End If
End Sub

[wannie7777]

Escuse moi mais qu'est ce que REDEMPTION et peut tu m'expliquer sont utilité.

Merci d'avance

[Oliv-]

C'est une dll , qui permet de faire ce que le modèle OUTLOOK ne peut pas faire.

regarde ici la description
http://www.dimastr.com/redemption/

[wannie7777]

Bon pour ceux que ça interressent j'ai trouver une solution qui permet de récupéré l'adresse mail du destinataire dans rapport de non remise .

Comme la dit Oliv (que je remercie de son aide par ailleur ) il est également possible de passer par la DLL REDEMPTION mais je n'est a pas pu l'utilisé car j'utilise des serveurs TSE sur lesquels les utilisateurs se connecte de façons aleatoire. J'aurais été obligé d'installer REDEMPTION sur chaque serveur chose que je voulais eviter.

La solution que j'ai trouvé est de traiter les entête Internet.

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
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
Sub Recup_adresse_mail()
'
''---------------------------------------------------------------------------------------
' Procedure : Recup_adresse_mail
' Autheur    : Erwan
' Date      : 16/09/2008
' Récupére dans une feuille Excel les addresses email contenues dans le corps de message des mails du dossier en cours
'---------------------------------------------------------------------------------------
 
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_prem_space As Integer
Dim intpos_deux_space As Integer
Dim oSession As MAPI.Session
Dim ofolders As MAPI.Folders
Dim ofolder As MAPI.Folder
Dim oMsgColl As Messages
Dim omessage As Message
 
 
    '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
 
      ' Connexion a une session MAPI
    Set oSession = New MAPI.Session
    oSession.Logon
 
    Set ofolders = oSession.GetInfoStore("").RootFolder.Folders
 
    'appel de la fonction Findfolder pour trouvé le dossier
    Set ofolder = FindFolder("test", ofolders)
 
    Set oMsgColl = ofolder.Messages
 
      ' Search through the messages in the Inbox for the Internet
      ' message.  Then use the CdoPR_TRANSPORT_MESSAGE_HEADERS
      ' (&H7D001E) property tag to retrieve the Internet header.
      ' If the property doesn't exist(Not a Internet message) you will
      ' receive a MAPI_E_NOT_FOUND error.
 
    For Each omessage In oMsgColl
 
        strTemp = omessage.Fields(&H7D001E) 'Display the header
 
        bool_trouv = True
 
        intpos = InStrRev(strTemp, "To: ")
        If intpos <> 0 Then
 
            intpos_prem_space = InStr(intpos, strTemp, " ")
            intpos_deux_space = InStr(intpos_prem_space, strTemp, vbCr & vbLf)
            adress_mail = Mid(strTemp, intpos_prem_space, intpos_deux_space - intpos_prem_space)
        End If
 
        If bool_trouv = True Then
            wsExcel.Cells(ligne, 1).Value = adress_mail
            ligne = ligne + 1
        End If
 
    Next omessage
 
    ' Deconnexion
    oSession.Logoff
    Set oSession = Nothing
    Set omessage = Nothing
    Set oMsgColl = Nothing
    Set ofolder = Nothing
 
    MsgBox "Opération terminée"
 
End Sub
 
Function FindFolder(ByVal strName As String, _
                    objFolders As MAPI.Folders) As MAPI.Folder
    Dim objTmp As MAPI.Folder
    Dim objTarget As MAPI.Folder
    For Each objTmp In objFolders
        If InStr(1, objTmp.Name, strName, vbTextCompare) > 0 Then
            Set objTarget = objTmp
            Exit For
        End If
    Next
    If objTarget Is Nothing Then
        For Each objTmp In objFolders
            Set objTarget = FindFolder(strName, objTmp.Folders)
            If Not objTarget Is Nothing Then Exit For
        Next
    End If
    Set FindFolder = objTarget
End Function

J'avoue que la fonction ainsi que le champs &H7D001E a été trouvé sur internet.

En tout cas si ça peux servir.