LDAP: Check if logged in user is member of domain group(s). Uses alternative credentials to log on to domain controller.

IsMemberOf.vb

Function IsMemberOf()
  
  ' Checks if logged in user is member of LDAP groups (group1, group2)
  
  IsMemberOf = False
  
  Const ADS_SECURE_AUTHENTICATION = 1
  Const ADS_SERVER_BIND = &h0200
  
  strUser = "***domain user name***"
  strPassword = "***user password***"
     
  ' Determine DNS domain name. Use server binding and alternate credentials
  Set objDSO = GetObject("LDAP:")
  Set objRootDse = objDSO.OpenDSObject("LDAP://RootDSE", strUser, strPassword, ADS_SECURE_AUTHENTICATION OR ADS_SERVER_BIND)
  strDNSDomain = objRootDse.Get("defaultNamingContext")
   
  ' Use ADO to search Active Directory. Use alternate credentials.
  Set adoConnection = CreateObject("ADODB.Connection")
  adoConnection.Provider = "ADsDSOObject"
  adoConnection.Properties("User ID") = strUser
  adoConnection.Properties("Password") = strPassword
  adoConnection.Properties("Encrypt Password") = True
  adoConnection.Properties("ADSI Flag") = ADS_SERVER_BIND OR ADS_SECURE_AUTHENTICATION
  adoConnection.Open "Active Directory Provider"
  
  ' Search entire domain. Use server binding.
  strBase = "<LDAP://server.domain.com/" & strDNSDomain & ">;"
  strFilter = "(&(objectCategory=group)(|(sAMAccountName=group1)(sAMAccountName=group2)));"
  strAttrs = "distinguishedName;"
  strScope = "subtree"
  strQuery = strBase & strFilter & strAttrs & strScope
     
  Set adoCommand = CreateObject("ADODB.Command")
  adoCommand.ActiveConnection = adoConnection
  adoCommand.Properties("Page Size") = 100
  adoCommand.Properties("Timeout") = 30
  adoCommand.Properties("Cache Results") = False
  adoCommand.CommandText = strQuery
  
  Set objRS = adoCommand.Execute
  
  ' Get current user DN
  Set objADSysInfo = CreateObject("ADSystemInfo")
  strUserDN = objADSysInfo.UserName
  Set objADSysInfo = Nothing
       
  Do Until objRS.EOF
    strGroupDN = objRS.Fields("distinguishedName").Value
    ' Escape any forward slash characters with backslash.
    strGroupDN = Replace(strGroupDN, "/", "\/")
    ' Get the AD group that matches this distinguishedName
    Set objGroup = objDSO.OpenDSObject("LDAP://" & strGroupDN, strUser, strPassword, ADS_SECURE_AUTHENTICATION OR ADS_SERVER_BIND)
    If objGroup.IsMember("LDAP://" & strUserDN) Then
      IsMemberOf = True
      Exit Function
    End If
    objRS.MoveNext
  Loop
  
  objRS.Close
  Set objRS = Nothing    
  Set objGroup = Nothing
  Set adoCommand = Nothing
  adoConnection.Close
  Set adoConnection = Nothing
  Set objRootDse = Nothing
  Set objDSO = Nothing

End Function