Quick Active Directory Password Reset (1 Viewer)

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