codice:
'###################################################################
' GESTIONE UTENTI/GRUPPI
'###################################################################
'===================================================================
' COSTANTI E API PER UTENTI E GRUPPI DI RETE
'===================================================================
Public Declare Function NetGroupAdd1 Lib "NETAPI32.dll" Alias "NetGroupAdd" _
(servername As Byte, ByVal Level As Long, Buffer As GROUP_INFO_1, ParmError As Long) As Long
Public Declare Function NetGroupDel Lib "NETAPI32.dll" _
(servername As Byte, groupname As Byte) As Long
Public Declare Function NetGroupAddUser Lib "NETAPI32.dll" _
(servername As Byte, groupname As Byte, UserName As Byte) As Long
Public Declare Function NetGroupDelUser Lib "NETAPI32.dll" _
(servername As Byte, groupname As Byte, UserName As Byte) As Long
Public Declare Function NetLocalGroupAdd1 Lib "NETAPI32.dll" Alias "NetLocalGroupAdd" _
(servername As Byte, ByVal Level As Long, Buffer As GROUP_INFO_1, ParmError As Long) As Long
Public Declare Function NetLocalGroupDel Lib "NETAPI32.dll" _
(servername As Byte, groupname As Byte) As Long
Public Declare Function NetLocalGroupAddMembers Lib "NETAPI32.dll" _
(servername As Byte, groupname As Byte, ByVal Level As Long, buf As LOCALGROUP_MEMBERS_INFO_3, _
ByVal totalentries As Long) As Long
Public Declare Function NetLocalGroupDelMembers Lib "NETAPI32.dll" _
(servername As Byte, groupname As Byte, ByVal Level As Long, buf As LOCALGROUP_MEMBERS_INFO_3, _
ByVal totalentries As Long) As Long
Public Declare Function NetAPIBufferFree Lib "NETAPI32.dll" Alias _
"NetApiBufferFree" (ByVal Ptr As Long) As Long
Public Declare Function NetAPIBufferAllocate Lib "NETAPI32.dll" Alias _
"NetApiBufferAllocate" (ByVal ByteCount As Long, Ptr As Long) As Long
Public Declare Function StrToPtr Lib "Kernel32" Alias "lstrcpyW" _
(ByVal Ptr As Long, Source As Byte) As Long
Global Const NERR_BASE = 2100
Global Const ERROR_ACCESS_DENIED = 5&
Global Const NERR_GroupNotFound As Long = (NERR_BASE + 120)
Global Const ERROR_NO_SUCH_MEMBER As Long = 1387&
Global Const ERROR_MEMBER_IN_ALIAS As Long = 1378&
Global Const ERROR_INVALID_MEMBER As Long = 1388&
Public Type GROUP_INFO_1
PtrName As Long
PtrComment As Long
End Type
Public Type LOCALGROUP_MEMBERS_INFO_3
LGrMi3_DomainAndName As Long
End Type
'===========================================================================================
'QUESTA FUNZIONE INSERISCE GRUPPI LOCALI/GLOBALI
'===========================================================================================
Public Function AddGroup(ByVal servername As String, ByVal groupname As String, ByVal GroupComment As String, Optional IsLocalGroup As Boolean = True) As Long
Dim result As Long
Dim GNPtr As Long
Dim GCPtr As Long
Dim ParmError As Long
Dim SNArray() As Byte
Dim GNArray() As Byte
Dim GCArray() As Byte
Dim GroupStruct As GROUP_INFO_1
'
' Move to byte arrays
'
SNArray = servername & vbNullChar
GNArray = groupname & vbNullChar
GCArray = GroupComment & vbNullChar
'
' Allocate buffer space
'
result = NetAPIBufferAllocate(UBound(GNArray) + 1, GNPtr)
result = NetAPIBufferAllocate(UBound(GCArray) + 1, GCPtr)
'
' Copy arrays to the buffer
'
result = StrToPtr(GNPtr, GNArray(0))
result = StrToPtr(GCPtr, GCArray(0))
'
' Fill the structure
'
With GroupStruct
.PtrName = GNPtr
.PtrComment = GCPtr
End With
'
' Add the Group
'
If IsLocalGroup = False Then
result = NetGroupAdd1(SNArray(0), 1, GroupStruct, ParmError)
Else
result = NetLocalGroupAdd1(SNArray(0), 1, GroupStruct, ParmError)
End If
AddGroup = result
If result <> 0 Then
Debug.Print "Error " & result & " in parameter " & _
ParmError & " when adding group " & groupname
End If
'
' Release buffers from memory
'
result = NetAPIBufferFree(GNPtr)
result = NetAPIBufferFree(GCPtr)
End Function
Private Function DelGroup(ByVal servername As String, ByVal groupname As String, Optional IsLocalGroup As Boolean = True) As Long
Dim GNArray() As Byte, SNArray() As Byte
GNArray = groupname & vbNullChar
SNArray = servername & vbNullChar
If IsLocalGroup = True Then
DelGroup = NetLocalGroupDel(SNArray(0), GNArray(0))
Else
DelGroup = NetGroupDel(SNArray(0), GNArray(0))
End If
End Function
'===========================================================================================
'QUESTA FUNZIONE INSERISCE UTENTI IN UN GRUPPO LOCALE/GLOBALE
'===========================================================================================
Private Function AddUsersToGroup(ByVal NomeServer As String, ByVal NomeGruppo As String, _
Utenti() As String, Optional GruppoLocale As Boolean = True) As Long
On Error GoTo ErrHandler
Dim UNPtr() As Long, nUtenti As Long, I As Long
Dim SNArray() As Byte, GNArray() As Byte, UNArray() As Byte
Dim ULocalArray() As LOCALGROUP_MEMBERS_INFO_3
' Move to byte arrays
SNArray = IIf(Left(NomeServer, 2) = "\\", NomeServer & vbNullChar, "\\" & NomeServer & vbNullChar)
GNArray = NomeGruppo & vbNullChar
nUtenti = UBound(Utenti) + 1
If GruppoLocale = True Then
'//Resize the array to hold all user info
ReDim ULocalArray(nUtenti - 1)
'//Resize the array to hold pointers to name strings
ReDim UNPtr(nUtenti - 1)
For I = 0 To nUtenti - 1
If InStr(1, Utenti(I), "\") >= 1 Then
'//domainname included (e.g. USL15\user1)
UNArray = Utenti(I) & vbNullChar
Else
'//domainname not included so just add "\"
UNArray = "\" & Utenti(I) & vbNullChar
End If
result = NetAPIBufferAllocate(UBound(UNArray) + 1, UNPtr(I))
result = StrToPtr(UNPtr(I), UNArray(0))
'//ok assign the pointer which contains <domain>\<username> (e.g. USL15\Beraudo_Da)
ULocalArray(I).LGrMi3_DomainAndName = UNPtr(I)
Next
'//Add n Utenti in one API call
AddUtentiToGroup = NetLocalGroupAddMembers(SNArray(0), GNArray(0), 3, ULocalArray(0), nUtenti)
For I = 0 To nUtenti - 1
Call NetAPIBufferFree(UNPtr(I))
Next
Else
'//Unlike NetLocalGroupAddMembers here you have to execute NetGroupAddUser
'//API n times to add n Utenti
For I = 0 To nUtenti - 1
If InStr(1, Utenti(I), "\") >= 1 Then
'//domainname included (e.g. USL15\user1)
UNArray = Utenti(I) & vbNullChar
Else
'//domainname not included so just add "\"
UNArray = "\" & Utenti(I) & vbNullChar
End If
AddUtentiToGroup = NetGroupAddUser(SNArray(0), GNArray(0), UNArray(0))
Debug.Print AddUtentiToGroup
Next
End If
ErrHandler:
End Function
'===========================================================================================
'QUESTA FUNZIONE ELIMINA GLI UTENTI DA UN GRUPPO LOCALE/GLOBALE
'===========================================================================================
Private Function DelUsersFromGroup(ByVal servername As String, ByVal groupname As String, _
Users() As String, Optional IsLocalGroup As Boolean = True) As Long
On Error GoTo ErrHandler
Dim UNPtr() As Long, nUsers As Long, I As Long
Dim SNArray() As Byte, GNArray() As Byte, UNArray() As Byte
Dim ULocalArray() As LOCALGROUP_MEMBERS_INFO_3
' Move to byte arrays
SNArray = IIf(Left(servername, 2) = "\\", servername & vbNullChar, "\\" & servername & vbNullChar)
GNArray = groupname & vbNullChar
nUsers = UBound(Users) + 1
If IsLocalGroup = True Then
ReDim ULocalArray(nUsers - 1) '//Resize the array to hold all user info
ReDim UNPtr(nUsers - 1) '//Resize the array to hold pointers to name strings
For I = 0 To nUsers - 1
If InStr(1, Users(I), "\") >= 1 Then
UNArray = Users(I) & vbNullChar '//domainname included (e.g. mydomain\user1)
Else
UNArray = "\" & Users(I) & vbNullChar '//domainname not included so just add "\"
End If
result = NetAPIBufferAllocate(UBound(UNArray) + 1, UNPtr(I))
result = StrToPtr(UNPtr(I), UNArray(0))
'//ok assign the pointer which contains <domain>\<username> (e.g. mydomain\testuser1)
ULocalArray(I).LGrMi3_DomainAndName = UNPtr(I)
Next
'//Add n users in one API call
DelUsersFromGroup = NetLocalGroupDelMembers(SNArray(0), GNArray(0), 3, ULocalArray(0), nUsers)
For I = 0 To nUsers - 1
Call NetAPIBufferFree(UNPtr(I))
Next
Else
'//Unlike NetLocalGroupAddMembers here you have to execute NetGroupAddUser API n times to add n users
For I = 0 To nUsers - 1
If InStr(1, Users(I), "\") >= 1 Then
UNArray = Users(I) & vbNullChar '//domainname included (e.g. mydomain\user1)
Else
UNArray = "\" & Users(I) & vbNullChar '//domainname not included so just add "\"
End If
DelUsersFromGroup = NetGroupDelUser(SNArray(0), GNArray(0), UNArray(0))
Next
End If
ErrHandler:
End Function
Public Function GetError(errCode As Long) As String
Select Case errCode
Case NERR_GroupNotFound
GetError = "Il Gruppo Specificato nel parametro non esiste."
Case ERROR_INVALID_MEMBER
GetError = "Non è possibile aggiungere l'utente perchè il tipo di account non è valido."
Case ERROR_MEMBER_IN_ALIAS
GetError = "Utente già presente nel Gruppo Locale. Nessuna Aggiunta Eseguita."
Case ERROR_NO_SUCH_MEMBER
GetError = "L'utente specificato non esiste. " & _
"Nessun Nuovo Utente è stato aggiunto al Gruppo"
Case ERROR_ACCESS_DENIED
GetError = "Accesso Negato"
Case Else
GetError = "Errore: " & Err.LastDllError
End Select
End Function
Public Function Imposta_Administrator(UtenteRete As String)
Dim Risultato As Long
Dim UsersToAdd(1) As String
'UTENTE DA AGGIUNGERE
UsersToAdd(0) = UtenteRete
'AGGIUNTA UTENTE AL GRUPPO
Risultato = AddUsersToGroup(".", "Administrators", UsersToAdd, True)
If Risultato = 0 Then
Msg = MsgBox("Utente Aggiunto", vbInformation, "Operazione Avvenuta")
Else
Msg = MsgBox(Err.Description & " " & GetError(Risultato), vbCritical, "Errore")
End If
End Function
Public Function DeImposta_Administrator(UtenteRete As String)
Dim UsersToRemove(0) As String
'UTENTE DA RIMUOVERE
UsersToRemove(0) = UtenteRete
'RIMUOVE UTENTE AL GRUPPO
Risultato = DelUsersFromGroup(".", "Administrators", UsersToRemove, True)
If Risultato = 0 Then
Msg = MsgBox("Utente Rimosso", vbInformation, "Operazione Avvenuta")
Else
Msg = MsgBox(GetError(Risultato), vbCritical, "Errore")
End If
End Function
Queste funzioni invece sono quelle da richiamare nel form
Rispondi quotando
