Posts tagged: inline code

Script to format an LDAP filter for readability

By , August 7, 2007 7:32 AM

I have automated DLs that use LDAP filters for membership criteria.  These filters are stored as binary data in the extensionData attribute of the group object, so they are not easily accessible by users who want to know what filter is being applied to a DL they own.

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

Add comment notification to simplebog 3.0

By , July 30, 2007 11:52 AM

Since I am using approval for comments on my site, I had no way of knowing when someone posted a comment pending approval.  And since you can’t simply look for comments to posts without going into the database directly, I needed a way to know when someone has posted a comment and to which post it belongs.

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.

Updated: Copy DLs from one user to another

By , July 22, 2007 4:01 PM

The first version of the script really was quick and dirty, requiring you to manually put the source and target users’ DNs in the script.  Since a coworker has been using the script, I thought it appropriate to update it to prompt for the usernames.  In addition, I added a new feature I recently read about, which is to output the results in real-time to a GUI.  This is done by creating an object for IE and writing the output similar to wscript.echo, but with the Write method of the object.

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
 

How to add CAPTCHA to simpleblog 3.0

By , July 21, 2007 9:34 PM

Johann almost added CAPTCHA verification to simpleblog 3, but he notes on his blog that he decided not to after looking at the pros and cons.  He says that simpleblog isn’t a target of comment spam because of the inability to post html or javascript code into a comment.  I disagree, however, because you still get targeted by comment spam by the very nature that bots will still post comments.  Even with approval enabled, I still have to delete the pending comments, and there can be A LOT of them.

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.

Quick and dirty script to copy DLs from one user to another

By , February 4, 2007 4:07 PM

Edit: The inline code in this post is not the latest version of the script. Get the latest version from the downloads page.

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

Change users’ default calendar permission (and email the users and admin)

By , June 21, 2006 4:49 PM

Our IT Leadership team decided that it will promote more effective collaboration if the Default calendar permission for all IT employees is set to Reviewer (instead of the Default of None). As with many of my scripts, I started with the work Glen Scales has already done. Go there for information on the prerequisite for using this script to make the change (the need for ACL.dll).

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

Script to disable Exchange ActiveSync for unauthorized users

By , June 1, 2006 9:09 AM

By default, users have all mobile services enabled (OMA, EAS including AUTD/DP).  This is a pain in my environment because only authorized users are allowed to use EAS (to ensure only approved devices procured through proper channels are used).  OMA, being similar to OWA, is allowed for everyone.

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

Company name change and email addresses

By , May 1, 2006 1:14 PM

My company changed its name a couple weeks ago and so I needed to add a new primary address for those who had the old domain as a primary, and move the old primary to a secondary. I was surprised that I couldn’t hardly find any existing scripts to accommodate such an endeavor so I had to resort to doing it myself.

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

Query for a mailbox’s size and quota

By , October 5, 2005 8:43 AM

There are a lot of scripts out there to report a mailbox’s current size and others to report the quota for a mailbox.  And some might even do both, but for an entire domain, server, etc.  I wanted one that I could use to list a single mailbox’s current size and where it falls within its quota.

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

Report the last time your Exchange servers were backed up

By , September 22, 2005 12:14 PM

Like a lot of my scripts, they start from the hard work that someone else has done.  This one began as a similar script that Glen Scales wrote and posted over on his blog.  His version enumerates the servers/stores in a domain and outputs the results to the screen.

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

Panorama Theme by Themocracy