Private Sub Form_Load()
    success = ChangePassword("Benutzername", "Neues Kennwort")
    MsgBox success
End Sub
 
 
Declare Function NetUserChangePassword Lib "NETAPI32.DLL" (DomainName As Byte, UserName As Byte, OldPwd As Byte, NewPwd As Byte) As Long
Declare Function NetAPIBufferAllocate Lib "NETAPI32.DLL" Alias "NetApiBufferAllocate" (ByVal ByteCount As Long, Ptr As Long) As Long
Declare Function StrToPtr Lib "kernel32" Alias "lstrcpyW" (ByVal Ptr As Long, Source As Byte) As Long
Declare Function NetUserSetInfo Lib "NETAPI32.DLL" (ServerName As Byte, UserName As Byte, ByVal Level As Long, Buffer As TUser1, ParmError As Long) As Long
Declare Function NetAPIBufferFree Lib "NETAPI32.DLL" Alias "NetApiBufferFree" (ByVal Ptr As Long) As Long
 
 Type TUser1
     ptrName As Long
     ptrPassword As Long
     dwPasswordAge As Long
     dwPriv As Long
     ptrHomeDir As Long
     ptrComment As Long
     dwFlags As Long
     ptrScriptPath As Long
End Type
 
Public Function ChangePassword(ByVal Uname As String, ByVal PWD As String) As Long
    Dim Result As Long, UNPtr As Long, PWDPtr As Long, ParmError As Long
    Dim SNArray() As Byte, UNArray() As Byte, PWDArray() As Byte
    Dim UserStruct As TUser1
    If Not EsOkUserName(Uname) Then
        ChangePassword = 1000
        Exit Function
    End If
   
    On Error GoTo Errorhandler
 
    SNArray = "" & vbNullChar
    UNArray = Uname & vbNullChar
    PWDArray = PWD & vbNullChar 'UnPass1
 
    Result = NetAPIBufferAllocate(UBound(UNArray) + 1, UNPtr)
    Result = NetAPIBufferAllocate(UBound(PWDArray) + 1, PWDPtr)
 
    Result = StrToPtr(UNPtr, UNArray(0))
    Result = StrToPtr(PWDPtr, PWDArray(0))
 
    With UserStruct
        .ptrName = UNPtr
        .ptrPassword = PWDPtr
        '.dwPasswordAge = 3
        '.dwPriv = USER_PRIV_USER
        '.ptrHomeDir = 0
        '.ptrComment = 0
        .dwFlags = UF_NORMAL_ACCOUNT Or UF_SCRIPT Or UF_PASSWD_CANT_CHANGE Or UF_DONT_EXPIRE_PASSWD
        '.dwFlags = &H10220
        '.ptrScriptPath = 0
    End With
     
    Result = NetUserSetInfo(SNArray(0), UNArray(0), 1, UserStruct, ParmError)
    ChangePassword = Result
    'MsgBox ("res:" & Result & " , param :" & ParmError)
    Result = NetAPIBufferFree(UNPtr)
    Result = NetAPIBufferFree(PWDPtr)
    Exit Function
 
Errorhandler:
     ChangePassword = CLng(Err.Number)
   End Function
 
Function EsOkUserName(ByVal Uname As String) As Boolean
    Dim lon As Integer, t As Integer
    Dim it As String
 
    EsOkUserName = True
 
    lon = Len(Uname)
    If lon > 0 Then
        For t = 1 To lon
            it = Mid(Uname, t, 1)
            If InStr(CARACTERES_ERRONEOS, it) > 0 Then
                EsOkUserName = False
                Exit For
            End If
        Next
    Else
        EsOkUserName = False
    End If
End Function