CRÉER UN COMPTE UTILISATEUR SOUS WINDOWS NT, 2000 OU XP

'-----------------------------------------------------------------------------------------
'CREATION DE COMPTES UTILISATEUR LOCAUX (Windows NT, 2000, XP)
'-----------------------------------------------------------------------------------------
'
'Version      : 1.2
'Auteur       : Eric Juaneda
'Création     : 4 décembre 2005
'Modification : 23 août 2006
'-----------------------------------------------------------------------------------------
Option Explicit
  
Private Const UF_SCRIPT = &H1
Private Const UF_ACCOUNTDISABLE = &H2
Private Const UF_NORMAL_ACCOUNT = &H200
Private Const UF_LOCKOUT = &H10

Private Const USER_PRIV_USER = 1
Private Const TIMEQ_FOREVER = -1

'Private Const NERR_BASE = 2100
'Private Const NERR_UserNotFound = (NERR_BASE + 121) '/* The user name could not be found. */
'Private Const NERR_BadUsername = (NERR_BASE + 102) '/* The user name or group name parameter is invalid. */
'Private Const NERR_UserExists = (NERR_BASE + 124)
'Private Const NERR_PasswordTooShort = (NERR_BASE + 145) '/* The password does not meet the password policy requirements. Check the minimum password length, password complexity and password history requirements. */
  
  
Private Type LOCALGROUP_MEMBERS_INFO_3
    lgrmi3_domainandname As Long
End Type
  
Private Type USER_INFO_2
  usri2_name As Long 'LPWSTR
  usri2_password As Long 'LPWSTR
  usri2_password_age As Long 'DWORD
  usri2_priv As Long 'DWORD
  usri2_home_dir As Long 'LPWSTR
  usri2_comment As Long 'LPWSTR
  usri2_flags As Long 'DWORD
  usri2_script_path As Long 'LPWSTR
  usri2_auth_flags As Long 'DWORD
  usri2_full_name As Long 'LPWSTR
  usri2_usr_comment As Long 'LPWSTR
  usri2_parms As Long 'LPWSTR
  usri2_workstations As Long 'LPWSTR
  usri2_last_logon As Long 'DWORD
  usri2_last_logoff As Long 'DWORD
  usri2_acct_expires As Long 'DWORD
  usri2_max_storage As Long 'DWORD
  usri2_units_per_week As Long 'DWORD
  usri2_logon_hours As Long 'PBYTE
  usri2_bad_pw_count As Long 'DWORD
  usri2_num_logons As Long 'DWORD
  usri2_logon_server As Long 'LPWSTR
  usri2_country_code As Long 'DWORD
  usri2_code_page As Long 'DWORD
End Type
  
  
Private Type USER_INFO_1003
    usri1003_password As Long
End Type
  
Private Type USER_INFO_1008
    usri1008_flags As Long
End Type
  
  
'API Unicode
Private Declare Function NetLocalGroupAddMembers Lib "Netapi32" (ByVal ServerName As Long, ByVal GroupName As Long, ByVal Level As Long, buf As Any, ByVal TotalEntries As Long) As Long
Private Declare Function NetLocalGroupDelMembers Lib "Netapi32" (ByVal ServerName As Long, ByVal GroupName As Long, ByVal Level As Long, buf As Any, ByVal TotalEntries As Long) As Long
Private Declare Function NetUserSetInfo Lib "Netapi32" (ByVal ServerName As Long, ByVal UserName As Long, ByVal Level As Long, buf As Any, Parm_Err As Long) As Long
Private Declare Function NetUserDel Lib "Netapi32" (ByVal ServerName As Long, ByVal UserName As Long) As Long
  
Private Declare Function NetUserAdd Lib "Netapi32" (ByVal ServerName As Long, ByVal Level As Long, buf As Any, Parm_Err As Long) As Long
  
Sub Main()
    Dim UserName As String
     
    UserName = "Einstein"
     
    CreateUser UserName, "albert", "Compte utilisé pour les calculs"
    AddUserInGroup UserName, "Administrateurs"
    DisableUser UserName
    ChangePassword UserName, "albert2"
     
End Sub
  
'Crée un compte utilisateur local
'<retour> 1 = Ok, 0 = Erreur
Private Function CreateUser(UserName As String, Password As String, Comment As String) As Long
    Dim Buffer As USER_INFO_2
    Dim rc As Long, Trap As Long, Size As Long
     
    
    With Buffer 'USER_INFO_2
        .usri2_name = StrPtr(UserName)
        .usri2_password = StrPtr(Password)
        .usri2_priv = USER_PRIV_USER '<--Ne pas mettre une autre valeur
        .usri2_comment = StrPtr(Comment)
        .usri2_flags = UF_NORMAL_ACCOUNT Or UF_SCRIPT Or UF_LOCKOUT
         
        .usri2_full_name = 0
        .usri2_acct_expires = TIMEQ_FOREVER 'Le compte n'expire jamais
    End With
  
  
    rc = NetUserAdd(0&, 2&, Buffer, Trap)
    '0 Ok
    '2202 NERR_BadUsername
    '2224 NERR_UserExists
    '2245 NERR_PasswordTooShort
    '87 ERROR_INVALID_PARAMETER
    '5 ERROR_ACCESS_DENIED
    If rc = 2224 Then rc = 0 'Le compte existe déjà
     
    If rc = 0 Then CreateUser = 1 'Code retour Ok
    
End Function
  
'Désactive un compte local
'<retour> 1 = Ok, 0 = Erreur
Public Function DisableUser(UserName As String) As Long
    Dim Buffer As USER_INFO_1008
    Dim rc As Long, Trap As Long
     
    Buffer.usri1008_flags = UF_SCRIPT Or UF_LOCKOUT Or UF_ACCOUNTDISABLE
    
    rc = NetUserSetInfo(0&, StrPtr(UserName), 1008&, Buffer, Trap)
     
    If rc = 0 Then DisableUser = 1 'Code retour Ok
     
End Function
  
'Change le mot de passe d'un compte utilisateur
'<retour> 1 = Ok, 0 = Erreur
Public Function ChangePassword(UserName As String, NewPassword As String) As Long
    Dim Buffer As USER_INFO_1003
    Dim rc As Long, Trap As Long
         
    Buffer.usri1003_password = StrPtr(NewPassword)
     
    rc = NetUserSetInfo(0&, StrPtr(UserName), 1003&, Buffer, Trap)
    '0 Ok
    '87 ERROR_INVALID_PARAMETER
     
    If rc = 0 Then ChangePassword = 1 'Code retour Ok
     
End Function
  
'Ajoute un compte à un groupe local
'<retour> 1 = Ok, 0 = Erreur
Public Function AddUserInGroup(UserName As String, GroupName As String) As Long
    Dim Buffer As LOCALGROUP_MEMBERS_INFO_3
    Dim rc As Long, Level As Long
     
     
'If UserName = "" Then iLastError = ERROR_INVALID_SERVICE_ACCOUNT: Exit Function
'If GroupName = "" Then iLastError = ERROR_INVALID_GROUPNAME: Exit Function
'If Len(UserName) > 20 Then iLastError = ERROR_INVALID_SERVICE_ACCOUNT: Exit Function '20 caractères maximum
     
  
'Rempli les données entrantes
    Buffer.lgrmi3_domainandname = StrPtr(UserName)
     
    'Travail en local
    rc = NetLocalGroupAddMembers(0&, StrPtr(GroupName), 3&, Buffer, 1)
    If rc = 1378 Then rc = 0
    '1387 ERROR_NO_SUCH_MEMBER Utilisateur inéxistant
    '1378 ERROR_MEMBER_IN_ALIAS Utilisateur déjà existant
    '5 ERROR_ACCESS_DENIED Accès refusé
     
'Code retour Ok
    If rc = 1378 Then rc = 0 'Utilisateur déjà dans le groupe
    If rc = 0 Then AddUserInGroup = 1
  
End Function