Code:
Public Function ChangePassword(UserName As String, _ NewPassword As String) As Boolean 'PURPOSE: Changes Password for User specified 'by User Name 'REQURIES: 1) ADSI, LDAP provider '2) Logged on user has privileges to change 'password 'PARAMETERS: 'UserName: Login Name of user for whom to change password 'NewPassword: New Password for User 'RETURNS: True if successful, false otherwise 'EXAMPLE: ChangePassword "Administrator", "adminpassword" Dim conn As New ADODB.Connection Dim rs As ADODB.Recordset Dim oRoot As IADs Dim oDomain As IADs Dim sBase As String Dim sFilter As String Dim sDomain As String Dim sAttribs As String Dim sDepth As String Dim sQuery As String Dim user As IADsUser On Error GoTo errhandler: Set oRoot = GetObject("LDAP://rootDSE") 'work in the default domain sDomain = oRoot.Get("defaultNamingContext") Set oDomain = GetObject("LDAP://" & sDomain) sBase = "<" & oDomain.ADsPath & ">" 'Only get user name requested sFilter = "(&(objectCategory=person)(objectClass=user)(name=" _ & UserName & "))" sAttribs = "adsPath" sDepth = "subTree" sQuery = sBase & ";" & sFilter & ";" & sAttribs & ";" & sDepth conn.Open _ "Data Source=Active Directory Provider;Provider=ADsDSOObject" Set rs = conn.Execute(sQuery) With rs If Not .EOF Then Set user = GetObject(rs("adsPath")) user.SetPassword NewPassword ChangePassword = True End If End With errhandler: On Error Resume Next If Not rs Is Nothing Then If rs.State <> 0 Then rs.Close Set rs = Nothing End If If Not conn Is Nothing Then If conn.State <> 0 Then conn.Close Set conn = Nothing End If Set oRoot = Nothing Set oDomain = Nothing End Function