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 = ";" & 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