Creating Exchange 2000/2003 Mailbox Rules programmatically via Rule.DLL - Microsoft Exchange

I've wrote a new version of script, that creates rule "Move Messages
with X-Spam-Flag: YES to Junk E-mail Folder".

Just set "strExchangeOrgDN" variable to yours, and save code in Unicode
format.

<=CUT=>
'============================================================================================================
'
' NAME: UnicodeCDOSpamRuleHeadersAllMailboxesInExchangeOrganization.vbs
' VERSION: 1.03
' AUTHOR: Alexander Dondokov
' DATE : 02/08/2006
'
' USAGE:
' 1) CScript //NoLogo
UnicodeCDOSpamRuleHeadersAllMailboxesInExchangeOrganization.vbs
' 2) CScript //NoLogo
UnicodeCDOSpamRuleHeadersAllMailboxesInExchangeOrganization.vbs >
LogFile.tsv
'
' COMMENTS: This VBS script creates Exchange Server Rule in the users
mailboxes gathered from Active Directory
' This script contains code written by:
' Robbie Allen
' Glen Scales
' Microsofts Script Center and Scripting Guy.
'
'============================================================================================================

On Error Resume Next

strJunkEmailFolderRUS = "Нежелательная почта"
strJunkEmailFolderENU = "Junk E-mail"
strSpamTag = "X-Spam-Flag: YES"
strSpamTagRule = "Move Messages with X-Spam-Flag: YES to Junk E-mail
Folder"
strErrRuleExists = "Rule already exists"
strErrRuleCreated = "Rule created"
strErrRuleNotCreated = "Rule not created"
strErrUserDisabled = "User is Hidden from GAL or Disabled"
strErrSystemMailbox = "System, SMTP or System Attendant Mailbox"
strErrMAPI = "MAPI Error Code "
strExchangeOrgDN = "CN=Microsoft
Exchange,CN=Services,CN=Configuration,DC=MYDOMAIN,DC=COM"

strFilter =
"(&(ObjectClass=msExchPrivateMDB)(ObjectCategory=msExchPrivateMDB));"
strAttrs = "homeMDBBL;"
strScope = "subtree"


Function FindStr(SearchString,SearchChar)
StrLengthSearchString = Len(SearchString)
StrLengthSearchChar = Len(SearchChar)
intPosition = Instr(1, SearchString, SearchChar, 1)
If intPosition >= 1 Then
FindStr = 1
Else
FindStr = 0
End If

If SearchString = "" Then
FindStr = 1
End If

End Function

Sub InsertJunkEmailRule(strDomainController, strMailAlias,
strSAMAccountName, strDistinguishedName)
Const ACTION_MOVE = 1
Const CdoPR_TRANSPORT_MESSAGE_HEADERS = &H7D001E
Const IGNORECASE = &H10000
Set objRules = CreateObject("MSExchange.Rules")
Set objRule = CreateObject("MSExchange.Rule")
Set objPropVal = CreateObject("MSExchange.PropertyValue")
Set objAction = CreateObject("MSExchange.Action")
Set objContCond = CreateObject("MSExchange.ContentCondition")
Set objSession = CreateObject("MAPI.Session")
strProfile = strDomainController & vbLf & strMailAlias
WScript.StdOut.Write(Date & vbTab & Time & vbTab & strDomainController
& vbTab & strMailAlias & vbTab & strSAMAccountName & vbTab &
strDistinguishedName & vbTab)
objSession.Logon "",,, False,, True, strProfile
Set objInbox = objSession.Inbox
Set CdoInfoStore = objSession.GetInfoStore
Set CdoFolderRoot = CdoInfoStore.RootFolder
Set CdoFolders = CdoFolderRoot.Folders
bFound = False
bRuleExist = False

Set CdoFolder = CdoFolders.GetFirst
Do While (Not bFound) And Not (CdoFolder Is Nothing)
If CdoFolder.Name = strJunkEmailFolderRUS or CdoFolder.Name =
strJunkEmailFolderENU Then
bFound = True
Else
Set CdoFolder = CdoFolders.GetNext
End If
Loop
Set ActionFolder = CdoFolder

objRules.Folder = objInbox
For Each EnumRule In objRules
If EnumRule.Name = strSpamTagRule Then
Wscript.Echo(strErrRuleNotCreated & vbTab & strErrRuleExists)
bRuleExist = True
End If
Next

If bRuleExist = False Then
' objRules.Folder = objInbox
' objPropVal.Tag = CdoPR_TRANSPORT_MESSAGE_HEADERS
' objPropVal.Value = strSpamTag
' objContCond.Value = objPropVal
' objContCond.PropertyType = CdoPR_TRANSPORT_MESSAGE_HEADERS
' objContCond.Operator = 1 + IGNORECASE
' objAction.ActionType = ACTION_MOVE
' objAction.Arg = ActionFolder
' objRule.Name = strSpamTagRule
' objRule.Condition = objContCond
' objRule.Actions.Add ,objAction
' objRules.add , objRule
' objRules.update
WScript.StdOut.Write(strErrRuleCreated & vbTab)
End If

objSession.Logoff

End Sub

Wscript.Echo("Date" & vbTab & "Time" & vbTab & "Domain Controller" &
vbTab & "Display Name" & vbTab & "SAM Account Name" & vbTab &
"Distinguished Name" & vbTab & "Result" & vbTab & "Error" & vbTab &
"Error Details")

StrBase = "<LDAP://" & strExchangeOrgDN & ">;"

set objConn = CreateObject("ADODB.Connection")
objConn.Provider = "ADsDSOObject"
objConn.Open "Active Directory Provider"
Set objRS = objConn.Execute(strBase & strFilter & strAttrs & strScope)
objRS.MoveFirst
while Not objRS.EOF
For Each objItem in objRS.Fields(0).Value
Set objItemUser = GetObject("LDAP://" & objItem)
strDomainController = "localhost"
strMailAlias = objItemUser.DisplayName
strMailNickName = objItemUser.MailNickName
strSAMAccountName = objItemUser.SAMAccountName
strDistinguishedName = objItemUser.DistinguishedName
'MailNickName

If FindStr(strMailAlias,"SystemMailbox") = 1 or
FindStr(strMailAlias,Null) = 1 Then
Wscript.Echo(Date & vbTab & Time & vbTab & strDomainController
& vbTab & strMailAlias & vbTab & strSAMAccountName & vbTab &
strDistinguishedName & vbTab & strErrRuleNotCreated & vbTab &
strErrSystemMailbox)
Else
If objItemUser.msExchHideFromAddressLists = "True" or
objItemUser.userAccountControl = "514" Then
Wscript.Echo(Date & vbTab & Time & vbTab & strDomainController
& vbTab & strMailAlias & vbTab & strSAMAccountName & vbTab &
strDistinguishedName & vbTab & strErrRuleNotCreated & vbTab &
strErrUserDisabled)
Else
InsertJunkEmailRule strDomainController, strMailAlias,
strSAMAccountName, strDistinguishedName
'WScript.Echo(strErrMAPI & CStr(Err.Number) & vbTab &
Err.Description)
'Err.Clear
If CStr(Err.Number) <> "0" Then
WScript.Echo(strErrRuleNotCreated & vbTab & strErrMAPI &
CStr(Err.Number) & vbTab & Err.Description)
Err.Clear
Else
WScript.Echo(strErrMAPI & CStr(Err.Number) & vbTab &
Err.Description)
Err.Clear
End If

End If
End If

Next
objRS.MoveNext
wend



Set objRules = Nothing
Set objRule = Nothing
Set objPropVal = Nothing
Set objAction = Nothing
Set objContCond = Nothing
Set objSession = Nothing
Set strSpamTag = Nothing
Set strSpamTagRule = Nothing
Set strDomainController = Nothing
Set strMailAlias = Nothing
Set strProfile = Nothing
Set strErrRuleExists = Nothing
Set strErrRuleCreated = Nothing
Set objInbox = Nothing
Set CdoInfoStore = Nothing
Set CdoFolderRoot = Nothing
Set CdoFolders = Nothing
Set bFound = Nothing
Set bRuleExist = Nothing
Set EnumRule = Nothing
Set strJunkEmailFolderENU = Nothing
Set strJunkEmailFolderRUS = Nothing

Set StrBase = Nothing
Set strFilter = Nothing
Set strAttrs = Nothing
Set strScope = Nothing
Set objConn = Nothing
Set objRS = Nothing
Set objItem = Nothing
Set objItemUser = Nothing
Set strDomainController = Nothing
Set strMailAlias = Nothing
Set strErrMAPI = Nothing
Set strExchangeOrgDN = Nothing

Wscript.Quit

<=CUT=>


P.S. My question about CDO window, that contains promt to choose user
account is still open, can somebody help me with this ???
Thnaks.

You usually get this popup when your not using the right mailbox alias eg if
you are using the logonname and the logonname and the mailbox alias are
different (in the case someone has renamed the account or for some other
reason). You can easliy get rid of the dialouge by setting the showDialog
parameter in the Logon method to false (this is the 3rd parameter in the
method) at the moment in your code this blank and the default is true. eg I
would use

objSession.Logon "","",false,false,,true,strProfile


Once you get rid of the dialouge you may find this is replaced with a
MAPI_E_LOGON_FAILED(80040111) error if the alias is not correct so you might
want to consider using mailNickname Ad property as the alias in your script.
(there's a good referance for the logon method
http://www.vbip.com/books/1861002068...er_2068_04.asp )

Cheers
Glen




"ncuxa.NET" <Alexander.Dondokov@gmail.com> wrote in message
news:1154523208.436943.202570@i3g2000cwc.googlegroups.com...
I've wrote a new version of script, that creates rule "Move Messages
with X-Spam-Flag: YES to Junk E-mail Folder".

Just set "strExchangeOrgDN" variable to yours, and save code in Unicode
format.

<=CUT=>
'============================================================================================================
'
' NAME: UnicodeCDOSpamRuleHeadersAllMailboxesInExchangeOrganization.vbs
' VERSION: 1.03
' AUTHOR: Alexander Dondokov
' DATE : 02/08/2006
'
' USAGE:
' 1) CScript //NoLogo
UnicodeCDOSpamRuleHeadersAllMailboxesInExchangeOrganization.vbs
' 2) CScript //NoLogo
UnicodeCDOSpamRuleHeadersAllMailboxesInExchangeOrganization.vbs >
LogFile.tsv
'
' COMMENTS: This VBS script creates Exchange Server Rule in the users
mailboxes gathered from Active Directory
' This script contains code written by:
' Robbie Allen
' Glen Scales
' Microsofts Script Center and Scripting Guy.
'
'============================================================================================================

On Error Resume Next

strJunkEmailFolderRUS = "????????????? ?????"
strJunkEmailFolderENU = "Junk E-mail"
strSpamTag = "X-Spam-Flag: YES"
strSpamTagRule = "Move Messages with X-Spam-Flag: YES to Junk E-mail
Folder"
strErrRuleExists = "Rule already exists"
strErrRuleCreated = "Rule created"
strErrRuleNotCreated = "Rule not created"
strErrUserDisabled = "User is Hidden from GAL or Disabled"
strErrSystemMailbox = "System, SMTP or System Attendant Mailbox"
strErrMAPI = "MAPI Error Code "
strExchangeOrgDN = "CN=Microsoft
Exchange,CN=Services,CN=Configuration,DC=MYDOMAIN,DC=COM"

strFilter =
"(&(ObjectClass=msExchPrivateMDB)(ObjectCategory=msExchPrivateMDB));"
strAttrs = "homeMDBBL;"
strScope = "subtree"


Function FindStr(SearchString,SearchChar)
StrLengthSearchString = Len(SearchString)
StrLengthSearchChar = Len(SearchChar)
intPosition = Instr(1, SearchString, SearchChar, 1)
If intPosition >= 1 Then
FindStr = 1
Else
FindStr = 0
End If

If SearchString = "" Then
FindStr = 1
End If

End Function

Sub InsertJunkEmailRule(strDomainController, strMailAlias,
strSAMAccountName, strDistinguishedName)
Const ACTION_MOVE = 1
Const CdoPR_TRANSPORT_MESSAGE_HEADERS = &H7D001E
Const IGNORECASE = &H10000
Set objRules = CreateObject("MSExchange.Rules")
Set objRule = CreateObject("MSExchange.Rule")
Set objPropVal = CreateObject("MSExchange.PropertyValue")
Set objAction = CreateObject("MSExchange.Action")
Set objContCond = CreateObject("MSExchange.ContentCondition")
Set objSession = CreateObject("MAPI.Session")
strProfile = strDomainController & vbLf & strMailAlias
WScript.StdOut.Write(Date & vbTab & Time & vbTab & strDomainController
& vbTab & strMailAlias & vbTab & strSAMAccountName & vbTab &
strDistinguishedName & vbTab)
objSession.Logon "",,, False,, True, strProfile
Set objInbox = objSession.Inbox
Set CdoInfoStore = objSession.GetInfoStore
Set CdoFolderRoot = CdoInfoStore.RootFolder
Set CdoFolders = CdoFolderRoot.Folders
bFound = False
bRuleExist = False

Set CdoFolder = CdoFolders.GetFirst
Do While (Not bFound) And Not (CdoFolder Is Nothing)
If CdoFolder.Name = strJunkEmailFolderRUS or CdoFolder.Name =
strJunkEmailFolderENU Then
bFound = True
Else
Set CdoFolder = CdoFolders.GetNext
End If
Loop
Set ActionFolder = CdoFolder

objRules.Folder = objInbox
For Each EnumRule In objRules
If EnumRule.Name = strSpamTagRule Then
Wscript.Echo(strErrRuleNotCreated & vbTab & strErrRuleExists)
bRuleExist = True
End If
Next

If bRuleExist = False Then
' objRules.Folder = objInbox
' objPropVal.Tag = CdoPR_TRANSPORT_MESSAGE_HEADERS
' objPropVal.Value = strSpamTag
' objContCond.Value = objPropVal
' objContCond.PropertyType = CdoPR_TRANSPORT_MESSAGE_HEADERS
' objContCond.Operator = 1 + IGNORECASE
' objAction.ActionType = ACTION_MOVE
' objAction.Arg = ActionFolder
' objRule.Name = strSpamTagRule
' objRule.Condition = objContCond
' objRule.Actions.Add ,objAction
' objRules.add , objRule
' objRules.update
WScript.StdOut.Write(strErrRuleCreated & vbTab)
End If

objSession.Logoff

End Sub

Wscript.Echo("Date" & vbTab & "Time" & vbTab & "Domain Controller" &
vbTab & "Display Name" & vbTab & "SAM Account Name" & vbTab &
"Distinguished Name" & vbTab & "Result" & vbTab & "Error" & vbTab &
"Error Details")

StrBase = "<LDAP://" & strExchangeOrgDN & ">;"

set objConn = CreateObject("ADODB.Connection")
objConn.Provider = "ADsDSOObject"
objConn.Open "Active Directory Provider"
Set objRS = objConn.Execute(strBase & strFilter & strAttrs & strScope)
objRS.MoveFirst
while Not objRS.EOF
For Each objItem in objRS.Fields(0).Value
Set objItemUser = GetObject("LDAP://" & objItem)
strDomainController = "localhost"
strMailAlias = objItemUser.DisplayName
strMailNickName = objItemUser.MailNickName
strSAMAccountName = objItemUser.SAMAccountName
strDistinguishedName = objItemUser.DistinguishedName
'MailNickName

If FindStr(strMailAlias,"SystemMailbox") = 1 or
FindStr(strMailAlias,Null) = 1 Then
Wscript.Echo(Date & vbTab & Time & vbTab & strDomainController
& vbTab & strMailAlias & vbTab & strSAMAccountName & vbTab &
strDistinguishedName & vbTab & strErrRuleNotCreated & vbTab &
strErrSystemMailbox)
Else
If objItemUser.msExchHideFromAddressLists = "True" or
objItemUser.userAccountControl = "514" Then
Wscript.Echo(Date & vbTab & Time & vbTab & strDomainController
& vbTab & strMailAlias & vbTab & strSAMAccountName & vbTab &
strDistinguishedName & vbTab & strErrRuleNotCreated & vbTab &
strErrUserDisabled)
Else
InsertJunkEmailRule strDomainController, strMailAlias,
strSAMAccountName, strDistinguishedName
'WScript.Echo(strErrMAPI & CStr(Err.Number) & vbTab &
Err.Description)
'Err.Clear
If CStr(Err.Number) <> "0" Then
WScript.Echo(strErrRuleNotCreated & vbTab & strErrMAPI &
CStr(Err.Number) & vbTab & Err.Description)
Err.Clear
Else
WScript.Echo(strErrMAPI & CStr(Err.Number) & vbTab &
Err.Description)
Err.Clear
End If

End If
End If

Next
objRS.MoveNext
wend



Set objRules = Nothing
Set objRule = Nothing
Set objPropVal = Nothing
Set objAction = Nothing
Set objContCond = Nothing
Set objSession = Nothing
Set strSpamTag = Nothing
Set strSpamTagRule = Nothing
Set strDomainController = Nothing
Set strMailAlias = Nothing
Set strProfile = Nothing
Set strErrRuleExists = Nothing
Set strErrRuleCreated = Nothing
Set objInbox = Nothing
Set CdoInfoStore = Nothing
Set CdoFolderRoot = Nothing
Set CdoFolders = Nothing
Set bFound = Nothing
Set bRuleExist = Nothing
Set EnumRule = Nothing
Set strJunkEmailFolderENU = Nothing
Set strJunkEmailFolderRUS = Nothing

Set StrBase = Nothing
Set strFilter = Nothing
Set strAttrs = Nothing
Set strScope = Nothing
Set objConn = Nothing
Set objRS = Nothing
Set objItem = Nothing
Set objItemUser = Nothing
Set strDomainController = Nothing
Set strMailAlias = Nothing
Set strErrMAPI = Nothing
Set strExchangeOrgDN = Nothing

Wscript.Quit

<=CUT=>


P.S. My question about CDO window, that contains promt to choose user
account is still open, can somebody help me with this ???
Thnaks.

Thanks, Glen.
I've tried to use strMailNickName, e.g.:
InsertJunkEmailRule strDomainController, strMailNickName,
strSAMAccountName, strDistinguishedName
And set ShowDialog to False, e.g.:
objSession.Logon "","",False,False,,True,strProfile
But, when I started to ****yze the output, generated by script, I got
more "The information store could not be opened. [MAPI 1.0 -
[MAPI_E_LOGON_FAILED(80040111)]]" errors, because MailNickName
attributes for few users are almost equal, e.g.:
User1: Ivan Ivanov; mailnNickName: Ivanov
User2: Peter Ivanov; mailnNickName: IvanovP
User4: Nataly Ivanova; mailnNickName: Ivanova

Variant 1: When script tries to resolve User1 (and ShowDialog set to
True in objSession.Logon), popup window appears with three users
resolved in GAL, and you must manually choose the right user account.

Variant 2: When script tries to resolve User1 (and ShowDialog set to
False in objSession.Logon), popup window doesn't appear with three
users resolved in GAL, and we've got error 80040111, because no one is
choosen.

As I understood, I have to change mailNickName attribute to be unique?

P.S. When I'm using DisplayName attribute in strProfile, i got less
errors 80040111, because users names are different.

Okay I see your problem what about using the email address this shouldn't be
ambiguous and it should work simular to the other attributes.

Cheers
Glen

"ncuxa.NET" <Alexander.Dondokov@gmail.com> wrote in message
news:1154685099.853976.160260@h48g2000cwc.googlegroups.com...
> Thanks, Glen.
> I've tried to use strMailNickName, e.g.:
> InsertJunkEmailRule strDomainController, strMailNickName,
> strSAMAccountName, strDistinguishedName
> And set ShowDialog to False, e.g.:
> objSession.Logon "","",False,False,,True,strProfile
> But, when I started to ****yze the output, generated by script, I got
> more "The information store could not be opened. [MAPI 1.0 -
> [MAPI_E_LOGON_FAILED(80040111)]]" errors, because MailNickName
> attributes for few users are almost equal, e.g.:
> User1: Ivan Ivanov; mailnNickName: Ivanov
> User2: Peter Ivanov; mailnNickName: IvanovP
> User4: Nataly Ivanova; mailnNickName: Ivanova
>
> Variant 1: When script tries to resolve User1 (and ShowDialog set to
> True in objSession.Logon), popup window appears with three users
> resolved in GAL, and you must manually choose the right user account.
>
> Variant 2: When script tries to resolve User1 (and ShowDialog set to
> False in objSession.Logon), popup window doesn't appear with three
> users resolved in GAL, and we've got error 80040111, because no one is
> choosen.
>
> As I understood, I have to change mailNickName attribute to be unique?
>
> P.S. When I'm using DisplayName attribute in strProfile, i got less
> errors 80040111, because users names are different.
>

Thank You VERY MUCH !!!
I've changed strMailAlias = objItemUser.DisplayName -> strMailAlias =
objItemUser.Mail, and it works great.
No more "[MAPI 1.0 - [MAPI_E_LOGON_FAILED(80040111)]]" Errors

Glen Scales [MVP] wrote:
> Okay I see your problem what about using the email address this shouldn't be
> ambiguous and it should work simular to the other attributes.
>
> Cheers
> Glen