The following is a function I created to quickly change passwords in Active Directory.
NOTE: YOU MUST HAVE ADMINISTRATIVE ACCESS TO THE AD FOLDER FOR THIS TO WORK
NOTE: YOU MUST HAVE ADMINISTRATIVE ACCESS TO THE AD FOLDER FOR THIS TO WORK
Code:
'*****Function to quickly reset Active Directory password*****
'*****Note: You must have administrative access to the Active Directory folder*****
'*****Arguments: strUserName = users sAMAccountName, strNewPassword = new password to be reset to*****
'*****Created by TJ Poorman 08/02/2013*****
Public Function ResetPassword(strUserName As String, strNewPassword As String)
Dim objUser As Object
Dim objItem As Object
Dim objOU As Object
Dim strADSPath As String
'Set strADSPath with the full LDAP path to the user
strADSPath = FindFullName(strUserName)
'Check if any of the sub functions returned an error
If Left(strADSPath, 6) = "Error:" Then
MsgBox "There has been an error" & Chr(13) & strADSPath
Exit Function
End If
Set objUser = GetObject(strADSPath)
objUser.SetPassword (strNewPassword) 'Set password for the user to the new password
objUser.accountdisabled = False 'Account is not disabled
objUser.pwdLastSet = 0 'Make it so the user has to change their password on login
objUser.SetInfo 'Update the information
MsgBox "Successfully reset password for '" & strUserName & "'"
End Function
Public Function FindFullName(strUserName As String) As String
Dim objConnection As Object
Dim objCommand As Object
Dim objRecordset As Object
'Create all the connections for LDAP
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = 2
'SQL statement to find the user based on their sAMAccountName
objCommand.CommandText = _
"SELECT DisplayName, sAMAccountName " _
& "FROM 'LDAP://Yourdomain' WHERE " _
& "objectCategory='user' " _
& "AND sAMAccountName = '" & strUserName & "'" 'Change this to your LDAP domain
Set objRecordset = objCommand.Execute
With objRecordset
If Not .EOF Then
.MoveLast
.MoveFirst
'Check if there is more than one record with the username
If .RecordCount > 1 Then
FindFullName "Error: There are more than one users with this account name"
Else
FindFullName = FindADSPath(StrConv(.Fields("DisplayName").Value, 3))
End If
Else
FindFullName = "Error: Could not find user"
End If
End With
objRecordset.Close
Set objRecordset = Nothing
End Function
Public Function FindADSPath(strFullName As String) As String
Dim objUser As Object
Dim objItem As Object
Dim intCount As Integer
Dim i As Integer
Dim strFinalPath As String
Set objUser = GetObject("[URL]ldap://OU=BaseOU,DC=domain,DC=com[/URL]") 'Change to your base OU and domain
'Find all the Organizational Units
For Each objItem In objUser
If objItem.ou <> "" Then
intCount = intCount + 1
End If
Next
'Set the array with the number of OU's
ReDim aryOUS(intCount) As Variant
'Get the ADSPath of each OU
i = 1
For Each objItem In objUser
aryOUS(i) = objItem.adspath
i = i + 1
Next
'Loop through each OU to find the user
For i = 1 To intCount
Set objUser = GetObject(aryOUS(i))
For Each objItem In objUser
'If the user is found return the ADSPath
If InStr(1, objItem.adspath, strFullName) <> 0 Then
strFinalPath = objItem.adspath
FindADSPath = strFinalPath
Exit Function
End If
Next
Next I
'Couldn't find the user
FindADSPath = "Error: Could not find user"
End Function
Last edited: