'BES license usage monitor.  Set current license total, alert threshold, And
'other variables to be notified when the license usage exceeds the threshold.
Dim strSQLServer, strBESDB, iCurrentLicenseTotal, iLicenseThreshold
Dim strMailRecipients, strMailSender, strMailSubject, strMailServer
'*************************************
'------Configurable Variables---------
iCurrentLicenseTotal = 1000 'Total number of licenses in License Management
iLicenseThreshold = 20 'Free licenses threshold for notification
strSQLServer = "ServerName" 'NetBIOS name of SQL Server
strBESDB = "DatabaseName" 'Database name in SQL
'------Notification configuration-----
strMailRecipients = "user1@domain.com,user2@domain.com" 'Command-separated list of addresses
strMailSender = "BESLicenseCounter@domain.com" 'From address
strMailSubject = "BES license usage at critical level" 'Subject of notification message
strMailServer = "smtpserver.domain.com" 'FQDN of smarthost
'*************************************

Dim iCurrentUserTotal, iAvailableLicenses, strSQLQuery, strSQLConn
Dim objSQLConn, objSQLRecordSet, objSQLExec
strSQLConn = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Data Source=" & _
	strSQLServer & "; Initial Catalog=" & strBESDB
strSQLQuery = "Select Count(*) As Total_Users From UserStats"
Set objSQLConn = CreateObject("ADODB.Connection")
Set objSQLRecordSet = CreateObject("ADODB.Recordset")
objSQLConn.Open = strSQLConn
objSQLRecordSet.Open strSQLQuery, objSQLConn
Set objSQLExec = objSQLRecordSet
While Not objSQLExec.EOF
	iCurrentUserTotal = objSQLExec.Fields("Total_Users").Value
	objSQLExec.MoveNext
Wend
iAvailableLicenses = iCurrentLicenseTotal - iCurrentUserTotal
If iAvailableLicenses < iLicenseThreshold Then
	Dim strMailBody
	strMailBody = iCurrentUserTotal & " of " & iCurrentLicenseTotal & " licenses are in use."
	strMailBody = strMailBody & "  It is time to order more licenses."
	SendMail
End If

Sub SendMail
	Set objEmail = CreateObject("CDO.Message")
	objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
	objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strMailServer
	objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
	objEmail.Configuration.Fields.Update
	objEmail.From = strMailSender
	objEmail.To = strMailRecipients
	objEmail.Subject = strMailSubject
	objEmail.HTMLBody = strMailBody
	objEmail.Send
End Sub

Microsoft KB 899663 instructs how to manually transpose GUID into a format that can be used in an LDAP filter so that you can search for a match.  Why do all this by hand when a script can do it for you?  I took an existing script I had that already does the transposition and added an AD search to return the matching dn.  The dn is passed to a name translation function that converts the dn to the NT4 format (domain\username) and displays the match with username and display name.

In addition to the VBScript file, I have also included a compiled version that uses SAPIEN Script Host as the engine.  This is a self-contained, runs-in-memory-only, no-DOS-box-comes-up engine from PrimalScript.  Running the compiled version is nice since you don’t have to ensure that CScript is the default host and no DOS box appears while the script is running.

The zip file with both versions is available here .

It was easy enough to extract the LDAP filter from the attribute, convert it to a string value, and display it.  But users don’t generally know how to read LDAP filters, let alone represented as a long line of text.  So I started looking for utilities or scripts that would take an LDAP filter, parse it, and display it with nesting.  Uh, yeah, there aren’t any.  I was determined, and so countless hours later I have a function that do such a thing.

The difficult part was keeping track of the level of nesting/indentation at any point. Since a filter can be written in almost any order as long as the resulting equation equals what you want, I couldn’t use any kind of static detection. Just because an open parentheses is following by another one doesn’t mean that you are, say, three levels nested. So the important part of the script keeps track of the indentation level as the cursor position moves through the filter.

I replace ampersands in the filter with crosshatches while working with it because I was having weird results otherwise, most likely because the ampersand is an operator in both LDAP and VBScript. And because the output is to an IE window and the indentation uses non-breaking spaces instead of the traditional tab (which doesn’t exist in HTML), I substitute the HTML string for a non-breaking space with a unique string of letters so the ampersand in that doesn’t get in the way.

Because this is part of a bigger script, I pulled out just the portion that formats the LDAP filter and displays it in an IE window. You just need to provide the "raw" filter, whether directly in the script or some other method. Copy and paste the code below or download it here.

Option Explicit
Dim strLDAPFilter, strFormattedFilter
Dim objIE, objDoc
strLDAPFilter = "YourLDAPFilter"
Set objIE =  CreateObject("InternetExplorer.Application")   objIE.AddressBar = False
objIE.Menubar = False
objIE.Toolbar = False
objIE.Resizable = True
objIE.Height = 450
objIE.Width = 700
objIE.Visible = True
objIE.Navigate("about:blank")
While objIE.Busy
	WScript.Sleep 100
Wend

Set objDoc = objIE.Document
objDoc.Open
objDoc.Write("<TITLE>LDAP Filter Display</TITLE>")
objDoc.Write("<BODY BGCOLOR=#C0C0C0>")

'Parse the LDAP filter and format results for display
'Apply nesting for readability
strFormattedFilter = FormatLDAPDisplay(strLDAPFilter)
objDoc.Write(strFormattedFilter)
'Format single-line LDAP filter to include nesting
Function FormatLDAPDisplay(strLDAPFilter)
	'Replace ampersands with crosshatches to keep them from interfering
	strLDAPFilter = Replace(strLDAPFilter, Chr(38), Chr(35))

	'Iterate through each character in filter and insert CRLF and nesting
	Dim intPos, intIndentCount, intWhileIndent
	Dim strIndentation, strInsert, strCharacter, strNewLDAPFilter
	Dim bolDblClose
	intPos = 1
	intIndentCount = 0
	Do While intPos < Len(strLDAPFilter)
		strCharacter = Mid(strLDAPFilter, intPos, 1)
		intWhileIndent = 1
		strIndentation = ""
		Select Case strCharacter
			'LDAP operators to watch for to modify nesting level.
			'NOT operator ignored because only used in one-off attribute value
			Case Chr(35), Chr(124)
				'Operator followed by open paren means nesting increase
				If Mid(strLDAPFilter, intPos + 1, 1) = Chr(40) Then
					intIndentCount = intIndentCount + 1
					'Build nest based on number of indentations
					Do While intWhileIndent <= intIndentCount
						'Use unique string as placeholder for nesting with HTML spaces
						strIndentation = strIndentation & "QZNBSPQZNBSPQZNBSPQZNBSP"
						intWhileIndent = intWhileIndent + 1
					Loop
					'Insert new string for formatting
					strNewLDAPFilter = Replace(strLDAPFilter, strCharacter, strCharacter & "<br>" & strIndentation, intPos, 1)
					'Restore full filter including new string
					strLDAPFilter = Left(strLDAPFilter, intPos - 1) & strNewLDAPFilter
					'Move current position to next character after inserted string
					intPos = intPos + Len(strIndentation) + 6
				Else
					intPos = intPos + 1
				End If
			Case Chr(40)
				Do While intWhileIndent <= intIndentCount
					strIndentation = "QZNBSPQZNBSPQZNBSPQZNBSP" & strIndentation
					intWhileIndent = intWhileIndent + 1
				Loop
				If Not strIndentation = "" Then
					'If open paren follows close paren, insert CRLF
					If Mid(strLDAPFilter, intPos - 1, 1) = Chr(41) Then
						strIndentation = strIndentation & "<br>"
					End If
					strNewLDAPFilter = Replace(strLDAPFilter, strCharacter, strIndentation & strCharacter, intPos, 1)
					strLDAPFilter = Left(strLDAPFilter, intPos - 1) & strNewLDAPFilter
					intPos = intPos + Len(strIndentation) +1
				Else
					intPos = intPos + 1
				End If
			Case Chr(41)
				'Two consecutive close paren means nesting reduces one level
				If Mid(strLDAPFilter, intPos + 1, 1) = Chr(41) Then
					intIndentCount = intIndentCount - 1
					bolDblClose = True
				End If
				Do While intWhileIndent <= intIndentCount
					strIndentation = strIndentation & "QZNBSPQZNBSPQZNBSPQZNBSP"
					intWhileIndent = intWhileIndent + 1
				Loop
				strNewLDAPFilter = Replace(strLDAPFilter, strCharacter, strCharacter & "<br>" & strIndentation, intPos, 1)
				strLDAPFilter = Left(strLDAPFilter, intPos - 1) & strNewLDAPFilter
				'Adjust position to account for two close paren
				If bolDblClose = True Then
					intPos = intPos + Len(strIndentation) + 5
					bolDblClose = Empty
				Else
					intPos = intPos + Len(strIndentation) + 6
				End If
			Case Else
				'No paren or operator means move to next character
				intPos = intPos + 1
		End Select
	Loop

	'Replace LDAP operators with words
	strLDAPFilter = Replace(strLDAPFilter, Chr(35), "<i>AND</i>")
	strLDAPFilter = Replace(strLDAPFilter, Chr(124), "<i>OR</i>")
	strLDAPFilter = Replace(strLDAPFilter, Chr(33), "<i>NOT </i>")
	'Replace spaceholders with HTML spaces
	strLDAPFilter = Replace(strLDAPFilter, "QZNBSP", Chr(38) & "nbsp;")
	FormatLDAPDisplay = strLDAPFilter
End Function

Set objIE = Nothing

To do this, add this subroutine to the end of functions.asp, which is the CDO code to send a message.  I didn’t use variables that are assigned in config.asp, so you will have to set them in the subroutine directly for SMTP server, from address, to address, and domain name in the body. 

<%
'Send comment notification
Sub SendEmail (strBDate, strBID)
	Dim objMail
	Set objMail = CreateObject("CDO.Message")
	objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing")      = 2
	objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver")     = "SMTP hostname"
	objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
	objMail.Configuration.Fields.Update
	objMail.From     = "fromaddress@yourdomain.com"
	objMail.To       = "toaddress@yourdomain.com"
	objMail.Subject  = "Comment has been submitted for approval"   
	objMail.HTMLBody = "A comment has been submitted for approval.  Go to http://www.yourdomain.com/admin?cmd=bloglist&view=calendar&blogDate=" & strBDate & "&comments=" & strBID & " to approve."
	objMail.Send
	Set objMail = Nothing
End Sub
%>

Then you need to add code to functions.asp to call this subroutine from the subroutine that inserts the comment.  Find the subroutine labeled InsertComment(), which should be around line 475 depending on other mods of mine or your own that you may have inserted.  Right before the existing line: 

Response.Redirect("default.asp?view=plink&id=" & bID & "&comments=1")

insert this code:

' convert blog ID to blog Date
strSQL = "SELECT * FROM  T_WEBLOG WHERE id = " & bID & " ORDER BY id DESC"
Set Rs = Server.CreateObject("ADODB.Recordset")
Rs.ActiveConnection = strConn
Rs.Source = strSQL
Rs.CursorType = 0
Rs.CursorLocation = 2
Rs.LockType = 1
Rs.Open()

If Not rs.EOF Then
	rs.MoveFirst
	While Not rs.EOF
		strBDate = rs("b_date")
		rs.MoveNext
	Wend
End If

SendEmail strBDate, bID

This is necessary because the comments are not accessed by using the blog entry ID, but the blog entry’s date.  So it is necessary to cross-reference the entry ID to the entry date, and then link to the comments for a given entry ID on that date.  The last line calls the email function which will include a hyperlink to the comments for the blog entry that has a new comment.

Now, that is all fine and dandy.  You will receive the email with the link, but when you follow it to your site, you probably won’t have an active session so you will have to log in.  The way the admin default and login pages work, you will lose the link to the entry you need to approve so you have to click the link in the email again.  I work around this by implementing the use of query strings so the site remembers where you were trying to go before you had to log in.

To add this feature, edit admindefault.asp.  At line 8, replace the Response.Redirect line with the following code: 

Dim sProtocol, sDomain, sPath, sQuerystring, sResult
sProtocol = "http://"
If UCase(Request.ServerVariables("HTTPS")) = "ON" Then
	sProtocol = "https://"
	sDomain = LCase(Request.ServerVariables("SERVER_NAME"))
	sPath = LCase(Request.ServerVariables("SCRIPT_NAME"))
	sQuerystring = LCase(Request.Querystring)
	sResult = sProtocol & sDomain & sPath
	If Len(sQuerystring) > 0 Then
		sResult = sResult & "?" & sQuerystring
		sResult = Server.URLEncode(sResult)
		Response.Redirect("login.asp") & "?sURL=" & sResult

This builds a query string of the URL you were going to go to before you are redirected to the login page.  Now edit adminlogin.asp.  At line 34, before the If statement to check for a postback, insert the following line: 

strSourceURL = Request.QueryString("sURL")

This retrieves the query string and puts it into a variable.  At line 39, before the SQL statement to select the users from the database, insert the following code: 

If Not Trim(Request.Form("sourceURL")) = "" Then
	strSourceURL = Request.Form("sourceURL")
Else
	strSourceURL = "./?"
End If

This extra code is added to accommodate you entering a bad password or if you are logging in without following a comment link.  At line 74, comment out Johann’s Response.Redirect line after a successful login and then insert and replace the Response.Redirect for no user found with this: 

	Response.Redirect(strSourceURL)
Else
	Response.Redirect("login.asp?error=nouser") & "&sURL=" & Server.URLEncode(strSourceURL)

This sends you to the page you were intending to go to in the first place.  If you entered a bad password, this also preserves the original URL after the login page reloads.

Last, but not least, you need to a hidden form field that will store the original URL when you submit the form to log in.  Near the end of the file, insert a line before the close form tag and paste this: 

<input name="sourceURL" type="hidden" value="<%= strSourceURL %>" />

I hope that’s not too complicated to follow.  It’s a little more convoluted for this modification because it is necessary to add code in multiple places in multiple files, rather than just a chunk of code in one file.  But, now you will receive an email when a comment is posted and be easily able to approve or deny the comment just by following the link in the email.

Like the original script, since we use automated DLs, too, I look for an indication that a given DL is a SmartDL and skip it.  And I now use PrimalScript to work with my scripts, so I use its packager to make an exectuable.  This makes it easier and nicer for non-IT end-users who will be running scripts like these.

Download it here, or copy/paste below.

'Version 2.0 - July 23, 2007
'Copy distribution group membership from one user to another,
'excluding automated DLs (SmartDL).
'Get source user
While Not bolExit = True
	strOldSamUser = InputBox("Enter the sAMAccountName of the person to copy DLs FROM." _
		, "Enter username")
	If strOldSamUser = "" Then
		WScript.Quit
	End If

	'Find the Global Catalog server
	Set objCont = GetObject("GC:")
	For Each objGC In objCont
		strADsPath = objGC.ADsPath
	Next

	Set objConnection = CreateObject("ADODB.Connection")
	Set objRecordset = CreateObject("ADODB.Recordset")
	objConnection.Provider = "ADsDSOObject"

	objConnection.Open "ADs Provider"
	strQuery = "<" & strADsPath & ">;(&(objectcategory=user)(sAMAccountName=" & strOldSamUser & _
		"));displayName,distinguishedName;subtree"
	Set objRecordset = objConnection.Execute(strQuery)

	If Trim(objRecordset.Fields("distinguishedName")) = "" Then
		strNoUser = MsgBox("Warning: User cannot be found.  Verify sAMAccountName.", vbCritical, "User not found!")
		bolExit = False
	Else
		intCorrectUser = MsgBox("Is this the correct user?" & VbCrLf & VbCrLf & "Display Name: " & _
		objRecordset.Fields("displayName") & VbCrLf & "DN: " & objRecordset.Fields("distinguishedName"), _
			vbYesNo, "Old user?")
		If intCorrectUser <> 6 Then
			bolExit = False
		Else
			strSrcDN = objRecordset.Fields("distinguishedName")
			bolExit = True
		End If
	End If
 Wend
'Open IE to display progress and results
Set objIE = CreateObject("InternetExplorer.Application")
objIE.AddressBar = False
objIE.Menubar = False
objIE.Toolbar = False
objIE.Resizable = True
objIE.Left = 10
objIE.Height = 450
objIE.Width = 800
objIE.Visible = True
objIE.Navigate("about:blank")
While objIE.Busy
	WScript.Sleep 100
Wend
Set objDoc = objIE.Document
objDoc.Open
objDoc.Write("<TITLE>Copy DL Membership</TITLE>")
objDoc.Write("<BODY BGCOLOR=#C0C0C0>")
objDoc.Write("<P><b>Source:</b> " & objRecordset.Fields("distinguishedName") & "<br>")
'Get target user
bolExit = False
While Not bolExit = True
	strNewSamUser = InputBox("Enter the sAMAccountName of the person to copy DLs TO." _
		, "Enter username")
	If strNewSamUser = "" Then
		objIE.Quit
		WScript.Quit
	End If
	strQuery = "<" & strADsPath & ">;(&(objectcategory=user)(sAMAccountName=" & strNewSamUser & _
		"));displayName,distinguishedName;subtree"
	Set objRecordset = objConnection.Execute(strQuery)
	If Trim(objRecordset.Fields("distinguishedName")) = "" Then
		strNoUser = MsgBox("Warning: User cannot be found.  Verify sAMAccountName.", vbCritical, "User not found!")
		bolExit = False
	Else
		intCorrectUser = MsgBox("Is this the correct user?" & VbCrLf & VbCrLf & "Display Name: " & _
			objRecordset.Fields("displayName") & VbCrLf & "DN: " & objRecordset.Fields("distinguishedName"), _
			vbYesNo, "Old user?")
		If intCorrectUser <> 6 Then
			bolExit = False
		Else
			Set objTargetUser = GetObject("LDAP://" & objRecordset.Fields("distinguishedName"))
			bolExit = True
		End If
	End If
 Wend
 'Write target user to IE window
 objDoc.Write("<b>Target:</b> " & objRecordset.Fields("distinguishedName") & "</P>")
 'Copy DLs
 strDomFQDN = Mid(strSrcDN, InStr(LCase(strSrcDN), ",dc=") + 4)
 strGCFQDN = Replace(LCase(strDomFQDN), ",dc=", ".")
 Set objOldUser = GetObject("GC://" & strGCFQDN & "/" & strSrcDN)
 For Each strGroup in objOldUser.MemberOf
	On Error Resume Next
	Set objGroup = GetObject("LDAP://" & strGroup)
	If Not Trim(objGroup.mailNickname) = "" Then
		If Not Instr(objGroup.info, "SmartDL") > 0 Then
			objGroup.Add(objTargetUser.ADsPath)
			If Err.Number = 0 Then
				objDoc.Write(objGroup.DisplayName & ": Update successful.<br>")
			Else
				objDoc.Write(objGroup.DisplayName & ": Update UNSUCCESSFUL.<br>")
			End If
		Else
			objDoc.Write(objGroup.DisplayName & ": Skipped (SmartDL).<br>")
		End If
	End If
	On Error Goto 0
 Next

 Set objOldUser = Nothing
 Set objTargetUser = Nothing
 Set objIE = Nothing
 Set objRecordset = Nothing
 Set objConnection = Nothing
 

Johann included a copy of Emir Tuzul’s free ASP CAPTCHA implementation, but never incorporated it into simpleblog.  I looked at how the code works and how Johann implemented comments, and I have successfully added CAPTCHA verification to the comments system.  Since doing so a few days ago, not a single spam comment has been left.  If you are interested, this is how to do it.

Since Johann included version 2 of the CAPTCHA code page, you do not need to download anything, but you can opt to use version 3 beta 1, which uses more character obfuscation to make it harder for bots to determine the characters in the image.

Edit functions.asp to add the following code to the end of the file, which is the verification function:

<%
Function CheckCAPTCHA(valCAPTCHA)
	SessionCAPTCHA = Trim(Session("CAPTCHA"))
	Session("CAPTCHA") = vbNullString
	If Len(SessionCAPTCHA) < 1 Then
		CheckCAPTCHA = False
		Exit Function
	End if
	If CStr(SessionCAPTCHA) = CStr(valCAPTCHA) Then
		CheckCAPTCHA = True
	Else
		CheckCAPTCHA = False
	End if
End Function
%>

Add the following code to functions.asp in the CommentsGet subroutine, which for me starts at line 351.  It may be different for you since I think I have added other code higher in the file.  This adds the actual CAPTCHA image to the comments form.  You will add this code after the call for GetEmoticons and the line break, which for me means inserting this at line 454:

Type the characters shown in the image for verification.
<img src="captcha.asp" alt="" width="86" height="21" />
<input name="strCAPTCHA" type="text" id="strCAPTCHA" maxlength="8" /></td>

At line 481 (after the declaration of the str_userIP variable), insert this, which puts the characters entered into the form in a variable:

strCAPTCHA = Trim(Request.Form("strCAPTCHA"))

Lastly, replace the code that inserts the comment into the database with the code below, starting at line 492 (after the comment  "insert Comment."  Instead of simply inserting the comment into the database, this will compare the entered characters to the actual ones in the image.  If they match, the comment is inserted.  If not, I use a JavaScript alert to present a popup box and then redirect the user back to the post:

If CheckCAPTCHA(strCAPTCHA) = True Then
	SQL = "INSERT INTO T_COMMENTS(c_content, c_name, c_email, c_url, c_bID_fk,ip) VALUES ('" & strComment & "','" & sanitize( strName ) & "','" & sanitize( strEmail ) & "','" &  sanitize( strUrl )& "'," &  sanitize( bID )& ",'"&str_userIP&"')"
	Set MyConn = Server.CreateObject("ADODB.Connection")
	MyConn.Open strConn
	MyConn.Execute(strSQL)
	MyConn.Close
	Set MyConn = Nothing
	Response.Redirect("default.asp?view=plink&id=" & bID & "&comments=1")
Else
	%>
	<script language="Javascript">
		alert('You did not type the verification code correctly.');
		location.replace('default.asp?view=plink&id=<%= bID %>&comments=1');
	</script>
	<%
End If

You’re done!  Save functions.asp and then go add a comment to one of your posts.  Intentionally enter incorrect characters to confirm the popup works and that the comment did not get added.  The only thing missing from this is that it doesn’t preserve the comment in the session.  This means that if a real person incorrectly enters the code, when returned to the post to try and enter another code, the actual comment data will have to be entered again.  Name, email, and URL don’t have to because they are stored in a cookie on the client.  Perhaps I will add that at a later time.

It is not uncommon at my company to have to move a user from one domain to another for technical, logistical, or political reasons.  For another set of reasons, moving the user account to the other domain is not done, instead manually creating a new one and associating the mailbox with the new account.

DL membership does not automatically get updated when this is done, so I have been doing it manually.  It has been on my to-do list for awhile to write a script to copy the DL membership from the old account to the new one.  So I threw this together this morning.  It lacks some of the nice extras my other scripts have (finding the user by logon name, email results, true logging) but it does work.

You have to edit the script to give it the variables for the old and new users’ dn.  It will skip security groups (any group without an alias) and also groups whose Notes (info) attribute contains the word SmartDL.  We use Imanami’s SmartDL for automated DL membership when applicable.  Those will be automatically updated the next time each of their jobs run.

Download it here, or copy/paste below.

Option Explicit
Dim strOldUser, strNewUser, objOldUser, objNewUser, strGroup, objGroup
strOldUser = "" 'dn of user to copy from'
strNewUser = "" 'dn of user to copy to'
Set objOldUser = GetObject("LDAP://" & strOldUser)
Set objNewUser = GetObject("LDAP://" & strNewUser)
wscript.echo "Source user: " & objOldUser.DisplayName
wscript.echo "Target user: " & objNewUser.DisplayName
For Each strGroup in objOldUser.MemberOf
	On Error Resume Next
	Set objGroup = GetObject("LDAP://" & strGroup)
    If Not Trim(objGroup.mailNickname) = "" Then
        If Not Instr(objGroup.info, "SmartDL") > 0 Then
			objGroup.Add(objNewUser.ADsPath)
			If Err.Num = 0 Then
				wscript.echo objGroup.DisplayName & ": Update successful."
			Else
				wscript.echo objGroup.DisplayName & ": Update UNSUCCESSFUL."
			End If
        Else
			wscript.echo objGroup.DisplayName & ": Skipped (SmartDL)."
        End If
	End If
	On Error Goto 0
Next
Set objOldUser = Nothing
Set objNewUser = Nothing

I have updated the script, which can be downloaded here, to not error when this happens and include if it is unable to connect to a specific server and read the last full backup time.  The HTML rendering didn’t look right for the server reported with an error, and I couldn’t figure out why, so also updated how the table is built.  Now the report is one big table instead of every server in its own table.

I have updated the script, which can be downloaded here, to search for the groups based on their objectGUID, which never changes no matter what you do to the object (rename, move, etc.).  Instead of hard-coding the dn of the object, I hard-code the objectGUID.  Then I bind directly to the object based on the GUID to retrieve its dn, which is used in the search filter to find the users I want to modify.

Note that ADO allows you to bind to an object given just its GUID, without having to specify other connection parameters.  You can also use the hexadecimal or binary format of the GUID in the connection string; AD will figure out which format you are using. I used the binary format in my script so that I could just copy and paste the value from Hyena into my script without having to convert to a hex value.

Glen’s script uses an input argument of a server name. My distributed environment doesn’t allow for such a broad application, so I use the membership of a DL that contains the IT personnel. This DL actually contains other DLs, so I separately use another script by Richard Mueller that enumerates nested groups and puts the results into a domain local group that is used for other purposes.

After getting the group members, I loop through each member for only those with a mailbox that isn’t hidden. For those who haven’t been touched by the script before, a function is called that uses CDO to log into the mailbox, enumerate the calendar permissions looking for the Default entry, and change it to Reviewer. The user’s local FreeBusy Data folder is also updated to set the Default to Editor since that permission goes hand in hand when setting permissions on the calendar.

To keep tabs on who the script has touched, a notation is added to extensionAttribute4 (customizable). Those with that notation are skipped in the future. Then an email is sent to the user informing them of the change. I chose to do this because Exchange users may be used to the fact the the Default permission is None; this way they are aware that their calendar is open for viewing. It also helps with new employees who are not aware of this "policy" and can mark items as Private as necessary.

Finally, an email is sent to the admin with the results of the job run. It includes the display name, mailbox server, and whether the permission was set or the object skipped (to catch entries that slip through my filter). I have scheduled this to run weekly, and I will get an email each time so I know that the script is successfully running and which users are being modified.

All of the variables that require customization are near the top. These are for mail configuration, search filter, and the notation parameters for touched mailboxes.

Download it here or copy below.

Option Explicit

Public Const CdoDefaultFolderCalendar = 0
Dim strSMTPServer, strMailFrom, strUserMailSubject, strUserMailBody
Dim strAdminMailRecip, strAdminMailSubject, strAdminMailBody
Dim strDefaultNamingContext, strQueryFilter, strAttName, strAttNote
Dim conn, com, iAdRootDSE, strNamingContext
Dim Rs, objGroup, strMember, objUser, strMsExchHomeServerName
Dim objSession, CdoInfoStore, CdoFolderRoot, ACLObj, CdoCalendar, FolderACEs, fldACE
Dim objRoot, objFreeBusyFolder

'Configuration parameters:
''''''''''''''''''''''''''''''''''''''''''''''
'Email notification configuration
strSMTPServer = "server.company.com" 'FQDN of SMTP server
strMailFrom = """Display Name"" <a href="mailto:SMTPAddress@company.com">SMTPAddress@company.com</a>" ' Display name and address of sender
strUserMailSubject = "The default permission on your calendar has been updated" 'Subject of message sent to users
strUserMailBody = "In order to promote effective collaboration among the Company " & _
    "employees, the Default permission on your calendar has been updated to Reviewer.  This allows anyone within the organization " & _
    "to see the details of items within your calendar.  For items that are of a sensitive, confidential, or personal nature, " & _
    "you can mark them as Private.  This will restrict the details of the item so that others cannot see the subject or body.  " & _
    "If you have any questions about this change, please reply to this message or contact the Help Desk at XXXX.<br><br>" & _
    "Company Messaging and Collaboration Team (GAL Display Name)<br>Department<br>Company" 'Body of message sent to users
strAdminMailRecip = "<a href="mailto:SMTPAddress@company.com">SMTPAddress@company.com</a>" 'Address of admin to receive status report
strAdminMailSubject = "Default calendar permission change report" 'Subject of message sent to admin
'Domain to search for object
strDefaultNamingContext = "dc=company,dc=com" 'AD FQDN of base scope to search
'Search filter for group with users
strQueryFilter = "(&(objectcategory=group)(displayName=something))" 'LDAP filter to locate group with members to modify

'Attribute and notation for updated objects
strAttName = "extensionAttribute4" 'defined for a single-valued string attribute
strAttNote = "DefaultCalSet" 'Notation used to skip processed users on future script runs
''''''''''''''''''''''''''''''''''''''''''''''
strAdminMailBody = ""
Set conn = createobject("ADODB.Connection")
Set com = createobject("ADODB.Command")
Set iAdRootDSE = GetObject("<a href="ldap://RootDSE">LDAP://RootDSE</a>")
strNamingContext = iAdRootDSE.Get("configurationNamingContext")
Conn.Provider = "ADsDSOObject"
Conn.Open "ADs Provider"
Com.ActiveConnection = Conn
com.Properties("Page Size") = 1000
Com.CommandText = "<GC://" & strDefaultNamingContext & ">;" & StrQueryFilter & ";distinguishedname;subtree"
Set Rs = Com.Execute
While Not Rs.EOF
	Set objGroup = GetObject("LDAP://" & Rs.fields("distinguishedname"))
	For each strMember in objGroup.Member
		Set objUser = GetObject("LDAP://" & strMember)
		If InStr(objUser.Get(strAttName), strAttNote) < 1 Then
			strAdminMailBody = strAdminMailBody & objUser.displayName & "<br>"
			If objUser.Class = "user" And Not IsNull(objUser.msExchHomeServerName) And Not UCase(objUser.msExchHidefromAddressLists) = "TRUE" Then
				strMsExchHomeServerName = objUser.msExchHomeServerName
				strMsExchHomeServerName = right(strMsExchHomeServerName,len(strMsExchHomeServerName)-instrrev(strMsExchHomeServerName,"/cn=")-3)
				strAdminMailBody = strAdminMailBody & "&nbsp;&nbsp;&nbsp;&nbsp;" & strMsExchHomeServerName & "<br>"
				Call dofreebusy(strMsExchHomeServerName, objUser.mailNickname)
				strAdminMailbody = strAdminMailBody & "&nbsp;&nbsp;&nbsp;&nbsp;Permission set on: " & objUser.mailNickname & "<br>"
				WriteTag
				SendEmail objUser.mail, strUserMailSubject, strUserMailBody
			Else
				strAdminMailBody = strAdminMailBody & "&nbsp;&nbsp;&nbsp;&nbsp;Skipping object<br>"
			End If
		End If
	Next
	Rs.MoveNext
Wend
Rs.Close

'Send admin email report
If Not strAdminMailBody = "" Then
	strAdminMailBody = strAdminMailBody & "<br>Done.<br>"
Else
	strAdminMailBody = "No mailboxes needed updating."
End If
SendEmail strAdminMailRecip, strAdminMailSubject, strAdminMailBody

Set conn = Nothing
Set com = Nothing

Function dofreebusy(serverName, mailboxName)
	'Set Default permission to Reviewer
	Set objSession = CreateObject("MAPI.Session")
	objSession.Logon "","",false,true,0,true,servername & vbLF & mailboxname
	Set CdoInfoStore = objSession.GetInfoStore
	Set CdoFolderRoot = CdoInfoStore.RootFolder
	Set ACLObj = CreateObject("MSExchange.aclobject")
	Set CdoCalendar = objSession.GetDefaultFolder(CdoDefaultFolderCalendar)
	ACLObj.CdoItem = CdoCalendar
	Set FolderACEs = ACLObj.ACEs
	For each fldACE in FolderACEs
		If fldACE.ID = "ID_ACL_DEFAULT" Then
			fldACE.Rights = 1025
			ACLObj.Update
		End If
	Next

	'Set local FreeBusy folder permission to Editor
	Set objRoot = objSession.GetFolder("")
	Set objFreeBusyFolder = objRoot.Folders.Item("FreeBusy Data")
	ACLObj.CdoItem = objFreeBusyFolder
	Set FolderACEs = ACLObj.ACEs
	For each fldACE in FolderACEs
		If fldACE.ID = "ID_ACL_DEFAULT" Then
		fldACE.Rights = 1123
		ACLObj.Update
		End If
	Next
End function

'Write notation tag into attribute
Sub WriteTag()
	If IsNull(objUser.Get(strAttName)) or IsEmpty(objUser.Get(strAttName)) Then
		objUser.Put strAttName, strAttNote & ";"
	Else
		Dim strExistAttName
		strExistAttName = objUser.Get(strAttName)
		objUser.Put strAttName, strExistAttName & strAttNote & ";"
	End If
	objUser.SetInfo
End Sub

'Send change notification and report
Sub SendEmail (strRecipAddress, strMailSubject, strMailBody)
	Dim objMail
	Set objMail = CreateObject("CDO.Message")
	objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
	objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPServer
	objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
	objMail.Configuration.Fields.Update

 objMail.From = strMailFrom
	objMail.To = strRecipAddress
	objMail.Subject = strMailSubject
	objMail.HTMLBody = strMailBody
	objMail.Send
	Set objMail = Nothing
End Sub

I had written a batch file long ago to change the bitmask attribute for users whose mobile services are enabled for everything (0) and are not in the appropriate DL of authorized users to disable only EAS (5).  It was an inefficient script that required explicit permissions for each domain, called a command-line regex tool to format the ldifde export, and was prone to errors.

This updated script accomplishes the same thing, but more efficiently.  It processes all users at one time (inside a for loop) and uses implicit permissions.  It even emails the results of the number of users modified.  The script is customized for my environment, but you can tweak it as necessary. 

I have five user domains, but the DLs for authorization are in one domain.  I wanted it to be as dynamic as possible, but balancing that with all the extra code necessary to make every piece not rely on hard-coded information.  So you need to provide mail config information, the NetBIOS domain names you want to loop through, and the dn of the groups for each user domain.  The GC to search and the DC to make the change to will be determined automatically.

Download it here or copy below.

Option Explicit

Dim mailFrom, mailTo, mailSubject, mailBody, mailServer
Dim objConnection, objCommand, objRecordSet, objUser, objGC, objDomain
Dim strGCPath, strNBDomain, strdomain, arrDomains, strCount
dim strSearchFilter, strEASDL, strDomainPath
strCount = ""

'Mail config
mailFrom = Wscript.ScriptName & "@company.com"
mailTo = "user@company.com"
mailSubject = "EAS Disable Results"
mailBody = ""
mailServer = "server.company.com"

'AD connection parameters
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Open "Provider=ADsDSOObject;"
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection

'Get FQDN of a GC
Set objGC = GetObject("GC://RootDSE")
strGCPath = objGC.Get("dnsHostName")

'Query each domain and call disable subroutine
arrDomains = array("domainA", "domainB", "domainC", "domainD", "domainE")
For each strDomain in arrDomains
	subOMADisable strdomain
Next

'Email results
Call subSendMail(mailFrom, mailTo, mailSubject, strCount, mailServer)

'Sub to change attribute value
Sub subOMADisable(strNBDomain)
	'Get base DN of domain
	Set objDomain = GetObject("LDAP://" & strNBDomain & "/RootDSE")
	strDomainPath = objDomain.Get("DefaultNamingContext")
	Set objDomain = Nothing

	Select Case strNBDomain
		Case "domainA"
			strEASDL = "dn of groupA"
		Case "domainB"
			strEASDL = "dn of groupB"
		Case "domainC"
			strEASDL = "dn of groupC"
		Case "domainD"
			strEASDL = "dn of groupD"
		Case "domainE"
			strEASDL = "dn of groupE"
	End Select
	strSearchFilter="(&(objectcategory=user)(mailnickname=*)(homeMDB=*)(!memberof=" & strEASDL & ")(!msExchOMAAdminWirelessEnable=5))"
	objCommand.CommandText = "<GC://" & strGCPath & "/" & strDomainPath & ">;" & strSearchFilter & ";distinguishedname;subtree"
	Set objRecordSet = objCommand.Execute
	If objRecordSet.RecordCount > 0 Then
		While Not objRecordSet.EOF
			Set objUser = GetObject("LDAP://" & objRecordSet.Fields("distinguishedname"))
			'wscript.echo objUser.DisplayName
			objUser.Put "msExchOMAAdminWirelessEnable", "5"
			objUser.SetInfo
			objRecordSet.MoveNext
		Wend
	End If
	strCount = strCount & vbTAB & strNBDomain & ": " & objRecordSet.RecordCount & vbCRLF
End Sub

'Sub to send email with results
Sub subSendMail (mFrom, mTo, mSubject, mBody, mServer)
	Dim objEmail
	Set objEmail = CreateObject("CDO.Message")
	objEmail.From = mFrom
	objEmail.To = mTo
	objEmail.Subject = mSubject
	objEmail.Textbody = "Objects modified in each domain:" & vbCRLF &vbCRLF & mBody
	objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
	objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = mServer
	objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
	objEmail.Configuration.Fields.Update
	objEmail.Send
End Sub

'Cleanup
Set objUser = Nothing
Set objCommand = Nothing
Set objGC = Nothing
Set objConnection = Nothing

This script goes through all accounts in a given AD domain and whose primary email address is the "old" SMTP domain name, makes the primary a secondary, takes the username portion of the address and appends the new domain and makes it the new primary. I log all of the old address and new addresses to the screen, so redirect the output to a file to capture that. It doesn’t check for preexisting addresses so conflicts can occur. I had previously done my own extract to look for those, so dealing with them manually was easier and faster than coding for that.

I modified the script each time I ran it to change the AD domain I wanted to search (though I could have just defined an array of domain names and looped through each of them), and ran it against DLs and public folders, too, adjusting the filter to return the different object types. You will need to do the same.

Download the code here, or copy below.

Option Explicit
'Set value for domain to run against and LDAP filter to use
'Also set the old and new SMTP domain names on line 33
'If you need to update the display name to remove a company designation, that is line 80
dim strDomain, strSearchFilter
strdomain = "nbdomain" 'Put the NetBIOS domain name here
'Update filter below to return the object types you want, e.g., users, groups, publicfolders
strSearchFilter = "(&(objectcategory=publicfolder)(mailnickname=*)(mail=*@olddomain.com))" 

'Connect to AD
Dim objConnection, objCommand, objRecordSet, objUser
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Open "Provider=ADsDSOObject;"
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 10000

'Retrieve user objects
Const ADS_PROPERTY_UPDATE = 2
objCommand.CommandText = "<LDAP://" & strDomain & ">; " & strSearchFilter & "; distinguishedname"
Set objRecordSet = objCommand.Execute
wscript.echo "Count:" & objRecordSet.RecordCount
While not objRecordSet.EOF
	Set objUser = GetObject("LDAP://" & Replace(objRecordSet.Fields("distinguishedname"),"/", "\/"))
	wscript.echo objUser.displayName & "; " & strDomain & "\" & objUser.sAMAccountName

	'Set values for new email addresses
	Dim blnExists, strNewMail, i, strOldProxy, strAddress
	Dim arrProxyAddresses, intProxyAddresses, strNewProxy, intProxyForLoop
	arrProxyAddresses = objUser.proxyAddresses
	intProxyAddresses = UBound(arrProxyAddresses)
	intProxyForLoop = intProxyAddresses	

	'Set value for mail
	strNewMail = Replace(objUser.mail, "@olddomain.com", "@newdomain.com")
	wscript.echo vbTab & "Old mail: " & objUser.mail
	wscript.echo vbTab & "New mail: " & strNewMail
	wscript.echo ""

	'Log old SMTP proxies
	For each strOldProxy in arrProxyAddresses
		If UCase(Left(strOldProxy,5)) = "SMTP:" Then
			wscript.echo vbTab & "Old proxies: " & strOldProxy
		End If
	Next

	'Change primary to secondary and add new primary
	blnExists = False
	For i = 0 to intProxyForLoop
		dim strAddressType, strAddressBody
		strAddressType = Left(arrProxyAddresses(i),5)
		strAddressBody = Mid(arrProxyAddresses(i),6)
		If UCase(strAddressType) = "SMTP:" Then
			If strAddressType = "SMTP:" Then
	    			arrProxyAddresses(i) = Replace(arrProxyAddresses(i), "SMTP:", "smtp:")
	    		Else
	    			If LCase(strAddressBody) = LCase(strNewMail) Then
					blnExists = True
					arrProxyAddresses(i) = Replace(arrProxyAddresses(i), "smtp:", "SMTP:")
				End If
			End If
		End If
		If i = intProxyForLoop Then
			If Not blnExists Then
				ReDim Preserve arrProxyAddresses(intProxyAddresses + 1)
				arrProxyAddresses(intProxyAddresses + 1) = "SMTP:" & strNewMail
			End If
		End If
	Next

	'Log new SMTP proxies
	For each strNewProxy in arrProxyAddresses
		If UCase(Left(strNewProxy,5)) = "SMTP:" Then
			wscript.echo vbTab & "New proxies: " & strNewProxy
		End If
	Next
	wscript.echo ""

	'Remove component designation from display name
	Dim strDisplayName
	strDisplayName = Replace(objUser.displayName, " - COMPANY", "")
	wscript.echo vbTab & "New display: " & strDisplayName

	'Commit changes
	objUser.Put "mail", strNewMail
	objUser.PutEx ADS_PROPERTY_UPDATE, "proxyAddresses", arrProxyAddresses
	objUser.Put "displayName", strDisplayName
	On Error Resume Next
	objUser.SetInfo
	If Err.Number <> 0 Then
		wscript.echo "Update unsuccessful!"
	Else
		wscript.echo "Update successful"
	End If
	wscript.echo vbCRLF
	On Error Goto 0
	objRecordSet.MoveNext
Wend

Set objRecordSet = Nothing
Set objUser = Nothing
Set objCommand = Nothing
Set objConnection = Nothing

This script allows you to find a user based on login name (samAccountName) or email address.  If multiple matches are found it will report on all of them.  It uses WMI to query Exchange for the mailbox’s current size and then uses LDAP to determine the quota.  Since there are multiple places a quota can be set (system policy, server, mailbox), the script factors those in and backtracks to the resulting quota in effect.

The results are output to the screen and to a popup window.  And since it is nice to know, it also will display if default or custom limits are in use.  This script is nice because you don’t have to customize anything.  Just download\copy it and run it.

Option Explicit
Dim objGC, objOU, strADPath
Dim strUserLoginName
Dim objADOCnxn, objADOCmd, strSearchFilter, strReturnAttrib, strSearchDepth, objResults, intMatchingRecords
Dim strUserDisplayName, strRawExchServer, strExchServer
Dim wmiConn, strWQL, wmiColl, wmiObj
Dim mbstore, strquota, stroverquota, strHardLimit, strmbsize, strquotasum

'
' Messages to be displayed if the scripting host is not cscript
'
Const kMessage1 = "Please run this script using CScript."
Const kMessage2 = "This can be achieved by"
Const kMessage3 = "1. Using ""CScript script.vbs arguments"" or"
Const kMessage4 = "2. Changing the default Windows Scripting Host to CScript"
Const kMessage5 = "   using ""CScript //H:CScript //S"" and running the script "
Const kMessage6 = "   ""script.vbs arguments""."

' Make sure running with CScript
If Not IsHostCscript() Then
	Call WScript.echo(kMessage1 & vbCRLF & kMessage2 & vbCRLF & _
         kMessage3 & vbCRLF & kMessage4 & vbCRLF & _
         kMessage5 & vbCRLF & kMessage6 & vbCRLF)
	WScript.quit
End If

' Connect to a global catalog for the forest
Set objGC = GetObject("GC:")
For Each objOU In objGC
	strADPath = "<" & objOU.AdsPath & ">"
Next
Set objOU = Nothing
Set objGC = Nothing

WScript.Echo "* Searching within: " & strADPath

' Get input - strUserLoginName
strUserLoginName = InputBox("This will search for the user's mailbox and display its size." & _
 vbCrLf & vbCrLf & "Enter a user's login name, or" & vbCrLf & "their primary SMTP address:" & _
 vbCrLf & vbCrLf & "(LDAP wildcard characters are supported.)")
If strUserLoginName = "" Then
	WScript.Echo "User Canceled"
	WScript.Quit
End If
' Use ADO to query on the given user login name
Set objADOCnxn = CreateObject("ADODB.Connection")
objADOCnxn.Provider = "ADsDSOObject"
objADOCnxn.Open "Active Directory Provider"
Set objADOCmd = CreateObject("ADODB.Command")
objADOCmd.ActiveConnection = objADOCnxn
strSearchFilter ="(&(objectCategory=person)(|(mail=" & strUserLoginName & ")(samAccountName=" & strUserLoginName & ")))"
strReturnAttrib = "displayName,msExchHomeServerName,samAccountName,mdbUseDefaults,homemdb,mDBStorageQuota,mDBOverQuotaLimit,mDBOverHardQuotaLimit"
strSearchDepth = "SubTree"
objADOCmd.CommandText = strADPath & ";" & strSearchFilter & ";" & strReturnAttrib & ";" & strSearchDepth
Set objResults = objADOCmd.Execute
intMatchingRecords = objResults.RecordCount
WScript.Echo "    AD Search Returned " & intMatchingRecords & " Records" & vbCrLf
If intMatchingRecords < 1 Then
	' User name was not found
	MsgBox "The specified string was not found!" & vbCrLf & vbCrLf & "No matching user name or SMTP address(es)", 0, "Search Results"
Else
	' We found a match, for each record in result set...
	Do
		strUserDisplayName = objResults.Fields("displayName").value
		strRawExchServer = objResults.Fields("msExchHomeServerName").value

		' only proceed if the msExchHomeServerName attribute contains an '=' character
		If InStr(1, strRawExchServer, "=", vbTextCompare) Then
		' Parse out the actual Exchange server name (everything to right of last '=')
		strExchServer = Mid(strRawExchServer,InStrRev(strRawExchServer, "=", -1, vbTextCompare) + 1)

		' Create a WMI connection to that server
		Set wmiConn = GetObject("WinMgmts:{impersonationLevel=impersonate}!\\" & strExchServer & "\root\microsoftexchangev2")

		' Search for the display name of the user
		WScript.Echo "* Looking for '" & strUserDisplayName & "' on server " & strExchServer
		strWQL = "SELECT * FROM Exchange_Mailbox WHERE MailboxDisplayName = '" & strUserDisplayName & "'"
		'WScript.Echo "    DEBUG " & strWQL
		WScript.Echo "  Searching... Please wait"

		Set wmiColl = wmiConn.ExecQuery(strWQL)
		If wmiColl.Count >= 1 Then

			' Get quota limits
			If objResults.Fields("mDBUseDefaults").value = true Then
				Set mbstore = GetObject("GC://" & objResults.Fields("homemdb"))
				If mbstore.mDBStorageQuota = "" Then
					strquota =  "No Quota"
				Else
					strquota = formatnumber(mbstore.mDBStorageQuota/1024,0)
				End if
				If mbstore.mDBOverQuotaLimit = "" Then
					stroverquota =  "No Quota"
				Else
					stroverquota = formatnumber(mbstore.mDBOverQuotaLimit/1024,0)
				End if
				If mbstore.mDBOverHardQuotaLimit = "" Then
					strHardLimit =  "No Quota"
				Else
					strHardLimit = formatnumber(mbstore.mDBOverHardQuotaLimit/1024,0)
				End if
				If strquota <> "No Quota" Then
					strquotasum = "    Storage Quotas (Using store limits):" & vbcrlf
					strquotasum = strquotasum & "    Warning Limit: " & strquota & " MB" & vbcrlf
					strquotasum = strquotasum & "    Prohibit Send: " & stroverquota & " MB" & vbcrlf
					strquotasum = strquotasum & "    Prohibit Receive: " & strHardLimit & " MB" & vbcrlf
				Else
					strquotasum = "Storage Limits: No Quotas Configured" & vbcrlf
				End if
			Else
				If IsNull(objResults.fields("mDBStorageQuota").value) Then
					strquota =  "No Quota"
				Else
					strquota = formatnumber(objResults.fields("mDBStorageQuota").value/1024,0) & " MB"
				End if
				If IsNull(objResults.fields("mDBOverQuotaLimit").value) Then
					stroverquota =  "No Quota"
				Else
					stroverquota = formatnumber(objResults.fields("mDBOverQuotaLimit").value/1024,0) & " MB"
				End if
				If IsNull(objResults.fields("mDBOverHardQuotaLimit").value) Then
					strHardLimit =  "No Quota"
				Else
					strHardLimit = formatnumber(objResults.fields("mDBOverHardQuotaLimit").value/1024,0) & " MB"
				End if
				strquotasum = "    Storage Quotas (Using custom limits):" & vbcrlf
				strquotasum = strquotasum & "    Warning Limit: " & strquota & vbcrlf
				strquotasum = strquotasum & "    Prohibit Send: " & stroverquota & vbcrlf
				strquotasum = strquotasum & "    Prohibit Receive: " & strHardLimit & vbcrlf

			End if

			' for each mailbox found (should only be one), display the size
			For Each wmiObj In wmiColl
				WScript.Echo "    Found: " & wmiObj.MailboxDisplayName
				WScript.Echo "    Mailbox Size: " & formatnumber(wmiObj.Size/1024,1) & " MB" & vbCrLf
				Wscript.Echo strquotasum
				MsgBox "    Mailbox: " & strUserDisplayName & vbcrlf & "    Size: " & formatnumber(wmiObj.Size/1024,1) & _
				 " MB" & vbcrlf & vbcrlf & strquotasum, 0, "Search Results"
			Next
		Else
			' No mailbox found
			MsgBox "'" & strUserDisplayName & "' mailbox was not found on server " & strExchServer, 0, "Search Results"
		End If

		Set wmiColl = Nothing
		Set wmiConn = Nothing
	Else
		WScript.Echo "* No Exchange Home Server defined for " & objResults.Fields("samAccountName").value & vbCrLf
	End If

	'move to the next record in the record set; quit when EOF is true
	objResults.MoveNext
	Loop until objResults.EOF

End If
Set objResults = Nothing
Set objADOCmd = Nothing
Set objADOCnxn = Nothing

WScript.Echo "Done!"
WScript.Quit

' Determines which program is used to run this script.
' Returns true if the script host is cscript.exe
Function IsHostCscript()
	On Error Resume Next
	Dim strFullName
	Dim strCommand
	Dim i, j
	Dim bReturn
	bReturn = False
	strFullName = WScript.FullName
	i = InStr(1, strFullName, ".exe", 1)
	If i <> 0 Then
		j = InStrRev(strFullName, "\", i, 1)
		If j <> 0 Then
			strCommand = Mid(strFullName, j+1, i-j-1)
			If LCase(strCommand) = "cscript" Then
				bReturn = True
			End If
		End If
	End If
	If Err <> 0 Then
		Call WScript.echo("Error 0x" & Hex(Err.Number) & " occurred. " & Err.Description _
			& ". " & vbCRLF & "The scripting host could not be determined.")
	End If
	IsHostCscript = bReturn
End Function

My needs required some tweaking since I have servers in multiple domains, and I wanted it to email the results to multiple people who are responsible for backups.  I also needed to account for servers that don”t have public and/or private stores (e.g., front-end servers, conferencing servers).  The script will email the report in HTML format, grouping the stores alphabetically by server name.  Change the constants at the top to suit your needs and then schedule it to run daily.  My next step is to note stores that haven”t been backed up in X days (perhaps two or three) and highlight them in red so it is easy to spot those stores (since my report currently has 60+ stores in it).  Until then, download this version here, or copy it below.

'Change the constants below
CONST strSMTPServer = "Change to server name"
CONST strSMTPRecipient = "Change to recipient address(es)"
CONST strSMTPSender = "Change to sender address"
set conn = createobject("ADODB.Connection")
set mdbobj = createobject("CDOEXM.MailboxStoreDB")
set pdbobj = createobject("CDOEXM.PublicStoreDB")
set com = createobject("ADODB.Command")
Set iAdRootDSE = GetObject("<a href="ldap://RootDSE/">LDAP://RootDSE</a>")
strNameingContext = iAdRootDSE.Get("configurationNamingContext")
Conn.Provider = "ADsDSOObject"
Conn.Open "ADs Provider"
serverQuery = "<GC://" & strNameingContext & ">;(&(objectCategory=msExchExchangeServer));name,distinguishedName;subtree"
Com.ActiveConnection = Conn
Com.Properties("Sort on") = "name"
Com.CommandText = serverQuery
Set Rs = Com.Execute
While Not Rs.EOF
	output = output & "<font size=2><u><b>" & Rs.Fields("name") & "</b></u></font>" & vbcrlf
mbQuery = "<LDAP://" & strNameingContext & ">;(&(objectCategory=msExchPrivateMDB)(legacyExchangeDN=*" & _
	Rs.Fields("name") & "/cn=Microsoft Private MDB));name,distinguishedName;subtree"
	pfQuery = "<LDAP://" & strNameingContext & ">;(&(objectCategory=msExchPublicMDB)(legacyExchangeDN=*" & _
	Rs.Fields("name") & "/cn=Microsoft Public MDB));name,distinguishedName;subtree"
	Com.CommandText = mbQuery
	Set Rs1 = Com.Execute
	If Rs1.RecordCount = 0 Then
		output = output & "<table><tr><td width=50%><font size=2>&nbsp;&nbsp;&nbsp;&nbsp;No mailbox stores." & _
		"</font></td></tr>" & vbcrlf
	Else
		output = output & "<table>"
		While Not Rs1.EOF
			mdbobj.datasource.open "LDAP://" & Rs1.Fields("distinguishedName")
			output = output & "<tr><td width=50%><font size=2>&nbsp;&nbsp;&nbsp;&nbsp;" & Rs1.Fields("name") & _
			" </font></td><td><font size=2>Last Backed Up :" & mdbobj.LastFullBackupTime & "</font></td></tr>" & vbcrlf
			Rs1.MoveNext
		Wend
	End If
	Rs1.Close
	Com.CommandText = pfQuery
	Set Rs2 = Com.Execute
	If Rs2.RecordCount = 0 Then
		output = output & "<tr><td width=50%><font size=2>&nbsp;&nbsp;&nbsp;&nbsp;No public folder store.</td></tr>" & vbcrlf
	Else
		pdbobj.datasource.open "LDAP://" & Rs2.Fields("distinguishedName")
		output = output & "<tr><td width=50%><font size=2>&nbsp;&nbsp;&nbsp;&nbsp;" & _
		Rs2.Fields("name") & " </font></td><td><font size=2>Last Backed Up :" & _
		pdbobj.LastFullBackupTime & "</font></td></tr>" & vbcrlf
	End If
	output = output & "</table>"
	Rs2.Close
	On Error Goto 0
	output = output & vbcrlf
	Rs.MoveNext
Wend
Set iMsg = CreateObject("CDO.Message")
With iMsg
	.To = strSMTPRecipient
	.From = strSMTPSender
	.Subject = "Last Exchange Backup Report"
	.HTMLBody =  output
	.Configuration.Fields.Item("<a href="http://schemas.microsoft.com/cdo/configuration/sendusing">http://schemas.microsoft.com/cdo/configuration/sendusing</a>") = 2
	.Configuration.Fields.Item("<a href="http://schemas.microsoft.com/cdo/configuration/smtpserver">http://schemas.microsoft.com/cdo/configuration/smtpserver</a>") = strSMTPServer
	.Configuration.Fields.Item("<a href="http://schemas.microsoft.com/cdo/configuration/smtpserverport">http://schemas.microsoft.com/cdo/configuration/smtpserverport</a>") = 25
	.Configuration.Fields.Update
	.Send
End With
Rs.Close
Conn.Close
set mdbobj = Nothing
set pdbobj = Nothing
Set Rs = Nothing
Set Rs1 = Nothing
Set Rs2 = Nothing
Set Com = Nothing
Set Conn = Nothing

However, at my office we don’t have these kinds of users in one OU.  They are spread across multiple domains, but are all in a local group that has permission to a web page that allows them to change their password.  So I updated the script to enumerate the members of this group.  To accommodate different password aging settings in each domain I moved the domain query for this setting into the For loop.  I also added logging so you will have a record of what was sent, not sent, and why.  This way you can schedule it or run it interactively without having to adjust the code.  Download it here, or copy below.

Option Explicit

' Per environment constants - you should change these
Const SMTP_SERVER  = "ServerName"
Const STRFROM   = "From SMTP Address"
Const DAYS_FOR_EMAIL  = 14 'Send notification when pwd will expire in this number of days
Const GROUPDN = "DN of group to enumerate"
Const LOGFILE = "Patch and filename of log file"

' System Constants - do not change
Const ONE_HUNDRED_NANOSECOND    = .000000100   ' .000000100 is equal to 10^-7
Const SECONDS_IN_DAY            = 86400
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
Const E_ADS_PROPERTY_NOT_FOUND  = &h8000500D

' Change to "True" for extensive debugging output
Const bDebug   = False

Dim numDays, iResult
Dim strDomain
Dim objGroup, objMember, member
Dim objFSO, objFile, strOutput

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(LOGFILE, 8, True)

Set objGroup = GetObject("LDAP://" & GROUPDN)
objFile.WriteLine "Executed at " & Now() & vbCRLF
objFile.WriteLine "Enumerating members of " & objGroup.distinguishedName & ":" & vbCRLF
For each member in objGroup.member
	Set objMember = GetObject("LDAP://" & member)
	objFile.WriteLine objMember.distinguishedname
	strDomain = Mid(objMember.distinguishedname, InStr(objMember.distinguishedname, "DC="))
	numdays = GetMaximumPasswordAge (strDomain)
	Call ProcessUser (numDays)
Next

objFile.WriteLine "Done. Finished at " & Now() & "."
objFile.Close

Function GetMaximumPasswordAge (ByVal strDomainDN)
	Dim objDomain, objMaxPwdAge
	Dim dblMaxPwdNano, dblMaxPwdSecs, dblMaxPwdDays

	Set objDomain = GetObject("LDAP://" & strDomainDN)
	Set objMaxPWdAge = objDomain.maxPwdAge

	If objMaxPwdAge.LowPart = 0 And objMaxPwdAge.Highpart = 0 Then
		' Maximum password age is set to 0 in the domain
		' Therefore, passwords do not expire
		GetMaximumPasswordAge = 0
	Else
		dblMaxPwdNano = Abs (objMaxPwdAge.HighPart * 2^32 + objMaxPwdAge.LowPart)
		dblMaxPwdSecs = dblMaxPwdNano * ONE_HUNDRED_NANOSECOND
		dblMaxPwdDays = Int (dblMaxPwdSecs / SECONDS_IN_DAY)
		GetMaximumPasswordAge = dblMaxPwdDays
	End If
End Function

Function UserIsExpired (objMember, iMaxAge, iDaysForEmail, iRes)
	Dim intUserAccountControl, dtmValue, intTimeInterval
	Dim strName
	On Error Resume Next
	Err.Clear
	strName = Mid (objMember.Name, 4)
	intUserAccountControl = objMember.Get ("userAccountControl")

	If intUserAccountControl And ADS_UF_DONT_EXPIRE_PASSWD Then
		dp "The password for " & strName & " does not expire."
		UserIsExpired = False
	Else
		iRes = 0
		dtmValue = objMember.PasswordLastChanged
		If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then
			UserIsExpired = True
			dp "The password for " & strName & " has never been set."
		Else
			intTimeInterval = Int (Now - dtmValue)
			dp "The password for " & strName & " was last set on " & _
			DateValue(dtmValue) & " at " & TimeValue(dtmValue) & _
			" (" & intTimeInterval & " days ago)"
			If intTimeInterval >= iMaxAge Then
				dp "The password for " & strName & " has expired."
				UserIsExpired = True
			Else
				iRes = Int ((dtmValue + iMaxAge) - Now)
				dp "The password for " & strName & " will expire on " & _
				DateValue(dtmValue + iMaxAge) & " (" & _
				iRes & " days from today)."
				If iRes <= iDaysForEmail Then
					dp strName & " needs an email for password change"
					UserIsExpired = True
				Else
					dp strName & " does not need an email for password change"
					'Swap commented variable below to force email to be sent (for testing).
					UserIsExpired = False
					'UserIsExpired = True
				End If
			End If
		End If
	End If
End Function

Sub ProcessUser (iMaxPwdAge)
	Dim iResult, strExpire
	If Right (objMember.Name, 1) <> "$" Then
		If IsEmpty (objMember.Mail) or IsNull  (objMember.Mail) Then
			dp Mid (objMember.Name, 4) & " has no mailbox"
		Else
			If UserIsExpired (objMember, iMaxPwdAge, DAYS_FOR_EMAIL, iResult) Then
				objFile.WriteLine "Sending an email to " & objMember.givenName & " " & objMember.sn & _
				" (" & objMember.Mail & ").  Password expires in " & iResult & " days." & vbCRLF
				Call SendEmail (iResult)
			Else
				If iResult = "" Then
					strExpire = "."
				Else
					strExpire = " for " & iResult & " days."
				End If
				objFile.WriteLine "Skipping " & objMember.givenName & " " & objMember.sn & _
				". Password does not expire" & strExpire & vbCRLF
			End If
		End If
	End If
End Sub

Sub SendEmail (iResult)
	Dim objMail
	Set objMail = CreateObject ("CDO.Message")
	objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing")      = 2
	objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver")     = SMTP_SERVER
	objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
	objMail.Configuration.Fields.Update

	objMail.From = STRFROM
	objMail.To = objMember.Mail

	objMail.Subject = "The Windows password is going to expire for " & Mid (objMember.Name, 4)
	objMail.Textbody = "The Windows Active Directory password for user " & objMember.givenName & " " & objMember.sn & _
	" (" & objMember.sAMAccountName & ")" & " will expire in " & iResult & " days. " & vbCRLF & vbCRLF & _
	"Please use Outlook Web Access (https://www.company.com) to change it before it expires." & vbCRLF & vbCRLF & _
	"Thank you," & vbCRLF & _
	"Company Exchange Team" & vbCRLF & vbCRLF & _
	"Note: You have received this email because you are a member of a group that is authorized to change your " & _
	"password via Outlook Web Access since you do not log in to the corporate network.  If this no longer applies to you, " & _
	"please notify the Company Email Team (SMTPAddress) so you can be removed from the group."

	objMail.Send
	Set objMail = Nothing
End Sub

Sub dp (str)
	If bDebug Then
		objFile.WriteLine str
	End If
End Sub

Microsoft’s solution is to use MDBView and go through the hidden items in the inbox until you find the corresponding rule and manually delete it. You can also use the better tool, MFCMapi, to do it. I wanted a better way to do it, and one that admins who don’t delve into raw MAPI viewers could use. So I wrote this WebDAV script that queries the target mailbox for the hidden items in the inbox, displays them in a table, and allows you to delete the message from the results window.

The delegate rule’s Rule Provider Content value is “Schedule+ EMS Interface.” If the delegator has multiple delegates who receive meeting requests (not that common) you won’t see multiple rules. There is only one rule, regardless of the number of recipients. If you don’t see an item with the Rule Provider Content Value above, then the user doesn’t have any delegates who receive meeting requests.

The script uses Exchange 2003 SP1′s ability to use the SMTP address in the URL, negating the need for a virtual directory for each SMTP namespace in your org. So you need SP1 for this to function. Just change the values near the top for the protocol and server name of your front-end or back-end server. I wrapped the script in a web page so it can be hosted on an IIS server and then you can just browse to it from anywhere. Note that it is not a server-side script. The code will be executed by the client and will prompt for credentials. Putting it in a web page is just a convenience. Just copy and paste it into a file, or download it here.

<html>
<head>
<script language='VBScript'>
Dim objXMLHTTP, objXMLDoc
' Define your protocol; http or https
strProtocol = "http"
' Define your server name
strServername = "[server]"
' Define your local name for 'Inbox'
strInbox = "Inbox"
Sub getMessages_OnClick()
	strUsername = document.all.mailbox.value
	If strUsername <> "" Then
		strInboxURL = strProtocol & "://" & strServername & "/Exchange/"
		strInboxURL = strInboxURL & strUsername & "/" & strInbox
		Set objXMLHTTP = CreateObject("Microsoft.XMLHTTP")
		objXMLHTTP.Open "SEARCH", strInboxURL, True
		objXMLHTTP.setRequestHeader "Content-type:", "text/xml"
		objXMLHTTP.setRequestHeader "Depth", "1"
		objXMLHTTP.onReadyStateChange = getRef("checkXMLHTTPState")
		strXML = "<?xml version='1.0' ?>" & _
			"<a:searchrequest xmlns:a='DAV:'><a:sql>" & _
			"SELECT" & _
			" ""DAV:displayname""" & _
			",""<a href="http://schemas.microsoft.com/mapi/proptag/x65eb001f">http://schemas.microsoft.com/mapi/proptag/x65eb001f</a>""" & _
			" FROM scope('shallow traversal of """ & strInboxURL & """')" & _
			" WHERE ""DAV:ishidden""=True" & _
			" AND ""DAV:isfolder""=False" & _
			"</a:sql></a:searchrequest>"
		objXMLHTTP.Send(strXML)
	End If
End Sub

Sub checkXMLHTTPState
	If objXMLHTTP.readyState = 4 Then
		ResponseStatus.innerHTML = "Server Response: " & objXMLHTTP.Status & " - " & objXMLHTTP.StatusText
		Set objXMLDoc = objXMLHTTP.ResponseXML
		XSLDiv.innerHTML = objXMLDoc.TransformNode(responseXSL.documentElement)
		Set objXMLHTTP = Nothing
		Set objXMLDoc = Nothing
	End If
End Sub

Function deleteMessage(strURL)
	strUsername = document.all.mailbox.value
	strInboxURL = strProtocol & "://" & strServername & "/Exchange/"
	strInboxURL = strInboxURL & strUsername & "/" & strInbox
	strItemURL = strInboxURL & "/" & Replace(strURL, chr(34), "")
	Set objDelete = CreateObject("Microsoft.XMLHTTP")
	objDelete.Open "DELETE", strItemURL, False
	objDelete.Send
	If (objDelete.Status >=200 And objDelete.Status <300) Then
		MsgBox "Successful deletion."
	Else
		MsgBox "Delete request failed."
	End If
	Set objDelete = Nothing
	Call getMessages_OnClick()
End Function
</script>

<xml id='responseXSL'>
<xsl:template
xmlns:xsl='uri:xsl' xmlns:a='DAV:' xmlns:d='urn:schemas:httpmail:'
xmlns:mapitag='http://schemas.microsoft.com/mapi/proptag/'>
<table width='75%' border='1'>
<tr>
<td align='center'><font size='2'><b>Action</b></font></td>
<td width='40%' align='center'><font size='2'><b>Message Subject</b></font></td>
<td align='center'><font size='2'><b>Rule Provider Content</b></font></td>
</tr>
<xsl:for-each select='a:multistatus/a:response'>
<tr>
<td align='center'>
<input>
<xsl:attribute name='type'>button</xsl:attribute>
<xsl:attribute name='name'>deleteMessage1</xsl:attribute>
<xsl:attribute name='value'>Delete</xsl:attribute>
<xsl:attribute
name='onclick'>vbscript:deleteMessage("<xsl:value-of
select='string(a:propstat/a:prop/a:displayname)' />")
</xsl:attribute>
</input>
</td>
<td><font size='2'><xsl:value-of select='a:propstat/a:prop/a:displayname' /></font></td>
<td><font size='2'><xsl:value-of select='a:propstat/a:prop/mapitag:x65eb001f' /></font></td>
</tr>
</xsl:for-each>
</table>
</xsl:template>
</xml>

</head>
<body>
<font face='Verdana' size='2'>SMTP Address:<br>
<input type='text' name='mailbox'><br>
<input type='button' name='getMessages' value='Retrieve'><br><br>
<div id='responseStatus'></div>
<div id='XSLDiv'></div>
</body>
</html>