Option Explicit
 
 
Public Enum Enum_adscAccessType
    adscDenyedAccess = 0
    adscDataReader = 1
    adscDataWriter = 2
End Enum
 
 
Public Function AllowAccess(LoginID As String, Group As String) As Boolean
 
    Dim oCN As ADODB.Connection, oCM As ADODB.Command, oRS As ADODB.Recordset, oField As ADODB.Field
    Dim oUser As IADs, oParent As IADs, oGroup As IADs
    Dim oPropList As IADsPropertyList, oPropEntry As IADsPropertyEntry, oPropVal As IADsPropertyValue
    Dim sPath As String, v As Variant, i As Variant
    'This function checks a specific users r
    '     ights via their login and what ever grou
    '     p you pass in.
    'You will need to replace the {YOUR DC H
    '     ERE} with your own domain controller to 
    '     active directory.
    Set oCN = New ADODB.Connection
    Set oCM = New ADODB.Command
    Set oRS = New ADODB.Recordset
    oCN.Provider = "ADsDSOObject"
    oCN.Open
    Set oCM.ActiveConnection = oCN
    oCM.CommandText = "SELECT AdsPath FROM 'LDAP://OU=Branches,OU=Corp,DC={YOUR DC HERE},DC=com' " & _
    "WHERE objectCategory='person' AND cn='" & LoginID & "'"
 
    oCM.Properties("searchscope") = 2
    Set oRS = oCM.Execute
 
 
    If Not oRS.EOF Then
        Set oUser = GetObject(oRS("AdsPath").Value)
        oUser.GetInfo
        Set oParent = GetObject(oUser.Parent)
        Set oParent = GetObject(oParent.Parent)
 
 
        For i = 0 To oUser.PropertyCount - 1
            Set oPropEntry = oUser.Item(i)
 
 
            If oPropEntry.Name = "memberOf" Then
 
                For Each v In oPropEntry.Values
                    Set oPropVal = v
                    sPath = oPropVal.DNString
                    Set oGroup = GetObject("LDAP://" & sPath)
 
 
                    If oGroup.Name = "CN=" & Group Then
                        AllowAccess = True
                        Goto ShutDown
                    End If
 
                    Set oGroup = Nothing
                Next
 
            End If
 
            oUser.Next
        Next
 
    End If
 
    AllowAccess = False
    ShutDown:
    Set oCN = Nothing
    Set oRS = Nothing
    Set oCM = Nothing
    Set oField = Nothing
    Set oUser = Nothing
    Set oParent = Nothing
    Set oGroup = Nothing
    Set oPropList = Nothing
    Set oPropEntry = Nothing
    Set oPropVal = Nothing
    Set v = Nothing
End Function
 
 
Public Function ADSCAllowAccessByGroup(Group As String, UserName As String) As Boolean
 
    On Error Resume Next
    Dim oGroup As ActiveDs.IADsGroup
    Dim oUser As ActiveDs.IADsUser
    'This function checks whether or not a u
    '     ser is in a specific group. It will retu
    '     rn a true or false
    'You will need to replace the {YOUR DC H
    '     ERE} with your own domain controller to 
    '     active directory.
    Set oGroup = GetObject("WinNT://{YOUR DC HERE}.com/" & Group)
 
 
    If oGroup Is Nothing Then
        ADSCAllowAccessByGroup = False
        Exit Function
    End If
 
 
    For Each oUser In oGroup.Members
        Debug.Print oUser.Name
 
 
        If UCase(oUser.Name) = UCase(UserName) Then
            ADSCAllowAccessByGroup = True
            Exit Function
        End If
 
    Next
 
    ADSCAllowAccessByGroup = False
End Function
 
 
Public Function ADSCAllowAccessByUser(UserName As String, Group As String) As Boolean
 
    On Error Resume Next
    Dim oGroup As ActiveDs.IADsGroup
    Dim oUser As ActiveDs.IADsUser
    Set oUser = GetObject("WinNT://{YOUR DC HERE}.com/" & UCase(UserName) & ",user")
 
 
    If oUser Is Nothing Then
        ADSCAllowAccessByUser = False
        Exit Function
    End If
 
 
    For Each oGroup In oUser.Groups
 
 
        If UCase(oGroup.Name) = UCase(Group) Then
            ADSCAllowAccessByUser = True
            Exit Function
        End If
 
    Next
 
End Function
 
 
Public Function ADSCAccessType(Location As String, UserName As String, Module As String, AppName As String) As Enum_adscAccessType
 
    On Error Resume Next
    Dim oGroup As ActiveDs.IADsGroup
    Dim oUser As ActiveDs.IADsUser
    'This function assumes that you already 
    '     have 2 types of groups set up. One that 
    '     has DataReader at the end and another
    'that has datawriter at the end. It also
    '     assumes that you have set up your group 
    '     name in the following
    'order: Location_AppName & Module & Data
    '     Reader/DataWriter.
    'You can change this to fit your needs. 
    '     The main part is the first line of code 
    '     that sets the oUser
    'You will need to replace the {YOUR DC H
    '     ERE} with your own domain controller to 
    '     active directory.
    Set oUser = GetObject("WinNT://{YOUR DC HERE}.com/" & UCase(UserName) & ",user")
 
 
    If oUser Is Nothing Then
        ADSCAccessType = adscDenyedAccess
        Exit Function
    End If
 
 
    For Each oGroup In oUser.Groups
 
 
        Select Case oGroup.Name
            Case Location & "_" & AppName & Module & "DataReader"
            ADSCAccessType = adscDataReader
            Exit Function
            Case Location & "_" & AppName & Module & "DataWriter"
            ADSCAccessType = adscDataWriter
            Exit Function
        End Select
 
Next
 
ADSCAccessType = adscDenyedAccess
End Function