1 - Setup a new email account to store all bounced emails.
2 - Designate the bounce-back email to a dedicated email address. For easy handling, I set a custom header in the email to store the email address to track.
e.g. x-MyCustomHdr =
3 - Create a script to parse this mailbox, and save the email address to a database table. This script comes with an INI file. Credits to http://www.westphil.nl/systemadministration/vbscript/index.php?name=mailread for the original source code.
Pre-requisites:
Since Outlook 2007, Microsoft no longer bundles the MAPI.Session ActiveX object. This component needs to be installed on the machine. The component can be downloaded from Microsoft: http://www.microsoft.com/download/en/details.aspx?DisplayLang=en&id=3671
The solution is only 32bit compatible.
Outlook needs to be installed on the machine.
This is a script to parse an Outlook account, and save the email address to database.
'On Error Resume next
Dim objSession
Dim objIs
Dim objFldSource
Dim objFldDestination
Dim objMessage
Dim objAttachment
Dim ivalue
Dim strSubj, strBody, strEmail
Dim strConn, objConn
strIniFile = "MailRead.ini"
strSection = "Config"
strMapiProfile = ReadINI(strINIFile, strSection, "MapiProfile")
strMailBox = ReadINI(strINIFile, strSection, "MailBox")
strKey = ReadINI(strINIFile, strSection, "MailHeader")
strConn = "Driver={SQL Server};Data Source=XXXXXXX;Database=XXXXXXXX;UID=XXXXXXXXXX;PWD=XXXXXXXXXXXXXX;"
set objConn = CreateObject("ADODB.Connection")
objConn.open strConn
' Logon
Set objSession = CreateObject("MAPI.Session")
Call objSession.Logon(strMapiProfile)
Wscript.echo "Log on to profile : " & strMapiProfile
' Get Mailbox
Set objIs = objSession.InfoStores(strMailBox)
Wscript.echo "Logged on to Mailbox : " & objIs.name
' Get Root folder, inbox and deleted items
Set objFldSource = objIs.RootFolder
'Wscript.echo objFldSource.Folders.Count
For Each objF in objFldSource.Folders
If objF.Name = "Inbox" Then
Set objFldSource = objF
End If
If objF.Name = "Deleted Items" Then
Set objFldDestination = objF
End If
'WScript.Echo objF.Name
Next
' Loop through messages.
With objFldSource.Messages
For Index = .Count To 1 Step -1
With .Item(Index)
' Process the message.
Set objMessage = objFldSource.Messages(Index)
strSubj = objMessage.Subject
strBody = objMessage.Text
Wscript.Echo strSubj
' Get the original email
arrLines = Split(strBody,vbCrLf)
strEmail = ""
Wscript.echo "Attempting to parse " & strKey
For Each strLine in arrLines
If UCase(Left(strLine, Len(strKey) + 1)) = UCase(strKey & ":") Then
strEmail = Mid(strLine, InStr(strLine, ": ") + 1)
Wscript.Echo strEmail
Exit For
End If
Next
UpdateInvalidEmail objConn, strEmail, strSubj
' Move the message.
Call .MoveTo(objFldDestination.ID)
End With
Next
End With
Wscript.Echo "Finised parsing mailbox."
objConn.Close
Set objConn = Nothing
' Uitloggen.
Call objSession.Logoff
Set objSession = Nothing
Function ReadINI(strINIFile, strSection, strKey)
Dim objFSO, objTextFile, strLine
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(strINIFile)
'loop through each line and check for key value
Do While Not objTextFile.AtEndOfStream
strLine = objTextFile.ReadLine
'wscript.echo strLine
If UCase(strLine) = UCase("[" & strSection & "]") Then
Do While Not objTextFile.AtEndOfStream
strLine = objTextFile.ReadLine
If UCase(Left(strLine, Len(strKey) + 1)) = _
UCase(strKey & "=") Then
ReadINI = Mid(strLine, InStr(strLine, "=") + 1)
Exit do
End If
Loop
Exit Do
End If
Loop
objTextFile.Close
End Function
Sub UpdateInvalidEmail(objConn, email, subject)
If Len(email) > 50 Then email = Left(email, 50)
If Len(subject) > 500 Then subject = Left(subject, 500)
email = Replace(email, "'", "''")
subject = Replace(subject, "'", "''")
objConn.Execute "sp_UpdateInvalidEmails '" & email & "', '" & subject & "'"
End Sub
MailRead.ini
[Config] ;name of outlook profile to use MapiProfile=Default Outlook Profile ;Name of mailbox as it appears in outlook MailBox=Mailbox - Sender Name ;Any special extra headers MailHeader=x-MyCustomHdr
