Tech blog to share information.

June 26, 2010

Change Windows Password : VB code

June 26, 2010 Posted by tjcool 1 comment
While surfing i Found this code which.This code is in Visual basic 6.0.If the program run under a non-administrator on the target machine/domain, the NetUserChangePassword() function call can be used to override the existing password.

Option Explicit
'Api Declaration

Const NERR_BASE = 2100
Const MAX_NERR = NERR_BASE + 899 ' This is the last error in
' NERR range.

Private Declare Function LoadLibraryEx Lib "kernel32" Alias _
"LoadLibraryExA" (ByVal lpLibFileName As String, _
ByVal hFile As Long, ByVal dwFlags As Long) As Long

Private Declare Function FreeLibrary Lib "kernel32" _
(ByVal hLibModule As Long) As Long

Private Declare Function NetApiBufferFree& Lib "netapi32" _
(ByVal Buffer As Long)

Private Declare Sub lstrcpyW Lib "kernel32" _
(dest As Any, ByVal src As Any)

Private Declare Function FormatMessage Lib "kernel32" Alias _
"FormatMessageA" (ByVal dwFlags As Long, _
ByVal lpSource As Long, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, ByVal lpBuffer As String, _
ByVal nSize As Long, Arguments As Any) As Long

Private Declare Function NetUserSetInfo Lib "netapi32.dll" _
(ByVal ServerName As String, ByVal Username As String, _
ByVal Level As Long, UserInfo As Any, ParmError As Long) As Long

Private Declare Function NetGetDCName Lib "netapi32.dll" ( _
ServerName As Long, domainname As Byte, bufptr As Long) As Long

Private Declare Function NetUserChangePassword Lib "netapi32.dll" ( _
ByVal domainname As String, ByVal Username As String, _
ByVal OldPassword As String, ByVal NewPassword As String) As Long

Private Type USER_INFO_1003
usri1003_password As Long
End Type

'Close Button Code
Private Sub cmdClose_Click()
Unload Me
End Sub
'Set Password

Private Sub cmdOK_Click()
Dim sServer As String, sUser As String
Dim sNewPass As String, sOldPass As String
Dim UI1003 As USER_INFO_1003
Dim dwLevel As Long
Dim lRet As String
Dim sNew As String

' StrConv Functions are necessary since VB will perform
' UNICODE/ANSI translation before passing strings to the NETAPI
' functions

MousePointer = vbHourglass
sUser = StrConv(txtUser, vbUnicode)
sNewPass = StrConv(txtNew, vbUnicode)

'See if this is Domain or Computer referenced
If Left(txtMachine, 2) = "\\" Then
sServer = StrConv(txtMachine, vbUnicode)
' Domain was referenced, get the Primary Domain Controller
sServer = StrConv(GetPrimaryDCName(txtMachine), vbUnicode)
End If

If txtOld = "" Then
' Administrative over-ride of existing password.
' Does not require old password

dwLevel = 1003
sNew = txtNew
UI1003.usri1003_password = StrPtr(sNew)
lRet = NetUserSetInfo(sServer, sUser, dwLevel, UI1003, 0&)
' Set the Old Password and attempt to change the user's password
sOldPass = StrConv(txtOld, vbUnicode)
lRet = NetUserChangePassword(sServer, sUser, sOldPass, sNewPass)
End If

MousePointer = vbDefault
If lRet <> 0 Then
DisplayError lRet
MsgBox "Password Change was Successful"
End If

End Sub
Private Sub DisplayError(ByVal lCode As Long)
Dim sMsg As String
Dim sRtrnCode As String
Dim lFlags As Long
Dim hModule As Long
Dim lRet As Long

hModule = 0
sRtrnCode = Space$(256)

' if lRet is in the network range, load the message source

If (lCode >= NERR_BASE And lCode <= MAX_NERR) Then
hModule = LoadLibraryEx("netmsg.dll", 0&, _

If (hModule <> 0) Then
End If

End If

' Call FormatMessage() to allow for message text to be acquired
' from the system or the supplied module handle.

lRet = FormatMessage(lFlags, hModule, lCode, 0&, _
sRtrnCode, 256&, 0&)
If lRet = 0 Then
MsgBox "FormatMessage Error : " & Err.LastDllError
End If

' if you loaded a message source, unload it.
If (hModule <> 0) Then
FreeLibrary (hModule)
End If
'//... now display this string
sMsg = "ERROR: " & lCode & " - " & sRtrnCode
MsgBox sMsg
End Sub
Public Function GetPrimaryDCName(ByVal DName As String) As String

Dim DCName As String, DCNPtr As Long
Dim DNArray() As Byte, DCNArray(100) As Byte
Dim result As Long

DNArray = DName & vbNullChar
' Lookup the Primary Domain Controller
result = NetGetDCName(0&, DNArray(0), DCNPtr)
If result <> 0 Then
Msgbox "Error: " & result
Exit Function
End If
lstrcpyW DCNArray(0), DCNPtr
result = NetApiBufferFree(DCNPtr)
DCName = DCNArray()
GetPrimaryDCName = Left(DCName, InStr(DCName, Chr(0)) - 1)

End Function


Anonymous said...

Very nice article. I definitely love this website.
Continue the good work!

Visit my site :: Ty