Change a windows user's password. This requires that you know the old password.

ChangePassword.vbs

'***********************
'Name:   Change Password
'Author:  Jeremy England
'Company:    SimplyCoded
'Version:        rev.001
'Date: 	      10/05/2014
'***********************
Option Explicit
Dim objDomain, User, List
Dim strAccount, strNewPass, strOldPass, 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
End If

GetObject("WinNT://./" &strAccount& ", user").ChangePassword "" , strNewPass
Select Case Err.Number 
Case 0 
MsgBox "Password for "&strAccount&","&vbLf& "has been changed to """&strNewPass&"""",vbInformation
WScript.Quit
Case -2147024810
status = "(For security purposes, enter current password.)"
Do
Err.Clear
 strOldPass = InputBox(status&vbLf&"•"&strAccount,"Password Changer", "Enter current password.")
 If IsEmpty(strOldPass) Then
 MsgBox "Canceled",vbCritical
 WScript.Quit  
 Else
 GetObject("WinNT://./" &strAccount& ", user").ChangePassword strOldPass, strNewPass
 End If
 status = "(Incorrect current password, try again.)"
Loop Until Not Err.Number = -2147024810 And Err.Number = 0
 MsgBox "Password for "&strAccount&","&vbLf& "has been changed to """&strNewPass&"""",vbInformation
End Select

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