'GetMail V3.3b Dim eMails(), noms() As String Dim EmailFromBody As Boolean Private 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 du dossier sélectionné Sub GetEmail() Set rep = Outlook.Application.ActiveExplorer.CurrentFolder ' initialisation du tableau reponse = MsgBox("Voulez-vous extraire les e-mails du corps 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 = GetTempDir() & "/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" OpenExcel (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 vbTab & "corps" & 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 Sub OpenExcel(FileName) Set xls = CreateObject("Excel.Application") xls.Workbooks.Open FileName xls.Visible = True Exit Sub End Sub Function GetTempDir() As String Dim buffer As String * 256 Dim Length As Long Length = GetTempPath(Len(buffer), buffer) GetTempDir = Left(buffer, Length) End Function