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 |
Récupérer une adresse mail dans un corps de message
Répondre avec citation
Oliv'
.
Partager