Option Compare Database
Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function LookupAccountName Lib "advapi32.dll" Alias "LookupAccountNameA" (ByVal lpSystemName As String, ByVal lpAccountName As String, ByVal Sid As Long, cbSid As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Long) As Long
Private Declare Function GetLengthSid Lib "advapi32.dll" (ByVal pSid As Long) As Long
Private Declare Function FreeSid Lib "advapi32.dll" (ByVal pSid As Long) As Long
Private Declare Function IsValidSid Lib "advapi32.dll" (ByVal pSid As Long) As Long
Private Const ERROR_NONE_MAPPED As Long = 1332
Private Const ERROR_INSUFFICIENT_BUFFER As Long = 122
Public Function GetCurrentUserGroups() As String
Dim sid As Long
Dim sidSize As Long
Dim strSID As String * 1024
Dim strDomain As String * 255
Dim strUser As String * 255
Dim dwSizeDomain As Long
Dim dwSizeUser As Long
Dim sidType As Long
Dim groups() As String
Dim i As Integer
ReDim groups(0)
strUser = String(255, 0)
dwSizeUser = 255
If GetUserName(strUser, dwSizeUser) <> 0 Then
strUser = Left$(strUser, InStr(1, strUser, Chr(0)) - 1)
strDomain = String(255, 0)
dwSizeDomain = 255
sidSize = 0
If LookupAccountName(vbNullString, strUser, 0, sidSize, strDomain, dwSizeDomain, sidType) = 0 Then
If Err.LastDllError = ERROR_INSUFFICIENT_BUFFER Then
strDomain = Left$(strDomain, InStr(1, strDomain, Chr(0)) - 1)
sid = VarPtr(strSID)
sidSize = GetLengthSid(sid)
If sidSize <> 0 And IsValidSid(sid) <> 0 Then
If LookupAccountName(vbNullString, strUser, sid, sidSize, strDomain, dwSizeDomain, sidType) <> 0 Then
If sidType = 1 Then ' SidTypeUser
ReDim Preserve groups(1)
groups(0) = strUser
groups(1) = strDomain
End If
End If
End If
FreeSid sid
End If
End If
End If
GetCurrentUserGroups = Join(groups, "\")
End Function