Question (Quick and simple I hope)

[KRKComputers]

I was wondering if someone can tell me if Excel has a way to pull a user name from AD using a text box input and an MSGBOX output and if so what the code may be to attempt this?

I have attempted it but each time I try to do so I fail and would greatly appreciate if anyone may know the code for this.

Thanks
Kevin

 

[KRKComputers]

WBD,

Not to sound stupid but do I have to place the domain information in the code anywhere?

I am used to adding this in when running a script normally and want to make sure that this is not the issue.

If I do need to enter domain info where do I place it within the code?

Thx again
Kevin

 

[wideboydixon]

Hi Kevin,

As I said before, the code as posted works without issue for me using the AD we have at work. The domain information is being retrieved here:

strDomain = GetObject("LDAP://rootDSE").Get("defaultNamingContext")

If that's not returning the right value then perhaps change that line to:

strDomain = "[your domain]"

WBD

 

[edmitchell]

WBD, thanks for sorting the missing section of the code in the previous post, the code (with the ‘extra’ text) also works for me.

Kevin, is the error message exactly as it was before?


ed

 

[KRKComputers]

Ed,

It is still failing in the same location it always blows up in this area

    ' RecordSet    Dim objRecordSet As Object
    Set objRecordSet = objCommand.Execute

However I did manage to find code that does work and if I can get it to the point that will allow me to enter information into it all will be golden as currently the code only outputs to an excel spreadsheet. This does prove with this code working that I do in fact have permission to look into the domain.

Option ExplicitConst ADS_SCOPE_SUBTREE = 2
Sub LoadUserInfo()
    Dim x, objConnection, objCommand, objRecordSet, oUser, skip, disa
    Dim sht As Worksheet
    
    ' get domain
    Dim oRoot
    Set oRoot = GetObject("LDAP://rootDSE")
    Dim sDomain
    sDomain = oRoot.Get("defaultNamingContext")
    Dim strLDAP
    strLDAP = "LDAP://" & sDomain
    
    Set objConnection = CreateObject("ADODB.Connection")
    Set objCommand = CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Page Size") = 100
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    
    objCommand.CommandText = "SELECT adsPath FROM '" & strLDAP & "' WHERE objectCategory='person'AND objectClass='user'"
    Set objRecordSet = objCommand.Execute
        
    x = 2
    Set sht = ThisWorkbook.Worksheets("Company")
    With sht
        ' Clear and set Header info
        .Cells.Clear
        .Cells.NumberFormat = "@"
        .Cells(1, 1).Value = "Login"
        .Cells(1, 2).Value = "Name"
        .Cells(1, 3).Value = "Surmane"
        .Cells(1, 4).Value = "Display Name"
        .Cells(1, 5).Value = "Departement"
        .Cells(1, 6).Value = "Title"
        .Cells(1, 7).Value = "Telephone"
        .Cells(1, 8).Value = "Mobile"
        .Cells(1, 9).Value = "Fax"
        .Cells(1, 10).Value = "Initials"
        .Cells(1, 11).Value = "Company"
        .Cells(1, 12).Value = "Address"
        .Cells(1, 13).Value = "P.O. box"
        .Cells(1, 14).Value = "Zip"
        .Cells(1, 15).Value = "Town"
        .Cells(1, 16).Value = "State"
        Do Until objRecordSet.EOF
            Set oUser = GetObject(objRecordSet.Fields("aDSPath"))
            skip = oUser.sAMAccountName
            disa = oUser.AccountDisabled
                        
            If (skip = "Administrator") Or (skip = "Guest") Or (skip = "krbtgt") Or (disa = "True") Then
                .Cells(x, 1).Value = "test"
                DoEvents
                objRecordSet.MoveNext
            Else
                .Cells(x, 1).Value = CStr(oUser.sAMAccountName) 'Replace(oUser.Name, "CN=", "")
                .Cells(x, 2).Value = oUser.givenName
                .Cells(x, 3).Value = oUser.SN
                .Cells(x, 4).Value = oUser.DisplayName
                .Cells(x, 5).Value = oUser.department
                .Cells(x, 6).Value = oUser.Title
                .Cells(x, 7).Value = oUser.telephoneNumber
                .Cells(x, 8).Value = oUser.mobile
                .Cells(x, 9).Value = oUser.facsimileTelephoneNumber
                .Cells(x, 10).Value = oUser.initials
                .Cells(x, 11).Value = oUser.company
                .Cells(x, 12).Value = oUser.streetAddress
                .Cells(x, 13).Value = oUser.postOfficeBox
                .Cells(x, 14).Value = oUser.postalCode
                .Cells(x, 15).Value = oUser.l ' by
                .Cells(x, 16).Value = oUser.st
                DoEvents
                x = x + 1
                objRecordSet.MoveNext
            End If
            
        Loop
        
    End With
    Range("A1:D1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.AutoFilter
    Range("C12").Select


End Sub

Now if I can only get it to the point that I can input the username I want to look up all will be good.

Regards
Kevin

WBD, thanks for sorting the missing section of the code in the previous post, the code (with the ‘extra’ text) also works for me.

Kevin, is the error message exactly as it was before?


ed

 

[edmitchell]

Kevin

I've combined some of the old code into the new code, and the following works for me (and hopefully you!)

Public Sub LookupUser()

Dim cn As String
cn = InputBox("Enter the common name", "AD Lookup")

MsgBox GetAdsProp("cn", cn, "mail"), vbOKOnly + vbInformation, "Email"

End Sub


Function GetAdsProp(ByVal SearchField As String, ByVal SearchString As String, ByVal ReturnField As String) As String
    ' get domain
    Dim oRoot
    Set oRoot = GetObject("[URL]ldap://rootDSE[/URL]")
    Dim sDomain
    sDomain = oRoot.Get("defaultNamingContext")
    Dim strLDAP
    strLDAP = "LDAP://" & sDomain
    
    Set objConnection = CreateObject("ADODB.Connection")
    Set objCommand = CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Page Size") = 100
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
        
    ' Search the AD recursively, starting at root of the domain
    objCommand.CommandText = "SELECT " & ReturnField & " FROM '" & strLDAP & "' WHERE objectCategory='person'AND objectClass='user' and " & SearchField & "='" & SearchString & "'"
    
    ' RecordSet
    Dim objRecordSet As Object
    Set objRecordSet = objCommand.Execute
         
    
    If objRecordSet.RecordCount = 0 Then
        GetAdsProp = "not found"  ' no records returned
    Else
        GetAdsProp = objRecordSet.Fields(ReturnField)  ' return value
    End If
     
    ' Close connection
    objConnection.Close
    
    ' Cleanup
    Set objRecordSet = Nothing
    Set objCommand = Nothing
    Set objCommand = Nothing
End Function

Regards


Ed

 

[KRKComputers]

Ed,

Thanks for getting back to me.

I will give this a shot and post the results fingers crossed that it will work.

I do greatly appreciate all the help

Best Regards
Kevin

 

[KRKComputers]

Ed,

Thanks again for the help.

It appears that it is still failing and the failure point is coming up in the area of "Set oRoot = GetObject("ldap://rootDSE")" . I even tried it on another server that is not on the same network and still get the same thing. Once that happened I thought about it for a minute and decided to try it on a network that is not even the one I am working on and it still failed in the same location of the script.

Any other ideas?

I am still looking around on the web to see what could be the issue and also checking around with others I know to see if I can get some input from them as well.

This is really bizarre that I cannot get these scripts to work other then when I have the output go to an excel file as in the script I added in.

Thanks again for the help as always it is much appreciated.

Best Regards
Kevin

 

[edmitchell]

Kevin

just a thought, the ‘new’ code that you posted recently had the ‘ldap’ section in a subroutine, but the modified code has it in a function (I’m presuming the new code (the one that posts the data into Excel) still works okay?). May be worthwhile re- doing into a subroutine and seeing it that then works for you?


Ed

 

[edmitchell]

Kevin

on that basis, I've recoded it into a single subroutine, see below:

Const ADS_SCOPE_SUBTREE = 2
Public Sub LookupUser()
Dim cn As String, GetAdsProp As String
cn = InputBox("Enter the common name", "AD Lookup")
SearchField = "cn"
SearchString = cn
ReturnField = "mail"
' get domain
Dim oRoot
Set oRoot = GetObject("[URL]ldap://rootDSE[/URL]")
Dim sDomain
sDomain = oRoot.Get("defaultNamingContext")
Dim strLDAP
strLDAP = "LDAP://" & sDomain
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 100
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    
' Search the AD recursively, starting at root of the domain
objCommand.CommandText = "SELECT " & ReturnField & " FROM '" & strLDAP & "' WHERE objectCategory='person'AND objectClass='user' and " & SearchField & "='" & SearchString & "'"
' RecordSet
Dim objRecordSet As Object
Set objRecordSet = objCommand.Execute
     
If objRecordSet.RecordCount = 0 Then
    GetAdsProp = "not found"  ' no records returned
Else
    GetAdsProp = objRecordSet.Fields(ReturnField)  ' return value
End If
 
'Output details
MsgBox GetAdsProp, vbOKOnly + vbInformation, "Email"
 
 
' Close connection
objConnection.Close
' Cleanup
Set objRecordSet = Nothing
Set objCommand = Nothing
Set objCommand = Nothing
End Sub

if that doesn't work I'm at a loss as to why the 'new' code works but this version won't get 'going'!

Ed

 

[KRKComputers]

Ed,

Thanks again for giving this a shot.

It appears to start to fail at "Set oRoot = GetObject("ldap://rootDSE")" and continues from that point on failing however that is on the one network and I have not tried on any other just yet.

I will try on another network as the day goes by and let you know what happens and if it works or not. I am almost ready to throw in the towel as you have been extremely helpful and I have tried many things on my side to get this working but all seems to be failing.

Once again I do appreciate all your effort and will let you know how things go but for now it is failing on the one network but that does not mean it will fail on others.

The truly odd part of all this is I am a domain admin and it is not working which does tell me one thing and that is it is not my permissions. The one network I am on is not the greatest but the other I can test on has no issues hence the reason for testing on multiple so I know it is not network or permission related. I am sure you understand that the easy way to troubleshoot is to test in multiple areas to eliminate all possibilities.

Thanks again for your effort and I will keep you posted I just need a couple of days to test as I am getting swamped with other items that need to be looked at as well and when I do I will see what happens.

Have a great upcoming weekend.

Thanks again for all your help and hanging in with me to try to figure this out.

Kevin