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: https://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