Expiring Users Script That Sends an Email

Below is a script that I created to query AD for expiring user accounts and then to email the results out. The only flaw is that it doesn't filter account that have already expired, so those will show. Which yeah I could add that in but it would be MUCH easier to just re-write this in powershell to do the same.

As always test and use at your own risk.

' VB Script to scrape AD for users with expiring dates
' set and to email the results in an html table with info


StrEmailTo = "address@here.com; address2@here.com"
StrEmailFrom = "fromaddress@here.com"
StrEmailSubject = "insert subject here"
Strsmtpserver = "youremailserver.domain.com"


Dim lngDate, objDate, dtmAcctExp, k


' Obtain local time zone bias from machine registry.
Set objShell = CreateObject("Wscript.Shell")
lngBiasKey = objShell.RegRead("HKLMSystemCurrentControlSetControl" _
& "TimeZoneInformationActiveTimeBias")
If (UCase(TypeName(lngBiasKey)) = "LONG") Then
lngBias = lngBiasKey
ElseIf (UCase(TypeName(lngBiasKey)) = "VARIANT()") Then
lngBias = 0
For k = 0 To UBound(lngBiasKey)
lngBias = lngBias + (lngBiasKey(k) * 256^k)
Next
End If



' Use ADO to search the domain.
Set adoConnection = CreateObject("ADODB.Connection")
Set adoCommand = CreateObject("ADODB.Command")
adoConnection.Provider = "ADsDSOOBject"
adoConnection.Open "Active Directory Provider"
Set adoCommand.ActiveConnection = adoConnection


' Determine the DNS domain from the RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("DefaultNamingContext")



' Filter to retrieve all user objects with accounts
' that expire.
strFilter = "(&(objectCategory=person)(objectClass=user)" _
& "(!accountExpires=0)(!accountExpires=9223372036854775807))"


strQuery = "<LDAP://" & strDNSDomain & ">;" & strFilter _
& ";distinguishedName,accountExpires;subtree"


' Run the query.
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False
Set adoRecordset = adoCommand.Execute


Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = StrEmailSubject
objMessage.From = StrEmailFrom
objMessage.To = StrEmailTo

objMessage.HTMLBody = "<font size=" & chr(34) & "2" & chr(34) & " face=" & chr(34) & "Arial" & chr(34) & ">" & _

"Below is the expiring users report:<br><br><table border-" & Chr(34) & "1" & Chr(34) & "><tr><th>Date Expires</th><th>-----</th><th>User</th></tr><tr>"

'**********************

' Enumerate the recordset.
Do Until adoRecordset.EOF
' Retrieve attribute values.
strDN = adoRecordset.Fields("distinguishedName").Value
lngDate = adoRecordset.Fields("accountExpires")
' Convert accountExpires to date in current time zone.
Set objDate = lngDate
dtmAcctExp = Integer8Date(objDate, lngBias)
' Output to console.
objMessage.HTMLBody = objMessage.HTMLBody & "<tr><td>" & dtmAcctExp & " " & "</td><td>&nbsp;</td><td>" & strDN & "</td></tr>"
adoRecordset.MoveNext
Loop
adoRecordset.Close
objMessage.HTMLBody = objMessage.HTMLBody & "</table>"


objMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Strsmtpserver
objMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.Send

'**********************

' Clean up.
adoConnection.Close

Function Integer8Date(ByVal objDate, ByVal lngBias)
' Function to convert Integer8 (64-bit) value to a date, adjusted for
' local time zone bias.
Dim lngAdjust, lngDate, lngHigh, lngLow
lngAdjust = lngBias
lngHigh = objDate.HighPart
lngLow = objdate.LowPart
' Account for bug in IADslargeInteger property methods.
If (lngLow < 0) Then
lngHigh = lngHigh + 1
End If
If (lngHigh = 0) And (lngLow = 0) Then
lngAdjust = 0
End If
lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) _
+ lngLow) / 600000000 - lngAdjust) / 1440
Integer8Date = CDate(lngDate)
End Function