script which emails a list of account expiration dates

'Option Explicit

Dim oShell
Dim strSchemaPath
Dim objConnection
Dim ojRS
Dim StrAttr, strName, strattribute
Dim strLDAP
Dim objConn 'ADO Connection object
Dim objRS 'ADO Recordset object
Dim strAlt ' As Boolean
Dim StrADs
Dim strclass
Dim strSam, strobjFilter, strattrFilter 
Dim objWMIService, objitem, objUser
Dim strUserDN, lngTZBias
Dim objShell, lngBiasKey, k
Dim strWrite
Dim objAccountExpires

Set oShell = WScript.CreateObject ("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
strWrite = "UserName,DisplayName,Date" & vbcrlf
' Obtain local Time Zone bias from machine registry.
' This bias changes with Daylight Savings Time.
Set objShell = CreateObject("Wscript.Shell")
lngBiasKey = objShell.RegRead("HKLM\System\CurrentControlSet\Control\" _
    & "TimeZoneInformation\ActiveTimeBias")
If (UCase(TypeName(lngBiasKey)) = "LONG") Then
    lngTZBias = lngBiasKey
ElseIf (UCase(TypeName(lngBiasKey)) = "VARIANT()") Then
    lngTZBias = 0
    For k = 0 To UBound(lngBiasKey)
        lngTZBias = lngTZBias + (lngBiasKey(k) * 256^k)
    Next
End If



'AD gathering
'Get the Root DSE from a random DC
Set objRootDSE = GetObject("LDAP://RootDSE")

'Connect to the schema container on a random DC
strDNSDomain = objRootDSE.Get("defaultNamingContext")

wscript.echo strDNSDomain
       
'Makes a connection to AD using ADODB (ADSI)
       set objConnection = CreateObject("ADODB.Connection")
       Set objCommand = CreateObject("ADODB.Command")
       objConnection.Provider = "ADsDSOObject"
       objConnection.Open("Active Directory Provider")
       objCommand.ActiveConnection = objConnection


'msgbox (CDbl(DateDiff("s", CDate("01/01/1601 00:00:00"), Now - 1)))
Set objRS  = objConnection.Execute("<LDAP://" & strDNSDomain & ">;(&(objectCategory=person)" _
& "(objectClass=user)(!accountexpires=9223372036854775807)(!accountexpires=0));Name,ADsPath,accountExpires;SubTree") '
   	
While Not objRS.EOF
set ObjUser = GetObject(objRs.Fields("ADsPath").value)
Set objDate = objUser.accountExpires
objAccountExpires = Integer8Date(objDate, lngTZBias)
wscript.echo objuser.sAMAccountName & "," & objuser.displayName & "," & objAccountExpires
strWrite = StrWrite & objuser.sAMAccountName & "," & objuser.displayName & "," & objAccountExpires & vbcrlf
objRS.MoveNext
Wend
Set objRS = Nothing
objConnection.Close   

'Writes the log file
set strNewFile = objFSO.createtextfile("c:\Audit.csv", true)
strNewFile = "C:\Audit.csv"
Set objFile = objFSO.OpenTextFile(strNewFile, 2)
objFile.WriteLine strWrite
objFile.Close

EmailADMIN

'Converts the Long integer to a readable date
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 error 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
    ' Trap error if lngDate is ridiculously huge.
    On Error Resume Next
    Integer8Date = CDate(lngDate)
    If (Err.Number <> 0) Then
        On Error GoTo 0
        Integer8Date = #1/1/1601#
    End If
    On Error GoTo 0
End Function


Function EmailADMIN


Set objEmail = CreateObject("CDO.Message")
objEmail.From = "Somename@domain.local" '"AD Audit"
objEmail.To = "somename@domain.local" '"Admin@Domain.local"
objEmail.Subject = "<Enter your SUBJECT LINE>"
objEmail.Textbody = "<Enter body info>" '"Enter the text desired" 
objEmail.addattachment("c:\Audit.csv")
objEmail.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "<Exchange server name or IP"
objEmail.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Update
objEmail.Send

End Function

Select allOpen in new window