Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 2199
  • Last Modified:

Excel Code to get Data from Active directory.

Hi,

Excel Code to get Data from Active directory.
The script when run asks for the start and end date and retrieves the Created users details. I want one addition.

To have the managers email ID also next to the managers name. So all the other colums should be next.

Regards
Sharath

Sub Get_Users_Or_Contacts_Created_Between_Dates()
    Set objRootDSE = GetObject("LDAP://RootDSE")
    strDNSDomain = objRootDSE.Get("defaultNamingContext")
    
    strSheetName = "New NT Login"
    
    Set objSheet = Sheets(strSheetName)
    
    dtmStartDate = InputBox("Enter the start of the date range:", "Start of Date Range", "mm/dd/yyyy")
    dtmEndDate = InputBox("Enter the end of the date range:", "End of Date Range", "mm/dd/yyyy")
    'dtmStartDate = Right("0" & Month(Now), 2) & "/" & Right("0" & Day(Now), 2) & "/" & Year(Now)
    'dtmEndDate = Right("0" & Month(Now), 2) & "/" & Right("0" & Day(Now), 2) & "/" & Year(Now)
    
    Const ADS_SCOPE_SUBTREE = 2
    
    dtmStartDate = Right(dtmStartDate, 4) & Left(dtmStartDate, 2) & Mid(dtmStartDate, 4, 2) & "000000.0Z"
    dtmEndDate = Right(dtmEndDate, 4) & Left(dtmEndDate, 2) & Mid(dtmEndDate, 4, 2) & "115959.0Z"
    'dtmStartDate = "20060101000000.0Z"
    
    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") = 1000
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    
    objCommand.CommandText = _
        "SELECT adsPath FROM 'LDAP://" & strDNSDomain & "' WHERE objectCategory='person' AND (objectClass='user' OR objectClass='contact') " & _
            "AND whenCreated>='" & dtmStartDate & "' AND whenCreated<='" & dtmEndDate & "'"
            
    Set adoRecordset = objCommand.Execute
    ' Enumerate the resulting recordset.
    
    ' Change the column letter here to the first column where data will exist
    intRow = objSheet.Cells(65536, "A").End(xlUp).Row + 1
    Do Until adoRecordset.EOF
        Set objUser = GetObject(adoRecordset.Fields("adsPath").Value)
        strNTLoginColumn = "A"
        boolExists = Check_If_User_Already_In_Sheet(objUser.samAccountName, objSheet, strNTLoginColumn)
        If boolExists = False Then
            objSheet.Cells(intRow, strNTLoginColumn).Value = objUser.samAccountName
            objSheet.Cells(intRow, "B").Value = objUser.whenCreated
            objSheet.Cells(intRow, "C").Value = objUser.Description
            objSheet.Cells(intRow, "D").Value = objUser.DisplayName
            objSheet.Cells(intRow, "E").Value = objUser.mail
            objSheet.Cells(intRow, "F").Value = objUser.Department
            objSheet.Cells(intRow, "G").Value = objUser.Title
            If objUser.Manager <> "" Then
                objSheet.Cells(intRow, "H").Value = Mid(Left(objUser.Manager, InStr(objUser.Manager, ",") - 1), 4)
            End If
            objSheet.Cells(intRow, "I").Value = objUser.Class
            objSheet.Cells(intRow, "J").Value = Split(objUser.distinguishedName, ",")(1)
            intRow = intRow + 1
        End If
        adoRecordset.MoveNext
    Loop
End Sub
 
Function Check_If_User_Already_In_Sheet(ByVal strNTLogin, ByVal objSheet, ByVal strColumn) As Boolean
    boolAnswer = False
    For intRow = 1 To objSheet.Cells(65536, strColumn).End(xlUp).Row
        If LCase(objSheet.Cells(intRow, strColumn).Value) = LCase(strNTLogin) Then
            boolAnswer = True
            Exit For
        End If
    Next
    Check_If_User_Already_In_Sheet = boolAnswer
End Function

Open in new window

0
bsharath
Asked:
bsharath
  • 8
  • 3
  • 2
  • +1
1 Solution
 
ExcelGuideConsultantCommented:
is it already added to the sheet, so you are looking to have the columns switched? Or is it completely new? Because it looks like column E contains the mailaddress?
0
 
AngelizedCommented:

Add this line
objSheet.Cells(intRow, "G").Value = GetmanagerEmail(objUser.Manager)
and Add this function at the end
Public Function GetmanagerEmail(sUsername)
    Dim objUser As IADs
    GetmanagerEmail = ""
    Set objUser = GetObject("LDAP://" & sUsername)
   If Not IsEmpty(objUser) Then
       GetmanagerEmail = objUser.Get("mail")
   End If  
End Function
0
 
bsharathAuthor Commented:
Psychotec
Thats the users email address.

Angelized
I want the Manager Email Address in Colum I and the others moved to the next colum.

When i used the code i get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

User-defined type not defined
---------------------------
OK   Help  
---------------------------

I want the manager name in colum H as it is and I should have the  Manager Email address and the other I,J,K,L should be moved next
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
bsharathAuthor Commented:
Psychotec
Thats the users email address.

Angelized
I want the Manager Email Address in Colum I and the others moved to the next colum.

When i used the code i get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

User-defined type not defined
---------------------------
OK   Help  
---------------------------

I want the manager name in colum H as it is and I should have the  Manager Email address and the other I,J,K,L should be moved next
0
 
Dave BrettVice President - Business EvaluationCommented:
Hi Sharath

Hows the baby?

Cheers

Dave

 
Sub Get_Users_Or_Contacts_Created_Between_Dates()
    Dim objRootdse, objUser
    Set objRootdse = GetObject("LDAP://RootDSE")
    strDNSDomain = objRootdse.get("defaultNamingContext")
 
    strSheetName = "New NT Login"
 
    Set objSheet = Sheets(1)
 
    dtmStartDate = InputBox("Enter the start of the date range:", "Start of Date Range", "mm/dd/yyyy")
    dtmEndDate = InputBox("Enter the end of the date range:", "End of Date Range", "mm/dd/yyyy")
    'dtmStartDate = Right("0" & Month(Now), 2) & "/" & Right("0" & Day(Now), 2) & "/" & Year(Now)
    'dtmEndDate = Right("0" & Month(Now), 2) & "/" & Right("0" & Day(Now), 2) & "/" & Year(Now)
 
    Const ADS_SCOPE_SUBTREE = 2
 
    dtmStartDate = Right(dtmStartDate, 4) & Left(dtmStartDate, 2) & Mid(dtmStartDate, 4, 2) & "000000.0Z"
    dtmEndDate = Right(dtmEndDate, 4) & Left(dtmEndDate, 2) & Mid(dtmEndDate, 4, 2) & "115959.0Z"
    'dtmStartDate = "20060101000000.0Z"
 
    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") = 1000
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
 
    objCommand.CommandText = _
    "SELECT adsPath FROM 'LDAP://" & strDNSDomain & "' WHERE objectCategory='person' AND (objectClass='user' OR objectClass='contact') " & _
                             "AND whenCreated>='" & dtmStartDate & "' AND whenCreated<='" & dtmEndDate & "'"
 
    Set adoRecordset = objCommand.Execute
    ' Enumerate the resulting recordset.
 
    ' Change the column letter here to the first column where data will exist
    intRow = objSheet.Cells(65536, "A").End(xlUp).Row + 1
    Do Until adoRecordset.EOF
        Set objUser = GetObject(adoRecordset.Fields("adsPath").Value)
        strNTLoginColumn = "A"
        boolExists = Check_If_User_Already_In_Sheet(objUser.samAccountName, objSheet, strNTLoginColumn)
        If boolExists = False Then
            objSheet.Cells(intRow, strNTLoginColumn).Value = objUser.samAccountName
            objSheet.Cells(intRow, "B").Value = objUser.whenCreated
            objSheet.Cells(intRow, "C").Value = objUser.Description
            objSheet.Cells(intRow, "D").Value = objUser.DisplayName
            objSheet.Cells(intRow, "E").Value = objUser.mail
            objSheet.Cells(intRow, "F").Value = objUser.Department
            objSheet.Cells(intRow, "G").Value = objUser.Title
            If objUser.manager <> "" Then
                Set objusermgr = GetObject("LDAP://" & objUser.manager)
                objSheet.Cells(intRow, "H").Value = Mid(Left(objUser.manager, InStr(objUser.manager, ",") - 1), 4)
                objSheet.Cells(intRow, "I").Value = objusermgr.get("mail")
            End If
            objSheet.Cells(intRow, "j").Value = objUser.Class
            objSheet.Cells(intRow, "K").Value = Split(objUser.distinguishedName, ",")(1)
            intRow = intRow + 1
        End If
        adoRecordset.MoveNext
    Loop
End Sub
 
Function Check_If_User_Already_In_Sheet(ByVal strNTLogin, ByVal objSheet, ByVal strColumn) As Boolean
    boolAnswer = False
    For intRow = 1 To objSheet.Cells(65536, strColumn).End(xlUp).Row
        If LCase(objSheet.Cells(intRow, strColumn).Value) = LCase(strNTLogin) Then
            boolAnswer = True
            Exit For
        End If
    Next
    Check_If_User_Already_In_Sheet = boolAnswer
End Function

Open in new window

0
 
bsharathAuthor Commented:
Hi Dave,

Ya Baby is fine...

When i run the script it asks for the date but no results show up...
0
 
bsharathAuthor Commented:
Hi Dave,

Ya Baby is fine...

When i run the script it asks for the date but no results show up...
0
 
bsharathAuthor Commented:
Dave your code works but it does not get the output to the sheet i am running from but gets it tyo a different sheet erasing the data in that sheet... :-(
0
 
Dave BrettVice President - Business EvaluationCommented:
Sharath,

My apologies, I didn't erverse my code testing
pls change this
Set objSheet = Sheets(1)
to
Set objSheet = Sheets(strSheetName)

There are some other tidy-ups we can do if the code is running slowly, force the user to enter a date format etc

Cheers

Dave

0
 
AngelizedCommented:
yep sorry for the confusion the IADS is not working for VBS
and VBA need a reference.
this should work.
Set objmanager = GetObject("LDAP://" & objUser.manager)
If Not IsEmpty(objmanager ) Then   objSheet.Cells(intRow, "I").Value = objmanager .Get("mail")

0
 
bsharathAuthor Commented:
Thank U Dave...
Thank you all for the help worked fine now....
0
 
bsharathAuthor Commented:
Thank U Dave...
Thank you all for the help worked fine now....
0
 
Dave BrettVice President - Business EvaluationCommented:
Thanks for the grade Sharath

Let me know if you want me to improve the  speed of the data population into Excel

Cheers

Dave
0
 
bsharathAuthor Commented:
Yes Dave if thats not going to take a long time for you...
0

Featured Post

Upgrade your Question Security!

Your question, your audience. Choose who sees your identity—and your question—with question security.

  • 8
  • 3
  • 2
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now