Send Mail when password expire

Hi there
I've attached my function for Sending Mail.
When calling the SendMail function you can optionally pass the full path of the attachment file, otherwise you call it like Call SendMail("") (empty quotes required if no attachment given)
Change the Constants to suit especially the email Server
Hope it helps
Regards
Krystian

Private Function SendMail(strAttachment)
 
' Version 1.1
' Written by Krystian Karia
' Dated: 15 Feb 2008
 
	On Error Resume Next 
 
	Dim fso, objConfiguration, objMessage, objFields
 
	Const SEND_USING = 2
	Const SMTP_SERVER_PORT = 25										' 25 is default SMTP Port
	Const SMTP_SERVER = "MailServer.Domain.local"					' Your SMTP Server in DNS format or IP
 
	Const EMAIL_SENDER = "first.last@domain.local"					' Can be any fake address if you want
	Const EMAIL_TO = "user.sn@mail.com,user2.sn@domain.co.uk"		' Comma seperated recipient list
	Const EMAIL_SUBJECT = "AUTOMATED EMAIL - Report"				' obvious!
	Const TEXT_BODY = "** AUTOMATED EMAIL **"			 			' Change to suit
	
	Set fso = CreateObject("Scripting.FileSystemObject")
	Set objConfiguration = CreateObject("CDO.Configuration") 
	Set objMessage = CreateObject("CDO.Message") 
	Set objFields = objConfiguration.Fields 
		
	If strAttachment <> "" Then
		If not fso.FileExists(strAttachment) Then
			SendMail = 53
			Exit Function
		End If
	End If
	
		With objFields 
			.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = SEND_USING 
			.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTP_SERVER_PORT 
			.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTP_SERVER
			.Update 
		End With 
 
 
 
 
		With objMessage 
			Set .Configuration = objConfiguration 
 
			.From = EMAIL_SENDER 
			.To = EMAIL_TO 
			.Subject = EMAIL_SUBJECT
			.TextBody = TEXT_BODY
 
				If strAttachment <> "" Then
					.AddAttachment strAttachment
				End If
 
' Ask for read receipt
'			.MDNRequested = True 
	
			.Send 
		End With 
 
' Catch any errors if they occured
 
	If Err.Number <> 0 Then 
		SendMail = Err.Number
		
	Else
		SendMail = 0
	End If 
 
 
End Function 'SendMail

Select allOpen in new window

Thanks i need replace, its ok?   Thanks! :D

this:

REM Sub SendEmailMessage(strDestEmail, strNoOfDays)
    REM Set objMessage = CreateObject("CDONTS.NewMail")
    REM objMessage.From = "administrator@fibertel.com.ar"
    REM objMessage.To = strDestEmail
    REM objMessage.Subject = "Password Expires in " & strNoOfDays & " days"
    REM objMessage.Body = "Your password expires in " & strNoOfDays & " days. Please goto http://changepass.com and reset"
    REM objMessage.Send
REM End Sub



for this:
Private Function SendMail(strAttachment)
 
' Version 1.1
' Written by Krystian Karia
' Dated: 15 Feb 2008
 
        On Error Resume Next
 
        Dim fso, objConfiguration, objMessage, objFields
 
        Const SEND_USING = 2
        Const SMTP_SERVER_PORT = 25                                                                             ' 25 is default SMTP Port
        Const SMTP_SERVER = "MailServer.Domain.local"                                   ' Your SMTP Server in DNS format or IP
 
        Const EMAIL_SENDER = "first.last@domain.local"                                  ' Can be any fake address if you want
        Const EMAIL_TO = "user.sn@mail.com,user2.sn@domain.co.uk"               ' Comma seperated recipient list
        Const EMAIL_SUBJECT = "AUTOMATED EMAIL - Report"                                ' obvious!
        Const TEXT_BODY = "** AUTOMATED EMAIL **"                                               ' Change to suit
       
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set objConfiguration = CreateObject("CDO.Configuration")
        Set objMessage = CreateObject("CDO.Message")
        Set objFields = objConfiguration.Fields
               
        If strAttachment <> "" Then
                If not fso.FileExists(strAttachment) Then
                        SendMail = 53
                        Exit Function
                End If
        End If
       
                With objFields
                        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = SEND_USING
                        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTP_SERVER_PORT
                        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTP_SERVER
                        .Update
                End With
 
 
 
 
                With objMessage
                        Set .Configuration = objConfiguration
 
                        .From = EMAIL_SENDER
                        .To = EMAIL_TO
                        .Subject = EMAIL_SUBJECT
                        .TextBody = TEXT_BODY
 
                                If strAttachment <> "" Then
                                        .AddAttachment strAttachment
                                End If
 
' Ask for read receipt
'                       .MDNRequested = True
       
                        .Send
                End With
 
' Catch any errors if they occured
 
        If Err.Number <> 0 Then
                SendMail = Err.Number
               
        Else
                SendMail = 0
        End If
 
 
End Function 'SendMail

Hi there
I have amended your code to use my function and have also amended the function to accept your parameters ( Recipient and Number of Days )
All you should do is change the SMTP_SERVER part to your own SMTP Server assuming you have one in your company??
Hope it helps
Regards
Krystian

'
' Esto verifica las password que estan por vencer en 4 dias
'
Option Explicit
 
Dim objCommand, objConnection, objChild, objUserConnection, strBase, strFilter, strAttributes, strPasswordChangeDate, intPassAge
Dim lngTZBias, objPwdLastSet, strEmailAddress, objMessage
Dim objShell, lngBiasKey, k, PasswordExpiry, strRootDomain
Dim strQuery, objRecordset, strName, strCN
 
' ********************* MODIFICAR ESTOS VALORES***********************************
 
PasswordExpiry=4
strRootDomain="ou=Seguridad,ou=Seguridad-Performance,ou=Gcia Operaciones RD,ou=Usuarios,dc=operaciones,dc=fibertel,dc=com,dc=ar"
 
' *********************************************************************************
 
 
' Obtain local Time Zone bias from machine registry.
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
 
Set objCommand = CreateObject("ADODB.Command")
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
objCommand.ActiveConnection = objConnection
strBase = "<LDAP://" & strRootDomain & ">"
 
strFilter = "(&(objectCategory=person)(objectClass=user))"
strAttributes = "sAMAccountName,cn,mail,pwdLastSet,distinguishedName"
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
objCommand.CommandText = strQuery
objCommand.Properties("Page Size") = 100
objCommand.Properties("Timeout") = 30
objCommand.Properties("Cache Results") = False
Set objRecordSet = objCommand.Execute
 
' WScript.echo "Running at " & Date()
 
Do Until objRecordSet.EOF
  strName = objRecordSet.Fields("sAMAccountName").Value
  strCN = objRecordSet.Fields("cn").value
  strEmailAddress = objRecordSet.Fields("mail").value
  Wscript.Echo "NT Name: " & strName & ", Common Name: " & strCN
 
  Set objUserConnection = GetObject("LDAP://" & objRecordSet.Fields("distinguishedName").Value)
  Set objPwdLastSet = objUserConnection.pwdLastSet
  strPasswordChangeDate = Integer8Date(objPwdLastSet, lngTZBias)
  WScript.Echo vbTab & "Password last changed at " & strPasswordChangeDate
  intPassAge = DateDiff("d", strPasswordChangeDate, Now)
  WScript.Echo vbTab & "Password changed " & intPassAge & " days ago"
 
  If intPassAge = (PasswordExpiry-3) Then
    WScript.echo vbTab & "Sending user notification to " & strEmailAddress & " that password expires in 3 days"
    Call SendMail(strEmailAddress, 3)
    
  ElseIf intPassAge = (PasswordExpiry-6) Then
    WScript.echo vbTab & "Sending user notification to " & strEmailAddress & " that password expires in 6 days"
    Call SendMail(strEmailAddress, 6)
 
  ElseIf intPassAge = (PasswordExpiry-9) Then
    WScript.echo vbTab & "Sending user notification to " & strEmailAddress & " that password expires in 9 days"
    Call SendMail(strEmailAddress, 9)
 
  End If
 
  objRecordSet.MoveNext
Loop
 
objConnection.Close
 
 
Function Integer8Date(objDate, 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 overly large
  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
 
 
Private Function SendMail(sArgRecipient, sArgNumOfDays)
 ' Version 1.2
 ' Written by Krystian Karia
 ' Dated 27/05/2009
 
' ** Note **
' You must change the SMTP SERVER to your own ( see between the borders below )
 
 
 
' Catch errors ourselves
	On Error Resume Next
 
' Declare Variables 
	Dim fso, objConfiguration, objMessage, objFields
	Dim EMAIL_SENDER
	Dim EMAIL_TO
	Dim EMAIL_SUBJECT
	Dim TEXT_BODY
	Dim ATTACHMENT
	Dim NUM_OF_DAYS
	 
' Declare Constants
	Const SEND_USING = 2
	Const SMTP_SERVER_PORT = 25										' 25 is default SMTP Port
 
' *************************************************************
	Const SMTP_SERVER = "MailServer.Domain.local"					' Your SMTP Server in DNS format or IP
 ' *************************************************************
 
 
 
 ' Initialize Variables
	NUM_OF_DAYS = sArgNumOfDays		' passed to us
	EMAIL_TO = sArgRecipient	' passed to us
	EMAIL_SENDER = "administrator@fibertel.com.ar"
	EMAIL_SUBJECT = "Password Expires in " & NUM_OF_DAYS & " days"
	TEXT_BODY = "Your password expires in " & NUM_OF_DAYS & " days. Please goto http://changepass.com and reset"
	ATTACHMENT = ""
 
 
' Create Objects	
	Set fso = CreateObject("Scripting.FileSystemObject")
	Set objConfiguration = CreateObject("CDO.Configuration") 
	Set objMessage = CreateObject("CDO.Message") 
	Set objFields = objConfiguration.Fields 
 
 
' Check attachment file exists if used
	If ATTACHMENT <> "" Then
		If not fso.FileExists(ATTACHMENT) Then
			SendMail = 53
			Exit Function
		End If
	End If
 
' Do not change any of teh settings below
		With objFields 
			.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = SEND_USING 
			.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTP_SERVER_PORT 
			.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTP_SERVER
			.Update 
		End With 
 
 ' Set the parameters for sending the mail
		With objMessage 
			Set .Configuration = objConfiguration 
 
			.From = EMAIL_SENDER 
			.To = EMAIL_TO 
			.Subject = EMAIL_SUBJECT
			.TextBody = TEXT_BODY
 
				If ATTACHMENT <> "" Then
					.AddAttachment ATTACHMENT
				End If
 
'			.MDNRequested = True 	' Ask for read receipt
	
			.Send 
		End With 
 
' Catch any errors if they occured
 
	If Err.Number <> 0 Then 
		SendMail = Err.Number
		
	Else
		SendMail = 0
	End If 
 
 
End Function 'SendMail

Select allOpen in new window

Krys, Thanks, but i don't recibe the mails. I modified my smtp with "smtp.fibertel.com.ar". How can i generate output with users is found the password about to expire.  I need known if script find any users.

Thanks

Hi there
Recently i wrote a script to get the date a users password will expire. See Here
Have a go with it to see if it works ok. All you should need to do is change the Group DN on line 32 to match a goup of yours that has some users in it.
Also, to check that mailing works ok, try the script below which is the same as what i gave you but can be run on its own to test mailing.
With these 2 you should see if things work each seperately . If so then its the script you have that needs attention and will help us to work out where the fault lies. Mailing or Getting the Password expiration dates. :-)
Is it possible that the users being found in your script don't have any passwords epxiring in 3, 6, 9 days ?? therefore, nothing to email. Just a thought :-)
Regards
Krystian

	Dim strEmailAddress
		
		strEmailAddress = "you@fibertel.com.ar" ' <____ change to suit
 
	Call SendMail(strEmailAddress, 6)
 
 
 
Private Function SendMail(sArgRecipient, sArgNumOfDays)
 ' Version 1.2
 ' Written by Krystian Karia
 ' Dated 27/05/2009
 
' ** Note **
' You must change the SMTP SERVER to your own ( see between the borders below )
 
 
 
' Catch errors ourselves
'	On Error Resume Next
 
' Declare Variables 
	Dim fso, objConfiguration, objMessage, objFields
	Dim EMAIL_SENDER
	Dim EMAIL_TO
	Dim EMAIL_SUBJECT
	Dim TEXT_BODY
	Dim ATTACHMENT
	Dim NUM_OF_DAYS
	 
' Declare Constants
	Const SEND_USING = 2
	Const SMTP_SERVER_PORT = 25										' 25 is default SMTP Port
 
' *************************************************************
	Const SMTP_SERVER = "MailServer.Domain.local"					' Your SMTP Server in DNS format or IP
 ' *************************************************************
 
 
 
 ' Initialize Variables
	NUM_OF_DAYS = sArgNumOfDays		' passed to us
	EMAIL_TO = sArgRecipient	' passed to us
	EMAIL_SENDER = "administrator@fibertel.com.ar"	' <_____ Cannot be the same as sender's address (fake one will do)
	EMAIL_SUBJECT = "Password Expires in " & NUM_OF_DAYS & " days"
	TEXT_BODY = "Your password expires in " & NUM_OF_DAYS & " days. Please goto http://changepass.com and reset"
	ATTACHMENT = ""
 
 
' Create Objects	
	Set fso = CreateObject("Scripting.FileSystemObject")
	Set objConfiguration = CreateObject("CDO.Configuration") 
	Set objMessage = CreateObject("CDO.Message") 
	Set objFields = objConfiguration.Fields 
 
 
' Check attachment file exists if used
	If ATTACHMENT <> "" Then
		If not fso.FileExists(ATTACHMENT) Then
			SendMail = 53
			Exit Function
		End If
	End If
 
' Do not change any of teh settings below
		With objFields 
			.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = SEND_USING 
			.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTP_SERVER_PORT 
			.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTP_SERVER
			.Update 
		End With 
 
 ' Set the parameters for sending the mail
		With objMessage 
			Set .Configuration = objConfiguration 
 
			.From = EMAIL_SENDER 
			.To = EMAIL_TO 
			.Subject = EMAIL_SUBJECT
			.TextBody = TEXT_BODY
 
				If ATTACHMENT <> "" Then
					.AddAttachment ATTACHMENT
				End If
 
'			.MDNRequested = True 	' Ask for read receipt
	
			.Send 
		End With 
 
' Catch any errors if they occured
 
	If Err.Number <> 0 Then 
		SendMail = Err.Number
		
	Else
		SendMail = 0
	End If 
 
 
End Function 'SendMail

Select allOpen in new window

Meant to also say to change the SMTP Server again in the Function :-)

Krys you are a beast :) and sorry by disturbing. I check your script and i need users in one group but o i have all users in diferents groups.

SMTP: smtp.fibertel.com.ar
LDAP: "ou=Seguridad,ou=Seguridad-Performance,ou=Gcia Operaciones RD,ou=Usuarios,dc=operaciones,dc=fibertel,dc=com,dc=ar"

Thanks for your help :)

I check your script to send mail with CDO.Message but i modified with my smtp, but i don't recibe any mail. When i check with CDONTS i will recibe OK the mails. The server is Windows 2003 Standard with IIS and SMTP service (of iis).
I need the script check on OU what users have password about to expire and send mail with notificacion. I think to check the password expire of users generate any output to check the script is find a users.

Thanks and sorry for disturbing :)

Sorry, but i don´t known how to continue with this problem.

I was resolved the problem with this script.


http://windowsitpro.com/article/articleid/97329/emailing-users-before-their-passwords-expire.html