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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
| 'GetMail V4.1
'DÈclaration des tableaux dynamiques globaux contenant la liste des emails
Dim eMails(), noms() As String
Dim EmailFromBody As Boolean
Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'Extrait dans Outlook la liste des emails (destinataire, Èmetteur, corp) du dossier sÈlectionnÈ
'et crÈe un mail avec la liste des emails
Sub GetEmail()
Set rep = Outlook.Application.ActiveExplorer.CurrentFolder
' Set rep = Application.Session.CurrentFolder
' initialisation du tableau
reponse = MsgBox("Voulez-vous extraire les e-mails du corp des messages ?", vbYesNoCancel)
If reponse = vbCancel Then
Exit Sub
ElseIf reponse = vbYes Then
EmailFromBody = True
Else
EmailFromBody = False
End If
ReDim Preserve eMails(1), noms(1)
eMails(1) = ""
noms(1) = ""
'On stocke les emails dans le tableau
GetEmailFromFolder rep
If eMails(1) <> "" Then
NomFichier = GetTempDir2() & "/emails.xls"
Close #1
Open NomFichier For Output As #1
For i = 1 To UBound(eMails)
Print #1, AfficheEmail(noms(i), eMails(i))
Next
Close #1
MsgBox UBound(eMails) & " emails trouvÈs dans " & rep, vbInformation, "Done"
OpenExcel2 (NomFichier)
Else
MsgBox "Pas d'email trouvÈ dans " & rep, vbInformation, "Done"
End If
End Sub
Function AfficheEmail(nom, Email)
Email = Replace(Email, "'", "")
If nom = "" Or nom = "body" Then
nom = Email
End If
AfficheEmail = Email + vbTab + nom + vcrlf
End Function
'Explore les dossiers (fonction rÈentrante)
Sub GetEmailFromFolder(myFolder)
Dim myItemRec, MyItem As Object
Dim myMailItem As Outlook.MailItem
'Tous les dossiers
For Each MyItem In myFolder.Folders
GetEmailFromFolder MyItem
Next
'Tous les mails
rep = Replace(myFolder.FolderPath, "\", vbTab)
'rep = Replace(myFolder, "\", vbTab)
'On Error Resume Next
For Each MyItem In myFolder.Items
If TypeName(MyItem) = "MailItem" Then
'Destinataires (cc & cci)
For Each myItemRec In MyItem.Recipients
addMail myItemRec.name & vbTab & "dest" & rep, myItemRec.Address
Next
'Emetteur
addMail MyItem.SenderName & vbTab & "exp" & rep, MyItem.SenderEmailAddress
'et dans le corp du mail
If EmailFromBody Then findMail MyItem.body, rep
End If
Next
End Sub
'Rajoute une entrÈe au tableau emails() si l'email n'existe pas dÈj‡
Sub addMail(nom, Email)
Email = TrimEmail(Email)
nom = Trim(nom)
If Email <> "" And InStr(Email, "@") > 0 And InStr(Email, ".") > 0 Then
'VÈrification de l'unicitÈ
Find = UBound(Filter(eMails, Email, True, vbTextCompare))
If eMails(1) = "" Then
eMails(1) = Email
noms(1) = nom
ElseIf Find = -1 Then
'On augmente la taille du tableau et on ajoute
ReDim Preserve eMails(UBound(eMails) + 1)
ReDim Preserve noms(UBound(noms) + 1)
eMails(UBound(eMails)) = Email
noms(UBound(noms)) = nom
Else
'On prÈfËre le plus grand si c'est pas une email
If Len(nom) > Len(noms(Find)) And InStr(nom, "@") = 0 Then
noms(Find) = nom
End If
End If
End If
End Sub
Sub findMail(body, rep)
at = InStr(body, "@")
Do While at > 1
D = at - 1
Do While carOk(Mid(body, D, 1))
D = D - 1
If D = 0 Then
Exit Do
End If
Loop
f = at + 1
Do While carOk(Mid(body, f, 1))
f = f + 1
If f = Len(body) Then
Exit Do
End If
Loop
If D < at - 3 And f > at + 4 Then
addMail GetTel(body) & vbTab & "body" & rep, Mid(body, D + 1, f - D - 1)
End If
at = InStr(at + 1, body, "@")
Loop
End Sub
Function carOk(c)
If c = "." Or c = "-" Or c = "_" Or (c >= "0" And c <= "9") Or (c >= "A" And c <= "Z") Or (c >= "a" And c <= "z") Then
carOk = True
Else
carOk = False
End If
End Function
Function carOkDebut(c)
If c = "-" Or c = "_" Or (c >= "0" And c <= "9") Or (c >= "a" And c <= "z") Then
carOkDebut = True
Else
carOkDebut = False
End If
End Function
Function carOkFin(c)
If (c >= "a" And c <= "z") Then
carOkFin = True
Else
carOkFin = False
End If
End Function
Function TrimEmail(email_ini)
Email = Trim(LCase(email_ini))
D = Len(Email)
For i = 1 To D
If Not carOkDebut(Left(Email, 1)) Then
Email = Mid(Email, 2, Len(Email) - 1)
Else
Exit For
End If
Next i
D = Len(Email)
For i = 1 To D
If Not carOkFin(Right(Email, 1)) Then
Email = Mid(Email, 1, Len(Email) - 1)
Else
Exit For
End If
Next i
TrimEmail = Email
End Function
Function GetTel(body)
Static Reg As Object
If Reg Is Nothing Then
Set Reg = CreateObject("vbscript.regexp")
Reg.Global = True
Reg.IgnoreCase = True
Reg.MultiLine = True
End If
Reg.Pattern = "([a-zA-ZÈ]*)[+ :]*?(([-. ]?[0-9]){10,11})"
Set Matches = Reg.Execute(body)
GetTel = ""
For Each Match In Matches
GetTel = GetTel & Match.Value & ";"
Next Match
End Function
Sub OpenExcel2(FileName)
Set xls = CreateObject("Excel.Application")
xls.Workbooks.Open FileName
xls.Visible = True
End Sub
Function GetTempDir2() As String
Dim buffer As String * 256
Dim Length As Long
Length = GetTempPath(Len(buffer), buffer)
GetTempDir2 = Left(buffer, Length)
End Function |
