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 |
Partager