|
|
|
|
|
|
|
|
Dicas
|
|
|
Visual Basic (Redes/Comunicações)
|
|
 |
Título da Dica: Listando usuários da Rede em Windows 2000/NT
|
 |
|
|
|
Postada em 6/10/2003 por ^HEAVY-METAL^
Option Explicit
Private Type USER_INFO
Name As String
Comment As String
UserComment As String
FullName As String
End Type
Private Type USER_INFO_API
Name As Long
Comment As Long
UserComment As Long
FullName As Long
End Type
Private Declare Function NetUserEnum Lib "netapi32" _
(lpServer As Any, ByVal Level As Long, _
ByVal Filter As Long, lpBuffer As Long, _
ByVal PrefMaxLen As Long, EntriesRead As Long, _
TotalEntries As Long, ResumeHandle As Long) As Long
Private Declare Function NetApiBufferFree Lib "netapi32" _
(ByVal pBuffer As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias _
"RtlMoveMemory" (pTo As Any, uFrom As Any, _
ByVal lSize As Long)
Private Declare Function lstrlenW Lib "kernel32" _
(ByVal lpString As Long) As Long
Private Const NERR_Success As Long = 0&
Private Const ERROR_MORE_DATA As Long = 234&
Private Const FILTER_TEMP_DUPLICATE_ACCOUNT As Long = &H1&
Private Const FILTER_NORMAL_ACCOUNT As Long = &H2&
Private Const FILTER_PROXY_ACCOUNT As Long = &H4&
Private Const FILTER_INTERDOMAIN_TRUST_ACCOUNT As Long = &H8&
Private Const FILTER_WORKSTATION_TRUST_ACCOUNT As Long = &H10&
Private Const FILTER_SERVER_TRUST_ACCOUNT As Long = &H20&
Public Function GetUsers(UserNames() As String, _
Optional ServerName As String = "") As Boolean
'PURPOSE:
'Get LoginNames of all users On the
'domain And
'save In a String Array
'PARAMETERS:
'UserNames(): Empty String Array,
'passed ByRef, To hold user names
'ServerName (Optional): Set To "" If
'you want user names For current
'machine, otherwise, Set To the server
'you want (e.g., Domain Controller Name)
'RETURNS: True If successful, False otherwise
'EXAMPLE:
'Dim sUsers() As String
'Dim lCtr As Long
'GetUsers sUsers, "MyDomainController"
'Or For Local MACHINE
'GetUsers sUsers
'For lCtr = LBound(sUsers) To UBound(sUsers)
' Debug.Print sUsers(lCtr)
'Next
'NOTES: WINDOWS NT/2000 only
Dim lptrStrBuffer As Long
Dim lRet As Long
Dim lUsersRead As Long
Dim lTotalUsers As Long
Dim lHnd As Long
Dim etUserInfo As USER_INFO_API
Dim bytServerName() As Byte
Dim lElement As Long
Dim Users() As USER_INFO 'This Function
'Is designed To Return a String of username
'but optionally, you can change it To
'Get this Array of the UDT, which
'will provide more information
'about Each user
Dim i As Long
ReDim Users(0) As USER_INFO
ReDim UserNames(0) As String
If Trim(ServerName) = "" Then
'Local users
bytServerName = vbNullString
Else
'Check the syntax of the ServerName String
If InStr(ServerName, "\\") = 1 Then
bytServerName = ServerName & vbNullChar
Else
bytServerName = "\\" & ServerName & vbNullChar
End If
End If
lHnd = 0
Do
'Begin enumerating users
If Trim(ServerName) = "" Then
lRet = NetUserEnum(vbNullString, 10, _
FILTER_NORMAL_ACCOUNT, lptrStrBuffer, 1, _
lUsersRead, lTotalUsers, lHnd)
Else
lRet = NetUserEnum(bytServerName(0), 10, _
FILTER_NORMAL_ACCOUNT, lptrStrBuffer, 1, _
lUsersRead, lTotalUsers, lHnd)
End If
'Populate UserInfo Structure
'If lRet = ERROR_MORE_DATA Then
' If lUsersRead 1 that why th For construct
For i = 0 To lUsersRead - 1
CopyMem etUserInfo, ByVal lptrStrBuffer + Len(etUserInfo) * i, _
Len(etUserInfo)
If Users(0).Name = "" Then
lElement = 0
Else
lElement = UBound(Users) + 1
End If
'ReDim Preserve UserNames(lElement)
ReDim Preserve Users(lElement) As USER_INFO
'data of interest
Users(lElement).Name = PtrToString(etUserInfo.Name)
'If lRet = ERROR_MORE_DATA Then -- i removed because i lost the last
'entry While the result Is NERR_Success
'Other stuff you can Get, but Not
'returned by this Function
'modify this Function If you are interested
Users(lElement).Comment = PtrToString(etUserInfo.Comment)
Users(lElement).UserComment = PtrToString(etUserInfo.UserComment)
Users(lElement).FullName = PtrToString(etUserInfo.FullName)
ReDim Preserve UserNames(lElement)
UserNames(lElement) = Users(lElement).Name
Next
If lptrStrBuffer Then
Call NetApiBufferFree(lptrStrBuffer)
End If
DoEvents
If lRet = NERR_Success Then Exit Do
Loop While lRet = ERROR_MORE_DATA
GetUsers = True
Exit Function
ErrHandler:
On Error Resume Next
Call NetApiBufferFree(lptrStrBuffer)
End Function
Private Function PtrToString(lpString As Long) As String
'Convert a windows pointer To a VB String
Dim bytBuffer() As Byte
Dim lLen As Long
If lpString Then
lLen = lstrlenW(lpString) * 2
If lLen Then
ReDim bytBuffer(0 To (lLen - 1)) As Byte
CopyMem bytBuffer(0), ByVal lpString, lLen
PtrToString = bytBuffer
End If
End If
End Function
T+,
|
|
|
|
|
