Change a windows user's password. Requires admin permission but doesn't require knowing the old password.

OverridePassword.vbs

'***********************
'Name: Change Pass Admin
'Author:  Jeremy England
'Company:    SimplyCoded
'Version:        rev.001
'Date: 	      10/05/2014
'***********************
Option Explicit

RunAsAdmin()

Dim objDomain, User, List, strAccount
Dim strNewPass, status
On Error Resume next

'Find current Users on computer, and select one.
'------------------------------------------------
Set objDomain = GetObject("WinNT://.")
objDomain.Filter = Array("user")
List = Array()
For Each User In objDomain
ReDim Preserve List(UBound(List) + 1)
List(UBound(List)) = User.Name
Next

status = "(Select a username.)"

Do
strAccount = InputBox(status&vbLf&"•"&Join(List, vbLf&"•"),"Password Changer", "Enter a username.")
If IsEmpty(strAccount) Then
 MsgBox "Canceled",vbCritical
 WScript.Quit
ElseIf IsInArray(strAccount, List) Then
 Exit Do
Else
 status = "(User doesn't exist.)"
End If
Loop

'Change password for selected user.
'------------------------------------------------
 status = "(User selected, please enter a new password)"
 strNewPass = InputBox(status&vbLf&"•"&strAccount,"Password Changer", "Enter a new password.")
 If IsEmpty(strNewPass) Then
 MsgBox "Canceled",vbCritical
 WScript.Quit
 Else

 GetObject("WinNT://./" &strAccount& ", user").SetPassword strNewPass
 
  If Err.Number = 0 And Not Err.Number = -2147024810 Then 
  MsgBox "Password for "&strAccount&","&vbLf& "has been changed to """&strNewPass&"""",vbInformation
  WScript.Quit
  Else
  MsgBox Err.Description &vbLf& Err.Number
  End If
 End If

'Functions.
'------------------------------------------------

Function IsInArray(strIn, arrCheck)
Dim bFlag : bFlag = False
 If IsArray(arrCheck) AND Not IsNull(strIn) Then
 Dim i
 For i = 0 to UBound(arrCheck)
  If arrcheck(i) = strIn Then
  bFlag = True
 Exit For
  End If
 Next
 End If
 IsInArray = bFlag
End Function

Function RunAsAdmin()
 Dim objSHL, objAPL
 Set objSHL = WScript.CreateObject("Wscript.Shell")
  If WScript.Arguments.length = 0 Then
  Set objAPL = CreateObject("Shell.Application")
  objAPL.ShellExecute "wscript.exe", """" & _
  WScript.ScriptFullName & """" & _
  " RunAsAdministrator", , "runas", 1
  WScript.Quit
  End If
End Function