Visual Basic Programming Code Examples

Visual Basic > API and Miscellaneous Code Examples

To change a login password use the following routines



To change a login password use the following routines

Option Explicit

'Error message API
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 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
'Network Details API
Private Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
'Password API
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


'Purpose     :  Changes a users password
'Inputs      :  sOldPassword        The old login password.
'               sNewPassword        The new login password.
'Outputs     :  Returns an empty string on success,
'               else returns an error description.
'Notes       :  NT/2000 Only
'Revisions   :

Function UserChangePassword(ByVal sOldPassword As String, ByVal sNewPassword As String) As String
    Dim sUsername As String, sTempsUsername As String * 512
    Dim sDomainControllerName As String
    Dim lErrorNumber As Long
    
    'Get the user domain name
    sDomainControllerName = Environ$("USERDOMAIN")
    If Len(sDomainControllerName) Then
        'Get the Username. Note, Could use Environ("UserName")
        WNetGetUser vbNullString, sTempsUsername, Len(sTempsUsername)
        sUsername = Left$(sTempsUsername, (InStr(1, sTempsUsername, vbNullChar, vbBinaryCompare) - 1))
        'Convert to Unicode
        sUsername = StrConv(sUsername, vbUnicode)
        sOldPassword = StrConv(sOldPassword, vbUnicode)
        sNewPassword = StrConv(sNewPassword, vbUnicode)
        sDomainControllerName = StrConv(sDomainControllerName, vbUnicode)
        lErrorNumber = NetUserChangePassword(sDomainControllerName, sUsername, sOldPassword, sNewPassword)
        If lErrorNumber Then
            UserChangePassword = ErrorDescription(lErrorNumber)
        End If
    End If
End Function


'Converts an error number to an error description
Private Function ErrorDescription(ByVal lCode As Long) As String
    Const FORMAT_MESSAGE_FROM_HMODULE = &H800, FORMAT_MESSAGE_FROM_SYSTEM = &H1000
    Const NERR_BASE = 2100, MAX_NERR = NERR_BASE + 899
    Const LOAD_LIBRARY_AS_DATAFILE = &H2
    
    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)
    lFlags = FORMAT_MESSAGE_FROM_SYSTEM
    
    '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&, LOAD_LIBRARY_AS_DATAFILE)
        If (hModule <> 0) Then
            lFlags = lFlags Or FORMAT_MESSAGE_FROM_HMODULE
        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 (hModule <> 0) Then
        'Unloaded message source
        FreeLibrary hModule
    End If
    
    ErrorDescription = "ERROR: " & lCode & " - " & sRtrnCode
    
    'Clean message
    lRet = InStr(1, ErrorDescription, vbNullChar)
    If lRet Then
        ErrorDescription = Left$(ErrorDescription, lRet - 1)
    End If
    lRet = InStr(1, ErrorDescription, vbNewLine)
    If lRet Then
        ErrorDescription = Left$(ErrorDescription, lRet - 1)
    End If
End Function

'Demonstration routine
Sub Test()
    Debug.Print UserChangePassword("ajb444", "ajb111")
End Sub