The main aim is to notify pop/smtp users defined days before their password expires. Here is the script below. It's written for Active Diretory 2003/2008 enviorments.
It's never tested in production environments. Using the script in your environment is your responsibilities.
You need to edit 'EDIT' section before using it in your environment.
'-----
Const ForReading=1,ForWriting=2,ForAppending=8,adLockOptimistic = 3,adOpenDynamic = 1,TriStateTrue = -1
Dim objUser, strUserDN, objShell, lngBiasKey, lngBias, WshShell, k
Dim objRootDSE, strDNSDomain, objDomain, objMaxPwdAge, intMaxPwdAge, FSO , adocommand , adoconnection,adoRecordSet
Dim objDate, dtmPwdLastSet, lngFlag, blnPwdExpire, blnExpired, LogFileAccounts, strBase,StrAttributes,StrQuery
Dim strFilter
Dim lngHighAge, lngLowAge
Dim sBCC,sSub,sBody,sAttch
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Int k : k=0
'----- EDIT-------
Int intMaxPwdAge : intMaxPwdAge = 200 'Enter Maximum pasword age of your domain
Dim outFile : outFile ="C:\SifresiDolanlar.txt" 'Output file
Dim Verbose : Verbose = 2 ' 1 =Verbose Mode, 0 =Quite mode, 2 = Report Mode (users will not get the message)
Dim strFrom : strFrom = "mailadmin@ttmail.com" 'From address of the message that will be sent to the users
Dim strBCC : strBCC = "borand@ttmail.com" 'BCC address, for getting a copy of the message
Dim strAdm : strAdm = "borand@ttmail.com" 'Mail administrator's address, for reporting
Dim strMailServer: strMailServer = "exf01.borand.local" 'Relay server, you need to give relay access for anonymous access for the IP address of the script machine
Dim HDayBefore : HDayBefore = 15 'Days before users will be informed
Dim strSub : strSub = "Sifrenizin süresi dolmak Uzeredir, lütfen degistiriniz"
Dim ebody : ebody = "Sifrenizin süresi dolmak üzeredir " 'Body of the message that will be sent to the user
ebody = ebody + vbCrLf + "Sifrenizi domaine üye bilgisayarinizdan veya owa sayfasindan (https://mail.borand.com.tr/owa )degistirebilirsiniz."
ebody = ebody + vbCrLf + "Saygilarimizla,"
ebody = ebody + vbCrLf + "Mesajlasma Sistemi Birim Yöneticisi"
strBase = "
strFilter = "(&(objectCategory=person)(objectClass=user)(mailnickName=*)(userPrincipalName=bora*))" 'Test filter
'strFilter = "(&(objectCategory=person)(objectClass=user))" ' Main filter (Filters all mailbox users)
'---- CALLS-----
Call Main()
Call SendMailToAdmin
'----
Function Main
Set logfileAccounts =FSO.CreateTextFile(Outfile,ForWriting, True)
logfileAccounts.WriteLine (Date()&" Tarihi icin sifresi dolmak üzere olan hesaplar")
DisplayMsg( " Main Function Running---")
Const ADS_UF_PASSWD_CANT_CHANGE = &H40
Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = adoConnection
StrAttributes = "distinguishedName,lastLogon"
strQuery = strBase & ";" & strFilter & ";" & strAttributes
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 300
adoCommand.Properties("Cache Results") = False
DisplayMsg(strQuery)
' On Error Resume Next
Set adoRecordset = adoCommand.Execute
If (Err.Number <> 0) Then
WScript.Echo Err.Description
Else
Do Until adoRecordset.EOF
strDN = adoRecordset.Fields("distinguishedName").Value
' WScript.Echo strDN
Set objuser = Getobject ("LDAP://" & strDN)
strUserDN = objUser.distinguishedName
Call GetPwdLastDate(objUser)
datePwdAge = DateDiff("d", dtmPwdLastSet, Now())
DisplayMsg("Users' password age is : " &datePwdAge)
If (intMaxPwdAge-HDayBefore < datePwdAge) And (datePwdAge < intMaxPwdAge) Then
DisplayMsg (" Kullanicinin sifresi dolmak uzere, mail gonderilecek ")
k=k+1
emailAdr = objUser.mail
LogFileAccounts.WriteLine EmailAdr & " " & datePwdAge
If Verbose <> 2 Then
Call SendMail (strFrom,emailAdr,strBCC,strSub,ebody,"")
End If
End If
adoRecordset.MoveNext
Loop
adoRecordset.Close
adoConnection.Close
End If
logfileAccounts.WriteLine (k &" kullaniciya mail gonderildi")
logfileAccounts.Close
DisplayMsg(" Main Function BITT")
End Function
Sub SendMailtoAdmin
DisplayMsg("running SendMailtoAdmin function...")
Set oFileIn= FSO.OpenTextFile(outFile, ForReading,False,TriStateTrue)
BodyText=oFileIn.ReadAll
DisplayMsg(BodyText)
oFileIn.Close
Call SendMail(strfrom,strAdm,"","Sifresi Dolmak uzere olan hesaplar",BodyText,"")
End Sub
Function GetPwdLastDate(objUser)
' Retrieve user password information.
' The pwdLastSet attribute should always have a value assigned,
' but other Integer8 attributes representing dates could be "Null".
If (TypeName(objUser.pwdLastSet) = "Object") Then
Set objDate = objUser.pwdLastSet
dtmPwdLastSet = Integer8Date(objDate, lngBias)
Else
dtmPwdLastSet = #1/1/1601#
End If
lngFlag = objUser.Get("userAccountControl")
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
' Determine if password expired.
blnExpired = False
If (blnPwdExpire = True) Then
If (DateDiff("d", dtmPwdLastSet, Now()) > intMaxPwdAge) Then
blnExpired = True
End If
End If
' Display password information.
Wscript.Echo "User: " & strUserDN & vbCrLf & "Password last set: " _
& dtmPwdLastSet & vbCrLf & "Maximum password age (days): " _
& intMaxPwdAge & vbCrLf & "Can password expire? " & blnPwdExpire _
& vbCrLf & "Password expired? " & blnExpired
End Function
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
Sub SendMail(sFrom,sTo,sBCC,sSub,sBody,sAttch)
Call DisplayMsg("Running SendMail function")
'On error resume next
err.clear
Const cdoAnonymous = 0 'Do not authenticate
Dim objEmail : Set objEmail = CreateObject("CDO.Message")
objEmail.From = sFrom
objEmail.To = sTo
ObjEmail.BCC = sBCC
objEmail.Subject = sSub
objEmail.Textbody = sBody
objEmail.AddAttachment sAttch
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 '2=remote server 1=Local pickup directory
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 0 '0=Anonymous,1=Basic,2=NTLM
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strMailServer
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Update
objEmail.Send
WScript.Echo sTo & " " & sBCC & " email addresses got the notification message."
If err.number <> 0 then
Call DisplayMsg( "Error sending email : " & err.descprition)
wscript.quit
end if
end Sub
Function DisplayMsg(msgTxt)
'Prints msg on screen only if Verbose is set
if Verbose = 1 Or Verbose = 2 then
wscript.echo msgTXT
end if
end Function
'---End of Script
