Envoyer un mail aux comptes qui ont leur mot de passe qui va expirer

Option Explicit

'Liste les comptes actifs du domaine qui ont un mot de passe qui va expirer dans moins de x jours et leur envoi nominativement un email pour leur signaler

Const ADS_UF_PASSWD_CANT_CHANGE = &H40
Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000
Const ADS_UF_ACCOUNTDISABLE = 2

Dim adoConnection, adoCommand
Dim objRootDSE, strDNSDomain, strFilter, strQuery, adoRecordset
Dim strDN, objShell, lngBiasKey, lngBias, blnPwdExpire
Dim objDate, dtmPwdLastSet, lngFlag, k, dtmPwdExpDate
Dim objDomain, objMaxPwdAge, lngHighAge, lngLowAge, intMaxPwdAge
Dim strName, strMail, strCountry, varAccountDisabled
Dim DelayBeforeExpiration
Dim varListAccountwithPasswordExpired

Dim varSMTPRelay 'Adresse du serveur de messagerie / relais smtp 
Dim varDestEmail, varSujetMail, varMessageMail, varSenderMail

varSMTPRelay = "AdresseServeurSMTP.com"
varSenderMail = "donotreply@nomdomaine.com" 'Adresse email envoyeur

' 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
	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 for all users.
Set adoConnection = CreateObject("ADODB.Connection")
Set adoCommand = CreateObject("ADODB.Command")
adoConnection.Provider = "ADsDSOOBject"
adoConnection.Open "Active Directory Provider"
Set adoCommand.ActiveConnection = adoConnection

' Determine domain maximum password age policy in days.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("DefaultNamingContext")
Set objDomain = GetObject("LDAP://" & strDNSDomain)
Set objMaxPwdAge = objDomain.MaxPwdAge

' Account for bug in IADslargeInteger property methods.
lngHighAge = objMaxPwdAge.HighPart
lngLowAge = objMaxPwdAge.LowPart
If (lngLowAge < 0) Then lngHighAge = lngHighAge + 1
intMaxPwdAge = -((lngHighAge * 2^32) + lngLowAge)/(600000000 * 1440)

' Filter to retrieve all user objects.
strFilter = "(&(objectCategory=person)(objectClass=user))"

strQuery = "<LDAP://" & strDNSDomain & ">;" & strFilter & ";distinguishedName,sAMAccountName,mail,co,pwdLastSet,userAccountControl;subtree"

adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False

varListAccountwithPasswordExpired = ""

' Enumerate all users.
Set adoRecordset = adoCommand.Execute
Do Until adoRecordset.EOF
	strDN = adoRecordset.Fields("distinguishedName").Value
	strName = adoRecordset.Fields("sAMAccountName").Value
	strMail = adoRecordset.Fields("mail").Value
	strCountry = adoRecordset.Fields("co").Value
	lngFlag = adoRecordset.Fields("userAccountControl").Value
	blnPwdExpire = True

	If ((lngFlag And ADS_UF_PASSWD_CANT_CHANGE) <> 0) Then
		blnPwdExpire = False
	End If

	If ((lngFlag And ADS_UF_DONT_EXPIRE_PASSWD) <> 0) Then
		blnPwdExpire = False
	End If
	
	varAccountDisabled = False 'Valeur par défaut
	If ((lngFlag And ADS_UF_ACCOUNTDISABLE) <> 0) Then varAccountDisabled = True 'Si le bit correspondant est à 1, alors cela signifie que le compte est désactivé
	
	' The pwdLastSet attribute should always have a value assigned,
	' but other Integer8 attributes representing dates could be "Null".
	If (TypeName(adoRecordset.Fields("pwdLastSet").Value) = "Object") Then
		Set objDate = adoRecordset.Fields("pwdLastSet").Value
		dtmPwdLastSet = Integer8Date(objDate, lngBias)
	Else
		dtmPwdLastSet = #1/1/1601#
	End If
	dtmPwdExpDate = DateAdd("d", dtmPwdLastSet, intMaxPwdAge)
	DelayBeforeExpiration = DateDiff("d", Now , dtmPwdExpDate)

	
	If (blnPwdExpire = True) And (varAccountDisabled = False) Then 'Si le mot de passe expire et que le compte n'est pas désactivé
		If Len(strMail) > 0 Then 'Si on a bien une adresse mail
			If (DelayBeforeExpiration = 5) Or (DelayBeforeExpiration = 3) Or (DelayBeforeExpiration = 1) Or (DelayBeforeExpiration = 0) Then 'Si le compte expire dans 5, 3 ou 1 jours
			'If (DelayBeforeExpiration <= 5) Then 'Si le compte expire sous 5 jours
				'Wscript.Echo """" & strDN & """," & strName & "," & strCountry & "," & blnPwdExpire & "," & dtmPwdLastSet & "," & dtmPwdExpDate
				Wscript.Echo strName & "," & strMail & "," & dtmPwdExpDate & "," & DelayBeforeExpiration
				varDestEmail = strMail

				varSujetMail = "Expiration de votre mot de passe dans " & DelayBeforeExpiration & " jour(s)"
				varMessageMail = "Bonjour," & VbCrLf & VbCrLf & VbCrLf & "votre mot de passe expire dans " & DelayBeforeExpiration & " jours(s). Merci de le modifier." & VbCrLf & VbCrLf & VbCrLf & "Cordialement,"

				Call EnvoyerEmail(varSMTPRelay, varDestEmail, varSenderMail, varSujetMail, varMessageMail)		
			End If
		Else
			varListAccountwithPasswordExpired = varListAccountwithPasswordExpired & strName & "," 'On note le login du compte qui n'a pas d'adresse mail
		End If
	End If
	
	adoRecordset.MoveNext
Loop
adoRecordset.Close

If Len(varListAccountwithPasswordExpired) > 1 Then
	varListAccountwithPasswordExpired = Left(varListAccountwithPasswordExpired, Len(varListAccountwithPasswordExpired)-1)
	If Len(varListAccountwithPasswordExpired) > 1 Then
		'Wscript.Echo "Account list without email adress :"
		'Wscript.Echo varListAccountwithPasswordExpired
	End If
End If

' 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 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

Public Function EnvoyerEmail(varSMTPRelay, varDestEmail, varSenderMail, varSujetMail, varMessageMail)

	Dim objMessage

	Set objMessage = CreateObject("CDO.Message")
	objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
	objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = varSMTPRelay
	objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
	objMessage.Configuration.Fields.Update

	objMessage.Subject = varSujetMail
	objMessage.Sender = varSenderMail
	objMessage.To = varDestEmail
	objMessage.TextBody = varMessageMail
	objMessage.Send

	Set objMessage = Nothing

End Function