Updating recipient maps from Exchange 2003

[wgrabski]

Here's a vbs script I (mostly) wrote that updates recipient maps for your domain. There is no way to 'query' the status of a map... as far as I know, so I just submit all the addresses each time. Some slight modifications might be necessary as I just moved variables out to the header during the posting of this message.


Cheers.

-----

Dim rootDSE, domainObject
dim nemail
dim Result
dim key,resultsfile,mydomain,username

resultsfile="C:\Program Files\Exchsrvr\last_map_results.csv"
key="123456"
mydomain="mydomain.com"
username="username"


Set rootDSE=GetObject("LDAP://RootDSE")
domainContainer = rootDSE.Get("defaultNamingContext")
Set domainObject = GetObject("LDAP://" & domainContainer)


Set fs = CreateObject ("Scripting.FileSystemObject")
Set userFile = fs.CreateTextFile (resultsfile)

ExportUsers(domainObject)

Sub ExportUsers(oObject)
Dim oUser
For Each oUser in oObject
Select Case oUser.Class
Case "user"
If oUser.mail <> "" then
'userFile.Write oUser.sAMAccountName
for each email in oUser.proxyAddresses
if (InStr(email, mydomain)>0) then
nemail = Right(CStr(email), len(cstr(email)) - 5)
if AddAddress(nemail) then
userFile.write nemail & ",ADDED"
userFile.WriteLine ""
WScript.echo nemail & "... OK"
else
userFile.write nemail & ",EXISTS"
userFile.WriteLine ""
WScript.echo nemail & "... EXISTS"
end if
end if
next
End if
Case "group"
If oUser.mail <> "" then
'userFile.Write oUser.sAMAccountName
for each email in oUser.proxyAddresses
if (InStr(email, mydomain)>0) then
nemail = Right(CStr(email), len(cstr(email)) - 5)
if AddAddress(nemail) then
userFile.write nemail & ",ADDED"
userFile.WriteLine ""
WScript.echo nemail & "... OK"
else
userFile.write nemail & ",EXISTS"
userFile.WriteLine ""
WScript.echo nemail & "... EXISTS"
end if
end if
next
End if
Case "organizationalUnit" , "container"
If UsersinOU (oUser) then
ExportUsers(oUser)
End if
End select
Next
End Sub

Function UsersinOU (oObject)
Dim oUser
UsersinOU = False
for Each oUser in oObject
Select Case oUser.Class
Case "organizationalUnit" , "container"
UsersinOU = UsersinOU(oUser)
Case "user"
UsersinOU = True

End select
Next
End Function

Function AddAddress(email)
dim URL

URL = "https://acc.rollernet.us/api/api.php?u="&username&"&k=" & key &"&m=rmap&a=add&d=" & email

Set WshShell = WScript.CreateObject("WScript.Shell")

Set http = CreateObject("Microsoft.XmlHttp")
http.open "GET", URL, FALSE
http.send ""
IF InStr(http.responseText, "OK") > 0 then
set WshShell = nothing
set http = nothing
AddAddress = True
Else
set WshShell = nothing
set http = nothing
AddAddress = False
End if

End Function