'**************************************
'Windows API/Global Declarations for :Cr
' eate/Destroy User on Domain ( Administra
' ting NT)
'**************************************
'Jeff Hong YAN 11/20/96 modified on 4/18
' /97
'This module shows how to create / destr
' oy a user account.
'Modified according to MS KB article Q15
' 9498
'You must have account operator's right
' to run
' for dwPriv
Const USER_PRIV_MASK = &H3
Const USER_PRIV_GUEST = &H0
Const USER_PRIV_USER = &H1
Const USER_PRIV_ADMIN = &H2
' for dwFlags
Const UF_SCRIPT = &H1
Const UF_ACCOUNTDISABLE = &H2
Const UF_HOMEDIR_REQUIRED = &H8
Const UF_LOCKOUT = &H10
Const UF_PASSWD_NOTREQD = &H20
Const UF_PASSWD_CANT_CHANGE = &H40
Const UF_NORMAL_ACCOUNT = &H200



Declare Function StrToPtr Lib "kernel32" Alias "lstrcpyW" ( _
    ByVal Ptr As Long, Source As Byte) As Long
    ' Add using Level 1 user structure


Declare Function NetUserAdd1 Lib "NETAPI32.DLL" Alias "NetUserAdd" _
    (ServerName As Byte, ByVal Level As Long, Buffer As TUser1, lParmError _
    As Long) As Long


Declare Function NetUserDel Lib "NETAPI32.DLL" (ServerName As Byte, _
    UserName As Byte) As Long


Type TUser1' Level 1
    ptrName As Long
    ptrPassword As Long
    dwPasswordAge As Long
    dwPriv As Long
    ptrHomeDir As Long
    ptrComment As Long
    dwFlags As Long
    ptrScriptHomeDir As Long
    End Type


Declare Function NetAPIBufferFree Lib "NETAPI32.DLL" Alias _
    "NetApiBufferFree" (ByVal Ptr As Long) As Long


Declare Function NetAPIBufferAllocate Lib "NETAPI32.DLL" Alias _
    "NetApiBufferAllocate" (ByVal ByteCount As Long, Ptr As Long) As Long




'**************************************
' Name: Create/Destroy User on Domain (
' Administrating NT)
' Description:Create a new user and dest
' roy an existing user on a Windows NT dom
' ain..
When a user is
created, I Set him To be a member of Domain Users While you can specify that he goes
into Domain User, Domain Guests, Domain Admins
Hong YAN <HONG-YAN@worldnet.att.net>
' By: Newsgroup Posting
'
'
' Inputs:None
'
' Returns:None
'
'Assumes:None
'
'Side Effects:None
'
'Warranty:
'code provided by Planet Source Code(tm)
' (http://www.Planet-Source-Code.com) 'as
' is', without warranties as to performanc
' e, fitness, merchantability,and any othe
' r warranty (whether expressed or implied
' ).
'Terms of Agreement:
'By using this source code, you agree to
' the following terms...
' 1) You may use this source code in per
' sonal projects and may compile it into a
' n .exe/.dll/.ocx and distribute it in bi
' nary format freely and with no charge.
' 2) You MAY NOT redistribute this sourc
' e code (for example to a web site) witho
' ut written permission from the original
' author.Failure to do so is a violation o
' f copyright laws.
' 3) You may link to this code from anot
' her website, provided it is not wrapped
' in a frame.
' 4) The author of this code may have re
' tained certain additional copyright righ
' ts.If so, this is indicated in the autho
' r's description.
'**************************************



Function DomainCreateUser( _
    ByVal sSName As String, _
    ByVal sUName As String, _
    ByVal sPWD As String, _
    ByVal sHomeDir As String, _
    ByVal sComment As String, _
    ByVal sScriptFile As String) As Long
    'Create a new user to be a member of gro
    ' up Domain Users
    Dim lResult As Long
    Dim lParmError As Long
    Dim lUNPtr As Long
    Dim lPWDPtr As Long
    Dim lHomeDirPtr As Long
    Dim lCommentPtr As Long
    Dim lScriptFilePtr As Long
    Dim bSNArray() As Byte
    Dim bUNArray() As Byte
    Dim bPWDArray() As Byte
    Dim bHomeDirArray() As Byte
    Dim bCommentArray() As Byte
    Dim bScriptFileArray() As Byte
    Dim UserStruct As TUser1

    ' Move to byte arrays
    bSNArray = sSName & vbNullChar
    bUNArray = sUName & vbNullChar
    bPWDArray = sPWD & vbNullChar
    bHomeDirArray = sHomeDir & vbNullChar
    bCommentArray = sComment & vbNullChar
    bScriptFileArray = sScriptFile & vbNullChar
    ' Allocate buffer space
    lResult = NetAPIBufferAllocate(UBound(bUNArray) + 1, lUNPtr)
    lResult = NetAPIBufferAllocate(UBound(bPWDArray) + 1, lPWDPtr)
    lResult = NetAPIBufferAllocate(UBound(bHomeDirArray) + 1, lHomeDirPtr)
    lResult = NetAPIBufferAllocate(UBound(bCommentArray) + 1, lCommentPtr)
    lResult = NetAPIBufferAllocate(UBound(bScriptFileArray) + 1, lScriptFilePtr)
    ' Copy arrays to the buffer
    lResult = StrToPtr(lUNPtr, bUNArray(0))
    lResult = StrToPtr(lPWDPtr, bPWDArray(0))
    lResult = StrToPtr(lHomeDirPtr, bHomeDirArray(0))
    lResult = StrToPtr(lCommentPtr, bCommentArray(0))
    lResult = StrToPtr(lScriptFilePtr, bScriptFileArray(0))


    With UserStruct
        .ptrName = lUNPtr
        .ptrPassword = lPWDPtr
        .dwPasswordAge = 3
        .dwPriv = USER_PRIV_USER
        .ptrHomeDir = lHomeDirPtr
        .ptrComment = lCommentPtr
        .dwFlags = UF_NORMAL_ACCOUNT Or UF_SCRIPT
        .ptrScriptHomeDir = lScriptFilePtr
    End With
    ' Create the new user
    lResult = NetUserAdd1(bSNArray(0), 1, UserStruct, lParmError)


    DomainCreateUser = lResult


        If lResult <> 0 Then
            Call NetErrorHandler(lResult, " when creating new user " & sUName)
        End If
        ' Release buffers from memory
        lResult = NetAPIBufferFree(lUNPtr)
        lResult = NetAPIBufferFree(lPWDPtr)
        lResult = NetAPIBufferFree(lHomeDirPtr)
        lResult = NetAPIBufferFree(lCommentPtr)
        lResult = NetAPIBufferFree(lScriptFilePtr)
    End Function


Public Function DomainDestroyUser(ByVal sSName As String, ByVal sUName As String)
    'Destroy an existing user with user id s
    ' UName
    'from current PDC with sSName
    Dim lResult As Long
    Dim lParmError As Long
    Dim bSNArray() As Byte
    Dim bUNArray() As Byte

    ' Move to byte arrays
    bSNArray = sSName & vbNullChar
    bUNArray = sUName & vbNullChar
    lResult = NetUserDel(bSNArray(0), bUNArray(0))


    If lResult = 0 Then


        DomainDestroyUser = True
        Else
            Call NetErrorHandler(lResult, "delete user '" & sUName & "' from server '" &
            sSName & "'.")


            DomainDestroyUser = False
            End If
        End Function