Zm∞na u₧ivatelskΘho hesla

Private Function ChangePassword(UserName As String, _
NewPassword As String) As Boolean

   'POÄADAVKY: ADSI, LDAP provider
   'U₧ivatel pracujφcφ s touto funkcφ musφ mφt prßvo na zm∞nu hesla

   'PARAMETERY:
   'UserName: P°ihlaÜovacφ jmΘno u₧ivatele, kterΘmu budeme m∞nit heslo
   'NewPassword: NovΘ heslo u₧ivatele

   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")
   'prßce s defaultnφ domΘnou
   sDomain = oRoot.Get("defaultNamingContext")
   Set oDomain = GetObject("LDAP://" & sDomain)
   sBase = "<" & oDomain.ADsPath & ">"

   'ZjiÜt∞nφ po₧adovanΘho u₧ivatele
   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

P°φklad volßnφ:
ChangePassword "Administrator", "adminpassword"

Zp∞t