VBScript: Gather E-mail Addresses from an Exchange Mailbox

I recently sent out a newsletter to everyone who had any communicatoin with RealCajunRecipes.com. I had an Exchange Mailbox that collected all emails sent using the Tell-A-Friend feature of the website as well as the guestbook, ask maw-maw, and general website comments. I’d forgotten to automatically subscribe these users to the newsletter application and so I back tracked using this handy script.

Note: the name of the mailbox containing all of the emails is named RealCajunRecipes which is associated with the Active Directory account Chrissy theMayor. The SQL Server table which contained the newsletter subs is appropriately named newslettersubs.

'****************************************************************************
' This script created by Chrissy LeMaire ([email protected])
' Website: http://netnerds.net/
'
' NO WARRANTIES, etc.
'
' This script processes an Exchange mailbox for email addresses
' and adds them to a SQL Server table
'
' Requirements -- access to the Exchange mailbox and an SQL
' table
'
' This script has only been tested on Exchange Server 2003.
'
' "What it does"
' 1. Opens the Exchange profile "MS Exchange Profile"
' 2. Opens the mail store "Mailbox - Chrissy theMayor"
' 3. Opens the mailbox "RealCajunRecipes"
' 4. Iterates through the box collecting email addresses
' 5. Adds email to SQL table if it doesnt already exist
'
'*****************************************************************************

Const ConnString = "Provider=SQLOLEDB; Data Source=sql; Initial Catalog=realcajun;Trusted_Connection=yes;"

set oSession=CreateObject("MAPI.Session")
oSession.Logon "MS Exchange Profile"

Set objInfoStores = oSession.InfoStores 'hi my Name is bear
For i = 1 To objInfoStores.Count
    If objInfoStores.Item(i)= "Mailbox - Chrissy theMayor" Then
        Set objInfoStore = objInfoStores.Item(i)
         Set objRootFolder = objInfoStore.RootFolder

        ' Open the RealCajunRecipes folder
        Set objFolder = objRootFolder.Folders("RealCajunRecipes")
        set objMessages = objFolder.Messages

                   For j = 1 To objMessages.Count
                       Set omsg = objMessages.Item(j)
                       theEmail = omsg.Sender

                       If AdditBool(theEmail,Connstring) = True Then
                               Call Addit(theEmail,Connstring)
                   End if

                       For each recipient in omsg.recipients
                       If AdditBool(recipient,Connstring) = True Then
                          Call Addit(recipient,Connstring)
                   End if
                       Next
                    Next
        Exit For
    End If
Next

Function AdditBool(theEmail,theConnString)

                       If InStr(theEmail,"@") = 0 or InStr(theEmail,"netnerds") > 0 or InStr(theEmail,"mymomma") > 0 or InStr(theEmail,"'") > 0 Then
                           AdditBool = False
                           Exit Function
                End If

                 Set rsEmailCheck = CreateObject("adodb.recordset")
                       strSQL = "select id from newsletterSubs where email = '" & theEmail & "'"
                       rsEmailCheck.Open strSQL, theConnString, 1, 1
                           If rsEmailCheck.eof and rsEmailCheck.bof Then
                               AdditBool = True
                           Else
                               AdditBool = False
                               Exit Function
                           End If
                       rsEmailCheck.Close

                       strSQL = "select id from newsletterNoSubs where email = '" & theEmail & "'"
                       rsEmailCheck.Open strSQL, Connstring, 1, 1

                       If rsEmailCheck.eof and rsEmailCheck.bof Then
                               AdditBool = True
                           Else
                               AdditBool = False
                               Exit Function
                           End If
                       rsEmailCheck.Close
                       Set rsEmailCheck = Nothing
End Function

Sub Addit(theEmail,theConnString)
                   Set Conn = CreateObject("adodb.connection")
                      strSQL = "insert into newsletterSubs (email,dateAdded,ipaddr) values ('" & theEmail & "','5/24/2004','10.0.0.102')"
                       Conn.Open theConnString
                       Conn.execute StrSQL
                       Conn.close
                   Set Conn = Nothing
                   'MsgBox theEmail
End Sub

Chrissy is a PowerShell MVP who has worked in IT for nearly 20 years, and currently serves as a Sr. Database Engineer in Belgium. Always an avid scripter, she attended the Monad session at Microsoft’s Professional Developers Conference in Los Angeles back in 2005 and has worked and played with PowerShell ever since. Chrissy is currently pursuing an MS in Systems Engineering at Regis University and helps maintain RealCajunRecipes.com in her spare time. She holds a number of certifications, including those relating to SQL Server, SuSE Linux, SharePoint and network security. She recently became co-lead of the SQL PASS PowerShell Virtual Chapter. You can follow her on Twitter at @cl.

Posted in Exchange

Leave a Reply

Your email address will not be published. Required fields are marked *

*