Home » Win NT / Get UserGroups Permissions in VB

Win NT / Get UserGroups Permissions in VB

Question:
I would like to get the permissions for the users of my app. I have setup groups for users with the appropriate permisions. Now all I want to do is check which group they belong to, when they execute my app.

Answer:
Actually, it’s not too difficult in VB. Add the following code to a new Form, and also add a single command button (Command1) and a single listbox (List1):

Option ExplicitPrivate Const INVALID_HANDLE_VALUE     As Long = -1&Private Const ERROR_SUCCESS            As Long = 0&Private Const FORMAT_MESSAGE_FROM_SYSTEM     As Long = &H1000Private Const FORMAT_MESSAGE_IGNORE_INSERTS  As Long = &H200Private Const ERROR_ACCESS_DENIED      As Long = 5&Private Const ERROR_INVALID_NAME       As Long = 123&Private Const ERROR_MORE_DATA          As Long = 234&Private Const NERR_BASE                As Long = 2100&Private Const NERR_Success             As Long = 0&Private Const NERR_GroupNotFound       As Long = NERR_BASE + 120&Private Const NERR_UserNotFound        As Long = NERR_BASE + 121&Private Const NERR_InvalidComputer     As Long = NERR_BASE + 251&Private Const NERR_DCNotFound          As Long = NERR_BASE + 353&Private Const constComputerNameLen     As Long = 15&Private Const UNLEN                    As Long = 256& ' Maximum username lengthPrivate Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As LongPrivate Declare Function NetUserGetGroups Lib "netapi32.dll" (Servername As Byte, username As Byte, ByVal level As Long, Buffer As Long, ByVal prefmaxlen As Long, entriesread As Long, totalentries As Long) As LongPrivate Declare Function NetApiBufferFree Lib "netapi32" (ByVal pBuffer As Long) As LongPrivate Declare Function GetComputerNameW Lib "kernel32" (lpBuffer As Any, nSize As Long) As LongPrivate Declare Function NetGetDCName Lib "netapi32.dll" (Servername As Byte, DomainName As Byte, Buffer As Long) As LongPrivate 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 LongPrivate Declare Function lstrcpyW Lib "kernel32" (lpString1 As Byte, ByVal lpString2 As Long) As LongPrivate Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As LongPrivate Declare Function GetUserNameW Lib "advapi32.dll" (lpBuffer As Byte, nSize As Long) As LongPrivate Function CurrentUserName() As String   Dim Buffer As String   Dim yBuffer() As Byte   Dim nRet As Long   Dim nLen As Long   Const NameLength = UNLEN + 1      nLen = NameLength * 2   ReDim yBuffer(0 To nLen - 1) As Byte   If GetUserNameW(yBuffer(0), nLen) Then      Buffer = yBuffer      CurrentUserName = Left(Buffer, nLen - 1)   End IfEnd FunctionPrivate Sub Command1_Click()   Dim p_vntRtn                        As Variant   Dim p_lngLoop                       As Long      List1.Clear      p_vntRtn = GetNTGroups(CurrentUserName())      If VarType(p_vntRtn) <> vbEmpty Then      For p_lngLoop = 0 To UBound(p_vntRtn)         List1.AddItem p_vntRtn(p_lngLoop)      Next p_lngLoop   End If   End SubPrivate Function GetNTGroups(ByVal xi_strUserID As String) As VariantOn Error Resume Next                   ' Don't accept errors here   Const p_constProcName               As String = "GetNTGroups"   Dim p_bytUserName()                 As Byte   Dim p_bytServerName()               As Byte   Dim p_astrGroups()                  As String   Dim p_alngGroups()                  As Long   Dim p_strPDC_Name                   As String   Dim p_strTmp                        As String   Dim p_lngRtn                        As Long   Dim p_lngBuffer                     As Long   Dim p_lngEntriesRead                As Long   Dim p_lngEntriesTotal               As Long   Dim p_lngLevel                      As Long   Dim p_lngBufferPtr                  As Long   Dim p_lngLoop                       As Long   Dim p_vntReplacementStrings         As Variant      ' Default the return to EMPTY   GetNTGroups = Empty      ' Get the name of the PDC   If GetPDC("", "", p_strPDC_Name) = False Then      ' Already logged in this function -- just exit      Exit Function   End If      ' Convert the user name to a byte array   p_bytUserName = xi_strUserID & vbNullChar      ' Convert the PDC name to a byte array   If InStr(p_strPDC_Name, "\") = 1 Then      p_bytServerName = p_strPDC_Name & vbNullChar   Else      p_bytServerName = "\" & p_strPDC_Name & vbNullChar   End If      ' Get the groups   p_lngLevel = 0&   p_lngBufferPtr = 4096   p_lngRtn = NetUserGetGroups(p_bytServerName(0), _                               p_bytUserName(0), _                               p_lngLevel, _                               p_lngBuffer, _                               p_lngBufferPtr, _                               p_lngEntriesRead, _                               p_lngEntriesTotal)         ' Check for errors   If p_lngRtn = NERR_Success Then      ReDim p_alngGroups(0 To p_lngEntriesRead - 1) As Long      ReDim p_astrGroups(0 To p_lngEntriesRead - 1) As String      CopyMem p_alngGroups(0), ByVal p_lngBuffer, p_lngEntriesRead * 4      For p_lngLoop = 0 To p_lngEntriesRead - 1         p_astrGroups(p_lngLoop) = PointerToStringW(p_alngGroups(p_lngLoop))      Next p_lngLoop   Else      Select Case p_lngRtn         Case ERROR_ACCESS_DENIED            p_strTmp = "Access denied -- insufficient rights to run NetUserGetGroups function."         Case NERR_InvalidComputer            p_strTmp = "Invalid computer name for PDC: " & p_strPDC_Name         Case NERR_UserNotFound            p_strTmp = "User not found: " & xi_strUserID         Case Else            p_strTmp = ReturnApiErrString(p_lngRtn)      End Select            ' Raise or otherwise handle the error   End If      ' Free the buffer   If p_lngBuffer Then      NetApiBufferFree p_lngBuffer   End If      GetNTGroups = p_astrGroups   On Error GoTo 0End FunctionPublic Function ReturnApiErrString(ByVal xi_lngErrorCode As Long) As StringOn Error Resume Next                   ' Don't accept an error here!   Const p_constProcName               As String = "ReturnApiErrString"   Dim p_strBuffer                     As String    ' ------------------------------------------   ' Allocate the string, then get the system   '     to tell us the error message   '     associated with this error number   ' ------------------------------------------   p_strBuffer = String(256, 0)   FormatMessage FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0&, xi_lngErrorCode, 0&, p_strBuffer, Len(p_strBuffer), 0&      ' ------------------------------------------   ' Strip the last null, then the last CrLf   '     pair if it exists   ' ------------------------------------------   p_strBuffer = Left(p_strBuffer, InStr(p_strBuffer, vbNullChar) - 1)   If Right$(p_strBuffer, 2) = Chr$(13) & Chr$(10) Then      p_strBuffer = Mid$(p_strBuffer, 1, Len(p_strBuffer) - 2)   End If      ' ------------------------------------------   ' Set the return value   ' ------------------------------------------   ReturnApiErrString = p_strBufferOn Error GoTo 0End FunctionPrivate Function GetPDC(ByVal xi_strServer As String, _                        ByVal xi_strDomain As String, _                        ByRef xo_strPDC_Name As String) As BooleanOn Error Resume Next                   ' Don't accept error here   Const p_constProcName               As String = "GetPDC"   Dim p_strTmp                        As String   Dim p_lngRtn                        As Long   Dim p_lngBufferPtr                  As Long   Dim p_astrTmp(100)                  As Byte   Dim p_abytServerName()              As Byte   Dim p_abytDomainName()              As Byte   Dim p_vntReplacementStrings         As Variant       ' Move to byte array   p_abytServerName = xi_strServer & vbNullChar   p_abytDomainName = xi_strDomain & vbNullChar               ' Get the name of the PDC   p_lngRtn = NetGetDCName(p_abytServerName(0), _                           p_abytDomainName(0), _                           p_lngBufferPtr)      ' ------------------------------------------   ' Set the return value (zero is success)   ' ------------------------------------------   If p_lngRtn = 0 Then      GetPDC = True   Else      GetPDC = False         Select Case p_lngRtn         Case NERR_DCNotFound            p_strTmp = "Could not find the domain controller for the current domain."         Case ERROR_INVALID_NAME            p_strTmp = "Invalid name for PDC -- the name could not be found."         Case Else            p_strTmp = ReturnApiErrString(p_lngRtn)      End Select            ' Raise or otherwise handle the error   End If        ' Translate the name   If p_lngRtn = 0 Then      xo_strPDC_Name = PointerToStringW(p_lngBufferPtr)   Else      xo_strPDC_Name = ""   End If      NetApiBufferFree p_lngBufferPtrOn Error GoTo 0End FunctionPrivate Function PointerToStringW(ByVal xi_lngStrPtr As Long) As StringOn Error Resume Next                   ' Don't accept error here   Dim p_abytBuffer()                  As Byte   Dim p_lngLength                     As Long      If xi_lngStrPtr Then            p_lngLength = lstrlenW(xi_lngStrPtr) * 2            If p_lngLength Then         ReDim p_abytBuffer(0 To (p_lngLength - 1)) As Byte         CopyMem p_abytBuffer(0), ByVal xi_lngStrPtr, p_lngLength         PointerToStringW = p_abytBuffer      End If      End If   On Error GoTo 0End Function

About Our Editorial Process

At DevX, we’re dedicated to tech entrepreneurship. Our team closely follows industry shifts, new products, AI breakthroughs, technology trends, and funding announcements. Articles undergo thorough editing to ensure accuracy and clarity, reflecting DevX’s style and supporting entrepreneurs in the tech sphere.

See our full editorial policy.