[VB6] Active Directory - Verify that a user is a member of a specific group

[Spacehamster]

Language: VB6 (possibly converted to VBScript/ASP for webapp)
Requirements: Active Directory
VB6 References: Active DS Library, Microsoft ActiveX Data Objects

I'm intending to convert this code into VBScript for use in a ASP Webapp. The function accepts a username (eg. s009999) and a groupname (eg. ITBranch), and uses an LDAP Query to verify whether the username is a member of groupname in Active Directory.

Public Function FindUserGroupInfo(LoginName As String, GroupName As String) As Boolean
' Searches for a user within a specified group in Active Directory.
' Returns TRUE if the user is found in the specified group.
' Returns FALSE if the user is not found in the group.
 
    ' LDAP Search Query Properties
    Dim conn As New ADODB.Connection    ' ADO Connection
    Dim rs As ADODB.Recordset           ' ADO Recordset
    Dim oRoot As IADs
    Dim oDomain As IADs
    Dim sBase As String
    Dim sFilter As String
    Dim sDomain As String
    Dim sAttribs As String
    Dim sDepth As String
    Dim sQuery As String
    Dim sAns As String
    
    ' Search Results
    Dim user As IADsUser
    Dim group As Variant
    Dim usergroup As String
    Dim userGroupFound As Boolean
    
    On Error GoTo ErrHandler:
    
    userGroupFound = False
    
    'Set root to LDAP/ADO.
    Set oRoot = GetObject("LDAP://rootDSE")
    
    'Create the Default Domain for the LDAP Search Query
    sDomain = oRoot.Get("defaultNamingContext")
    Set oDomain = GetObject("LDAP://" & sDomain)
    sBase = "<" & oDomain.ADsPath & ">"
    
    ' Set the LDAP Search Query properties
    sFilter = "(&(objectCategory=person)(objectClass=user)(name=" & LoginName & "))"
    sAttribs = "adsPath"
    sDepth = "subTree"
    sQuery = sBase & ";" & sFilter & ";" & sAttribs & ";" & sDepth
    
    ' Open the ADO connection and execute the LDAP Search query
    conn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
    Set rs = conn.Execute(sQuery)   ' Store the query results in recordset
    
    ' Display the user details
    If Not rs.EOF Then
        Set user = GetObject(rs("adsPath"))
 
        ' Display the groups memberships
        For Each group In user.Groups
            usergroup = group.name
            
            If (InStr(usergroup, GroupName) > 0) Then
                FindUserGroupInfo = True
                Exit Function
            End If
        Next
    End If
    FindUserGroupInfo = userGroupFound
ErrHandler:
    
    On Error Resume Next
    If Not rs Is Nothing Then
        If rs.State <> 0 Then rs.Close
        Set rs = Nothing
    End If
    
    If Not conn Is Nothing Then
        If conn.State <> 0 Then conn.Close
        Set conn = Nothing
    End If
    
    Set oRoot = Nothing
    Set oDomain = Nothing
End Function

Unfortunately our team is far too busy to peer-review code (at least that's their excuse). So I'd value people's criticisms and suggestions on how to improve this piece of code.

Thanks!

[bilderbach]

Sad as it is, you finally get some feedback ;(
Wrapped in a class and moved security from an old vb6 app still in production to AD
Thanks!!!!!!!!