Domain controller and user based on email VBA - excel

Question

I'm trying to resolve domain controller name and user(dc\user) using email address.
I have below code(borrowed) but it only solves user name for default domain. Any suggestions much appreciated.
Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
If InStr(strObjectToGet, "\") > 0 Then
arrGroupBits = Split(strObjectToGet, "\")
strDC = arrGroupBits(0)
strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
strObjectToGet = arrGroupBits(1)
Else
' Otherwise we just connect to the default domain
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
End If
strBase = "<LDAP://" & strDNSDomain & ">"
' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Command")
Set ADOConnection = CreateObject("ADODB.Connection")
ADOConnection.Provider = "ADsDSOObject"
ADOConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = ADOConnection
' Filter on user objects.
'strFilter = "(&(objectCategory=person)(objectClass=user))"
strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"
' Comma delimited list of attribute values to retrieve.
strAttributes = strCommaDelimProps
arrProperties = Split(strCommaDelimProps, ",")
' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
' Define the maximum records to return
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False
' Run the query.
End Function
Thanks in advance
Michal

Answer 1

This should be the code you need to get what you want.
It takes an email address and returns the attributes listed in strAttributes of the requested user.
Example:
Input: LdapUserByMailAddress("ad.user#ad.example.com")
Output: sn: Doe; givenName: John; mail: ad.user#ad.example.com;
Value of strBaseDn: <LDAP://dc=ad,dc=example,dc=com>
Public Function LdapUserByMailAddress(strMailAddress As String) As String
Dim arrMailParts() As String
Dim strUsername As String
Dim strDomain As String
Dim strBaseDn As String
Dim strFilter As String
Dim strQuery As String
Dim strAttributes As String
Dim arrAttributes() As String
Dim i As Integer
Dim j As Integer
strAttributes = "mail,sn,givenName"
arrAttributes = Split(strAttributes, ",")
arrMailParts = Split(strMailAddress, "#")
If 1 <> UBound(arrMailParts) Then
LdapUserByMailAddress = "Not a valid email address"
Exit Function
End If
strUsername = arrMailParts(0)
strDomain = arrMailParts(1)
strBaseDn = "<LDAP://dc=" & Replace(strDomain, ".", ",dc=") & ">"
strFilter = "(sAMAccountName=" & strUsername & ")"
' Construct the LDAP syntax query.
strQuery = strBaseDn & ";" & strFilter & ";" & strAttributes & ";subtree"
Set adoCommand = CreateObject("ADODB.Command")
Set ADOConnection = CreateObject("ADODB.Connection")
ADOConnection.Provider = "ADsDSOObject"
ADOConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = ADOConnection
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False
Set resultSet = adoCommand.Execute
LdapUserByMailAddress = ""
For i = 0 To resultSet.Fields.Count - 1
LdapUserByMailAddress = LdapUserByMailAddress & resultSet.Fields(i).Name & ": "
If resultSet.Fields(i).Type = adVariant And Not (IsNull(resultSet.Fields(i).Value)) Then
' For Multi Value attribute.
LdapUserByMailAddress = LdapUserByMailAddress & "[MultiValue]"
For j = LBound(resultSet.Fields(i).Value) To UBound(resultSet.Fields(i).Value)
LdapUserByMailAddress = LdapUserByMailAddress & resultSet.Fields(i).Value(j) & " # "
Next j
Else
' For Single Value attribute.
LdapUserByMailAddress = LdapUserByMailAddress & resultSet.Fields(i).Value
End If
LdapUserByMailAddress = LdapUserByMailAddress & ";"
Next i
End Function

Answer 2

Please elaborate about the given email addresses and add examples about the parameters strObjectType, strSearchField, strObjectToGet and strCommaDelimProps when calling the function Get_LDAP_User_Properties().
What is the expected result?
What is the actual result?
My interpretation of your question:
Your input is an email address like myuser#dc.example.com and you want to get following result: dc.example.com\myuser
Is this correct?
In that case this could be the solution:
Public Function LdapUserByMailAddress(strMailAddress As String) As String
Dim arrParts() As String
arrParts = Split(strMailAddress, "#")
If 1 <> UBound(arrParts) Then
LdapUserByMailAddress = "Not a valid email address"
Exit Function
End If
LdapUserByMailAddress = arrParts(1) & "\" & arrParts(0)
End Function
If you call this function in your worksheet with following code:
=LdapUserByMailAddress("user#dc.example.com")
you get this result: dc.example.com\user