Hej,
Du skal bruge NETAPI32 dll'et, og sikre dig at have de fornødne rettigheder i NT når du kører din kode...
Ellers er det noget med at lege med nedenstående kode...
Option Explicit
Option Base 0 ' Important assumption for this code
Type MungeLong
X As Long
Dummy As Integer
End Type
Type MungeInt
XLo As Integer
XHi As Integer
Dummy As Integer
End Type
Type TUser0 ' Level 0
ptrName As Long
End Type
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
ptrScriptPath As Long
End Type
'
' 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 ' Needs to be ORed with the
' other flags
'
' for lFilter
'
Const FILTER_NORMAL_ACCOUNT = &H2
Declare Function NetGetDCName Lib "NETAPI32.DLL" (ServerName As Byte, _
DomainName As Byte, DCNPtr As Long) As Long
Declare Function NetUserDel Lib "NETAPI32.DLL" (ServerName As Byte, _
UserName As Byte) As Long
Declare Function NetGroupAddUser Lib "NETAPI32.DLL" (ServerName As _
Byte, GroupName As Byte, UserName As Byte) As Long
Declare Function NetGroupDelUser Lib "NETAPI32.DLL" (ServerName As _
Byte, GroupName As Byte, UserName 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, ParmError _
As Long) As Long
' Enumerate using Level 0 user structure
Declare Function NetUserEnum0 Lib "NETAPI32.DLL" Alias "NetUserEnum" _
(ServerName As Byte, ByVal Level As Long, ByVal lFilter As Long, _
Buffer As Long, ByVal PrefMaxLen As Long, EntriesRead As Long, _
TotalEntries As Long, ResumeHandle As Long) As Long
Declare Function NetGroupEnumUsers0 Lib "NETAPI32.DLL" Alias _
"NetGroupGetUsers" (ServerName As Byte, GroupName As Byte, _
ByVal Level As Long, Buffer As Long, ByVal PrefMaxLen As Long, _
EntriesRead As Long, TotalEntries As Long, ResumeHandle As Long) As Long
Declare Function NetGroupEnum0 Lib "NETAPI32.DLL" Alias "NetGroupEnum" _
(ServerName As Byte, ByVal Level As Long, Buffer As Long, ByVal _
PrefMaxLen As Long, EntriesRead As Long, TotalEntries As Long, _
ResumeHandle As Long) As Long
Declare Function NetUserGetGroups0 Lib "NETAPI32.DLL" Alias _
"NetUserGetGroups" (ServerName As Byte, UserName As Byte, _
ByVal Level As Long, Buffer As Long, ByVal PrefMaxLen As Long, _
EntriesRead As Long, TotalEntries As Long) As Long
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
Declare Function PtrToStr Lib "Kernel32" Alias "lstrcpyW" _
(RetVal As Byte, ByVal Ptr As Long) As Long
Declare Function StrToPtr Lib "Kernel32" Alias "lstrcpyW" _
(ByVal Ptr As Long, Source As Byte) As Long
Declare Function PtrToInt Lib "Kernel32" Alias "lstrcpynW" _
(RetVal As Any, ByVal Ptr As Long, ByVal nCharCount As Long) As Long
Declare Function StrLen Lib "Kernel32" Alias "lstrlenW" _
(ByVal Ptr As Long) As Long
Function AddUserToGroup(ByVal SName As String, _
ByVal GName As String, ByVal UName As String) As Long
'
' This only adds users to global groups - not to local groups
'
Dim SNArray() As Byte, GNArray() As Byte, UNArray() As Byte, _
Result As Long
SNArray = SName & vbNullChar
GNArray = GName & vbNullChar
UNArray = UName & vbNullChar
Result = NetGroupAddUser(SNArray(0), GNArray(0), UNArray(0))
If Result = 2220 Then Debug.Print _
"There is no **GLOBAL** group '" & GName & "'"
AddUserToGroup = Result
End Function
Function DelUser(ByVal SName As String, ByVal UName As String) As Long
Dim UNArray() As Byte, SNArray() As Byte
UNArray = UName & vbNullChar
SNArray = SName & vbNullChar
DelUser = NetUserDel(SNArray(0), UNArray(0))
End Function
Function DelUserFromGroup(ByVal SName As String, _
ByVal GName As String, ByVal UName As String) As Long
'
' This only deletes users from global groups - not local groups
'
Dim SNArray() As Byte, GNArray() As Byte, UNArray() As Byte, _
Result As Long
SNArray = SName & vbNullChar
GNArray = GName & vbNullChar
UNArray = UName & vbNullChar
Result = NetGroupDelUser(SNArray(0), GNArray(0), UNArray(0))
If Result = 2220 Then Debug.Print _
"There is no **GLOBAL** group '" & GName & "'"
DelUserFromGroup = Result
End Function
Function EnumerateGroups(ByVal SName As String, _
ByVal UName As String) As Long
'
' Enumerates global groups only - not local groups
'
' The buffer is filled from the left with pointers to user names that
' are filled from the right side. For example:
'
' ptr1|ptr2|...|ptrn|<garbage>|strn|...|str2|str1
' ^-------------- BufPtr buffer ----------------^
'
' On NT, TotalEntries is the number of entries left to be read including
' the currently read entries.
'
' On LanMan and OS/2, it is the total number of entries, period. Code
' would have to be changed to reflect this if the Domain controller
' wasn't an NT machine.
'
' BufPtr gets the address of the buffer (or ptr1 - add 4 to BufPtr for
' each additional pointer)
'
Dim Result As Long, BufPtr As Long, EntriesRead As Long, _
TotalEntries As Long, ResumeHandle As Long, BufLen As Long, _
SNArray() As Byte, GNArray(99) As Byte, UNArray() As Byte, _
GName As String, I As Integer, UNPtr As Long, _
TempPtr As MungeLong, TempStr As MungeInt
SNArray = SName & vbNullChar ' Move to byte array
UNArray = UName & vbNullChar ' Move to Byte array
BufLen = 255 ' Buffer size
ResumeHandle = 0 ' Start with the first entry
Do
If UName = "" Then
Result = NetGroupEnum0(SNArray(0), 0, BufPtr, BufLen, _
EntriesRead, TotalEntries, ResumeHandle)
Else
Result = NetUserGetGroups0(SNArray(0), UNArray(0), 0, BufPtr, _
BufLen, EntriesRead, TotalEntries)
End If
EnumerateGroups = Result
If Result <> 0 And Result <> 234 Then ' 234 means multiple reads
' required
Debug.Print "Error " & Result & " enumerating group " & _
EntriesRead & " of " & TotalEntries
Exit Function
End If
For I = 1 To EntriesRead
' Get pointer to string from beginning of buffer
' Copy 4 byte block of memory in 2 steps
Result = PtrToInt(TempStr.XLo, BufPtr + (I - 1) * 4, 2)
Result = PtrToInt(TempStr.XHi, BufPtr + (I - 1) * 4 + 2, 2)
LSet TempPtr = TempStr ' munge 2 Integers to a Long
' Copy string to array and convert to a string
Result = PtrToStr(GNArray(0), TempPtr.X)
GName = Left(GNArray, StrLen(TempPtr.X))
Debug.Print "Group: " & GName
Next I
Loop Until EntriesRead = TotalEntries
' The above condition only valid for reading accounts on NT
' but not OK for OS/2 or LanMan
Result = NetAPIBufferFree(BufPtr) ' Don't leak memory
End Function
Function EnumerateUsers(ByVal SName As String, ByVal GName As String) _
As Long
'
' If a group name is specified, it must be a global group
' and not a local group.
'
' The buffer is filled from the left with pointers to user names that
' are filled from the right side. For example:
'
' ptr1|ptr2|...|ptrn|<garbage>|strn|...|str2|str1
' ^-------------- BufPtr buffer ----------------^
'
' On Windows NT, TotalEntries is the number of entries left to be read,
' including the currently read entries.
' On LanMan and OS/2, it is the total number of entries, period. Code
' would have to be changed to reflect this if the Domain controller
' wasn't an NT machine.
'
' BufPtr gets the address of the buffer (or ptr1 - add 4 to BufPtr for
' each additional pointer)
'
' SName should be "\\servername"
'
Dim Result As Long, BufPtr As Long, EntriesRead As Long, _
TotalEntries As Long, ResumeHandle As Long, BufLen As Long, _
SNArray() As Byte, GNArray() As Byte, UNArray(99) As Byte, _
UName As String, I As Integer, UNPtr As Long, TempPtr As MungeLong, _
TempStr As MungeInt
SNArray = SName & vbNullChar ' Move to byte array
GNArray = GName & vbNullChar ' Move to Byte array
BufLen = 255 ' Buffer size
ResumeHandle = 0 ' Start with the first entry
Do
If GName = "" Then
Result = NetUserEnum0(SNArray(0), 0, FILTER_NORMAL_ACCOUNT, _
BufPtr, BufLen, EntriesRead, TotalEntries, ResumeHandle)
Else
Result = NetGroupEnumUsers0(SNArray(0), GNArray(0), 0, BufPtr, _
BufLen, EntriesRead, TotalEntries, ResumeHandle)
End If
EnumerateUsers = Result
If Result <> 0 And Result <> 234 Then ' 234 means multiple reads
' required
Debug.Print "Error " & Result & " enumerating user " _
& EntriesRead & " of " & TotalEntries
If Result = 2220 Then Debug.Print _
"There is no **GLOBAL** group '" & GName & "'"
Exit Function
End If
For I = 1 To EntriesRead
' Get pointer to string from beginning of buffer
' Copy 4-byte block of memory in 2 steps
Result = PtrToInt(TempStr.XLo, BufPtr + (I - 1) * 4, 2)
Result = PtrToInt(TempStr.XHi, BufPtr + (I - 1) * 4 + 2, 2)
LSet TempPtr = TempStr ' munge 2 integers into a Long
' Copy string to array
Result = PtrToStr(UNArray(0), TempPtr.X)
UName = Left(UNArray, StrLen(TempPtr.X))
Debug.Print "User: " & UName
Next I
Loop Until EntriesRead = TotalEntries
' The above condition is only valid for reading accounts on Windows NT,
' but is not OK for OS/2 or LanMan
Result = NetAPIBufferFree(BufPtr) ' Don't leak memory
End Function
Function GetPrimaryDCName(ByVal MName As String, _
ByVal DName As String) As String
Dim Result As Long, DCName As String, DCNPtr As Long
Dim DNArray() As Byte, MNArray() As Byte, DCNArray(100) As Byte
MNArray = MName & vbNullChar
DNArray = DName & vbNullChar
Result = NetGetDCName(MNArray(0), DNArray(0), DCNPtr)
If Result <> 0 Then
Debug.Print "Error: " & Result
Exit Function
End If
Result = PtrToStr(DCNArray(0), DCNPtr)
Result = NetAPIBufferFree(DCNPtr)
DCName = DCNArray()
GetPrimaryDCName = DCName
End Function
Function AddUser(ByVal SName As String, 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
'
' Move to byte arrays
'
SNArray = SName & vbNullChar
UNArray = UName & vbNullChar
PWDArray = PWD & vbNullChar
'
' Allocate buffer space
'
Result = NetAPIBufferAllocate(UBound(UNArray) + 1, UNPtr)
Result = NetAPIBufferAllocate(UBound(PWDArray) + 1, PWDPtr)
'
' Copy arrays to the buffer
'
Result = StrToPtr(UNPtr, UNArray(0))
Result = StrToPtr(PWDPtr, PWDArray(0))
'
' Fill the structure
'
With UserStruct
.ptrName = UNPtr
.ptrPassword = PWDPtr
.dwPasswordAge = 3
.dwPriv = USER_PRIV_USER
.ptrHomeDir = 0
.ptrComment = 0
.dwFlags = UF_NORMAL_ACCOUNT Or UF_SCRIPT
.ptrScriptPath = 0
End With
'
' Add the user
'
Result = NetUserAdd1(SNArray(0), 1, UserStruct, ParmError)
AddUser = Result
If Result <> 0 Then
Debug.Print "Error " & Result & " in parameter " & ParmError _
& " when adding user " & UName
End If
'
' Release buffers from memory
'
Result = NetAPIBufferFree(UNPtr)
Result = NetAPIBufferFree(PWDPtr)
End Function
Ny bruger
Nybegynder
Opret
Preview
