VBScript: Gather E-mail Addresses from an Exchange Mailbox
I recently sent out a newsletter to everyone who had any communication 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 backtracked 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.
1' *************************************************
2' This script created by Chrissy LeMaire ([email protected])
3' Website: https://netnerds.net/
4'
5' NO WARRANTIES, etc.
6'
7' This script processes an Exchange mailbox for email addresses
8' and adds them to a SQL Server table
9'
10' Requirements -- access to the Exchange mailbox and an SQL
11' table
12'
13' This script has only been tested on Exchange Server 2003.
14'
15' "What it does"
16' 1. Opens the Exchange profile "MS Exchange Profile"
17' 2. Opens the mail store "Mailbox - Chrissy theMayor"
18' 3. Opens the mailbox "RealCajunRecipes"
19' 4. Iterates through the box collecting email addresses
20' 5. Adds email to SQL table if it doesnt already exist
21' *************************************************
22
23Const ConnString = "Provider=SQLOLEDB; Data Source=sql; Initial Catalog=realcajun;Trusted_Connection=yes;"
24
25set oSession = CreateObject("MAPI.Session")
26oSession.Logon "MS Exchange Profile"
27
28Set objInfoStores = oSession.InfoStores
29'hi my Name is bear
30For i = 1 To objInfoStores.Count
31 If objInfoStores.Item(i) = "Mailbox - Chrissy theMayor" Then
32 Set objInfoStore = objInfoStores.Item(i)
33 Set objRootFolder = objInfoStore.RootFolder
34
35 ' Open the RealCajunRecipes folder
36 Set objFolder = objRootFolder.Folders("RealCajunRecipes")
37 set objMessages = objFolder.Messages
38
39 For j = 1 To objMessages.Count
40 Set omsg = objMessages.Item(j)
41 theEmail = omsg.Sender
42
43 If AdditBool(theEmail, Connstring) = True Then
44 Call Addit(theEmail, Connstring)
45 End if
46
47 For each recipient in omsg.recipients
48 If AdditBool(recipient, Connstring) = True Then
49 Call Addit(recipient, Connstring)
50 End if
51 Next
52 Next
53
54 Exit For
55 End If
56Next
57
58Function AdditBool(theEmail, theConnString)
59
60If InStr(theEmail, "@") = 0 Or InStr(theEmail, "netnerds") > 0 Or InStr(theEmail, "mymomma") > 0 Or InStr(theEmail, "'") > 0 Then
61 AdditBool = False
62 Exit Function
63End If
64
65Set rsEmailCheck = CreateObject("adodb.recordset")
66strSQL = "select id from newsletterSubs where email = '" & theEmail & "'"
67rsEmailCheck.Open strSQL, theConnString, 1, 1
68If rsEmailCheck.eof And rsEmailCheck.bof Then
69 AdditBool = True
70Else
71 AdditBool = False
72 Exit Function
73End If
74rsEmailCheck.Close
75
76strSQL = "select id from newsletterNoSubs where email = '" & theEmail & "'"
77rsEmailCheck.Open strSQL, Connstring, 1, 1
78
79If rsEmailCheck.eof And rsEmailCheck.bof Then
80 AdditBool = True
81Else
82 AdditBool = False
83 Exit Function
84End If
85rsEmailCheck.Close
86Set rsEmailCheck = Nothing
87End Function
88
89Sub Addit(theEmail, theConnString)
90Set Conn = CreateObject("adodb.connection")
91strSQL = "insert into newsletterSubs (email,dateAdded,ipaddr) values ('" & theEmail & "','5/24/2004','10.0.0.102')"
92Conn.Open theConnString
93Conn.execute StrSQL
94Conn.close
95Set Conn = Nothing
96'MsgBox theEmail
97End Sub