Sujet Précédent Sujet Suivant

Recuperation mail sous outlook

dgfhierf Messages postés 5 Date d'inscription samedi 20 mai 2006 Statut Membre Dernière intervention 4 mars 2015 - 11 déc. 2008 à 12:29
dgfhierf Messages postés 5 Date d'inscription samedi 20 mai 2006 Statut Membre Dernière intervention 4 mars 2015 - 11 déc. 2008 à 16:15
Bonjour à tous,

Suite à un mailing j'aimerais epurer ma base des mails qui reviennent en erreur, n'existent plus... donc je les place tous dans un dossier et j'aimerais pouvoir lancer une macro qui va recuperer les mails dans le body des messages.
Je suis nul en VB, j'ai trouvé ce code qui fait ce que je veux mais qui est limiter au 550
Est ce qu'une ame charitable ne pourrait pas me dire ce qu'il faut modifier pour que ça prenne l'integrailté des mails

voici le code :

Sub GetEmailFromBody()
    
    ' ------------------------------------------------
    ' --- You may use and/or change this code freely
    ' --- provided you keep this message
    ' ---
    ' --- Description:
    ' --- Extracts first found email address from body
    ' --- (used to extract email address from
    ' --- error messages/returned email)
    ' --- Runs on all items in current folder
    ' ---
    ' --- By Max Flodén 2006 - http://www.tjitjing.com
    ' ------------------------------------------------


    Dim myOlApp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim mySelection As Selection
    Dim myItem As Object
    Dim myMailItemLog As Outlook.MailItem
    Dim myFolder As Outlook.MAPIFolder
       
    Dim strContactFolderName As String  'Directly under Public Folders\All Public Folders
    Dim strNewsletterCategoryName As String
    Dim strMailItemSender As String
    Dim strMailTo As String
    Dim intMessageCount As Integer
    Dim bolDebug As Boolean     'If true no emails will be sent
    Dim bolOnly550 As Boolean   'Only extract email addresses that are 'user not found' (#550) etc.
    Dim strTemp As String
   
    Set myNameSpace = myOlApp.GetNamespace("MAPI")


    'Debug settings
    bolDebug = True
  
    'Ask to continue - start warning
    intRes = MsgBox("This macro will go thru all items in folder." & vbCrLf & "Would like to extract only addresses that have 'user not found'?", vbYesNoCancel + vbQuestion, "Get Email from Body")
    If intRes = vbCancel Then
        Exit Sub
    ElseIf intRes = vbYes Then
        bolOnly550 = True
    Else
        bolOnly550 = False
    End If
           
    'Create a new email to use as log file
    Set myMailItemLog = myOlApp.CreateItem(olMailItem)
    myMailItemLog.Recipients.Add (myNameSpace.CurrentUser)
    myMailItemLog.Subject = "Email from Body - " & Now()
    myMailItemLog.BodyFormat = olFormatPlain
    myMailItemLog.Body = Now() & " Starting..." & vbCrLf & vbCrLf
            
    'Go thru all items in folder
    intMessageCount = 0
    intMsgCount_Error = 0
    For Each myItem In myOlApp.ActiveExplorer.CurrentFolder.Items
                If Not TypeName(myItem) "ReportItem" And Not TypeName(myItem) "MailItem" Then
            'Errorlog
            If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & "ERROR - MESSAGE TYPE IS NOT REPORTITEM OR MAILITEM." & vbCrLf
            myItem.UnRead = True
            intMsgCount_Error = intMsgCount_Error + 1
        Else
       
            'Check type is 550 - user not found/inactive etc
            '2007-03-27 removed 554 error
            If bolOnly550 And _
            (InStr(myItem.Body, "550") = 0) And _
            (InStr(myItem.Body, "unknown user") = 0) And _
            (InStr(myItem.Body, "user unknown") = 0) And _
            (InStr(myItem.Body, "no mailbox here by that name") = 0) And _
            (InStr(myItem.Body, "no such user") = 0) And _
            (InStr(myItem.Body, "bad address") = 0) And _
            (InStr(myItem.Body, "Host or domain name not found") = 0) And _
            (InStr(myItem.Body, "e-mail account does not exist") = 0) Then
                If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & "ERROR - NOT 550 OR Host or domain name not found MESSAGE." & vbCrLf
                myItem.UnRead = True
                intMsgCount_Error = intMsgCount_Error + 1
            Else
               
                'Extract email address from body
                intpos = InStr(myItem.Body, "@")
                If intpos = 0 Then
                    'No email address found
                    If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & "ERROR - NO EMAIL ADDRESS FOUND IN MESSAGE." & vbCrLf
                    myItem.UnRead = True
                    intMsgCount_Error = intMsgCount_Error + 1
                Else
                    'Get right of @
                    intpos_space = InStr(intpos, myItem.Body, " ")
                    intpos_bracket = InStr(intpos, myItem.Body, ">")
                    If (intpos_space < intpos_bracket) Or (intpos_bracket = 0) Then
                        intpos_temp = intpos_space
                    Else
                        intpos_temp = intpos_bracket
                    End If
                    strTemp = Left(myItem.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)
                    'Write to log
                    myMailItemLog.Body = myMailItemLog.Body & strTemp & vbCrLf
                    myItem.UnRead = False
                    intMessageCount = intMessageCount + 1
                End If
            End If
        End If
           
    Next
   
    'Done - write to log and show done message
    myMailItemLog.Body = myMailItemLog.Body & vbCrLf & Now() & " Done. Email addresses extracted: " & intMessageCount & ". Email addresses NOT extracted: " & intMsgCount_Error & "."
     myMailItemLog.Display
    MsgBox Now() & " Done. Email addresses extracted: " & intMessageCount & ". Email addresses NOT extracted: " & intMsgCount_Error & ".", vbInformation, "Done"


End Sub


Merci d'avance pour vore aide

2 réponses

Réponse 1 / 2
onlymusic Messages postés 11 Date d'inscription lundi 12 novembre 2007 Statut Membre Dernière intervention 11 décembre 2008
11 déc. 2008 à 14:17
Bonjour,

Essaye avec ca mais je ne trouve rien qui limite dans le code (qui au passage est plutot bien fait) :
Sub GetEmailFromBody()

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim mySelection As Selection
Dim myItem As Object
Dim myMailItemLog As Outlook.MailItem
Dim myFolder As Outlook.MAPIFolder

Dim strContactFolderName As String 'Directly under Public Folders\All Public Folders
Dim strNewsletterCategoryName As String
Dim strMailItemSender As String
Dim strMailTo As String
Dim intMessageCount As Integer
Dim bolDebug As Boolean 'If true no emails will be sent
Dim bolOnly10000 As Boolean 'Only extract email addresses that are 'user not found' (#10000) etc.
Dim strTemp As String

Set myNameSpace = myOlApp.GetNamespace("MAPI")

'Debug settings
bolDebug = True

'Ask to continue - start warning
intRes = MsgBox("This macro will go thru all items in folder." & vbCrLf & "Would like to extract only addresses that have 'user not found'?", vbYesNoCancel + vbQuestion, "Get Email from Body")
If intRes = vbCancel Then
Exit Sub
ElseIf intRes = vbYes Then
bolOnly10000 = True
Else
bolOnly10000 = False
End If

'Create a new email to use as log file
Set myMailItemLog = myOlApp.CreateItem(olMailItem)
myMailItemLog.Recipients.Add (myNameSpace.CurrentUser)
myMailItemLog.Subject = "Email from Body - " & Now()
myMailItemLog.BodyFormat = olFormatPlain
myMailItemLog.Body = Now() & " Starting..." & vbCrLf & vbCrLf

'Go thru all items in folder
intMessageCount = 0
intMsgCount_Error = 0
For Each myItem In myOlApp.ActiveExplorer.CurrentFolder.Items

If Not TypeName(myItem) "ReportItem" And Not TypeName(myItem) "MailItem" Then
'Errorlog
If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & "ERROR - MESSAGE TYPE IS NOT REPORTITEM OR MAILITEM." & vbCrLf
myItem.UnRead = True
intMsgCount_Error = intMsgCount_Error + 1
Else

'Check type is 10000 - user not found/inactive etc
'2007-03-27 removed 10004 error
If bolOnly10000 And _
(InStr(myItem.Body, "10000") = 0) And _
(InStr(myItem.Body, "unknown user") = 0) And _
(InStr(myItem.Body, "user unknown") = 0) And _
(InStr(myItem.Body, "no mailbox here by that name") = 0) And _
(InStr(myItem.Body, "no such user") = 0) And _
(InStr(myItem.Body, "bad address") = 0) And _
(InStr(myItem.Body, "Host or domain name not found") = 0) And _
(InStr(myItem.Body, "e-mail account does not exist") = 0) Then
If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & "ERROR - NOT 10000 OR Host or domain name not found MESSAGE." & vbCrLf
myItem.UnRead = True
intMsgCount_Error = intMsgCount_Error + 1
Else

'Extract email address from body
intpos = InStr(myItem.Body, "@")
If intpos = 0 Then
'No email address found
If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & "ERROR - NO EMAIL ADDRESS FOUND IN MESSAGE." & vbCrLf
myItem.UnRead = True
intMsgCount_Error = intMsgCount_Error + 1
Else
'Get right of @
intpos_space = InStr(intpos, myItem.Body, " ")
intpos_bracket = InStr(intpos, myItem.Body, ">")
If (intpos_space < intpos_bracket) Or (intpos_bracket = 0) Then
intpos_temp = intpos_space
Else
intpos_temp = intpos_bracket
End If
strTemp = Left(myItem.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)
'Write to log
myMailItemLog.Body = myMailItemLog.Body & strTemp & vbCrLf
myItem.UnRead = False
intMessageCount = intMessageCount + 1
End If
End If
End If

Next

'Done - write to log and show done message
myMailItemLog.Body = myMailItemLog.Body & vbCrLf & Now() & " Done. Email addresses extracted: " & intMessageCount & ". Email addresses NOT extracted: " & intMsgCount_Error & "."
myMailItemLog.Display
MsgBox Now() & " Done. Email addresses extracted: " & intMessageCount & ". Email addresses NOT extracted: " & intMsgCount_Error & ".", vbInformation, "Done"

End Sub

Redis moi
0
Réponse 2 / 2
dgfhierf Messages postés 5 Date d'inscription samedi 20 mai 2006 Statut Membre Dernière intervention 4 mars 2015
11 déc. 2008 à 16:15
Salut,

Merci pour ton aide mais apparemment ça change pas grand chose.
Personne n'aurait une ptite macro qui recupere les adresses mails dans les mails d'un dossier sous outlook?

merci d'avance
0
Rejoignez-nous