Solved

Excel Macro that queries the active directory for the Newly created Users does not get the Contact details.

Posted on 2008-10-28
15
465 Views
Last Modified: 2012-05-05
Hi,

Excel Macro that queries the active directory for the Newly created Users does not get the Contact details.
Can the newly created contact details also be brough in. In the same manner as the user.

Regards
Sharath

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(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
                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
Comment
Question by:bsharath
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 10
  • 5
15 Comments
 
LVL 65

Expert Comment

by:RobSampson
ID: 22828640
Sharath, this should do it.  It was checking if the contact already exists, by referencing the samAccountName, which doesn't exist for a Contact....it now checks Display Name for contacts.

Regards,

Rob.
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(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"
        strDisplayNameColumn = "D"
        If LCase(objUser.Class) = "user" Then
            boolExists = Check_If_User_Already_In_Sheet(objUser.samAccountName, objSheet, strNTLoginColumn)
        ElseIf LCase(objUser.Class) = "contact" Then
            boolExists = Check_If_User_Already_In_Sheet(objUser.displayName, objSheet, strDisplayNameColumn)
        End If
        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
 
LVL 11

Author Comment

by:bsharath
ID: 22828653
Thank U... :-)))

Still get just the user data retrieved.

Today 1 created a Ntlogin and a contact for 1 same user. When i run the macro it gets me the NTlogin but not the Contact detail.
0
 
LVL 11

Author Comment

by:bsharath
ID: 22828655
Thank U... :-)))

Still get just the user data retrieved.

Today 1 created a Ntlogin and a contact for 1 same user. When i run the macro it gets me the NTlogin but not the Contact detail.
0
Get 15 Days FREE Full-Featured Trial

Benefit from a mission critical IT monitoring with Monitis Premium or get it FREE for your entry level monitoring needs.
-Over 200,000 users
-More than 300,000 websites monitored
-Used in 197 countries
-Recommended by 98% of users

 
LVL 65

Expert Comment

by:RobSampson
ID: 22828720
Hmmm, maybe you don't have a display name for that contact?

Try changing this line
            boolExists = Check_If_User_Already_In_Sheet(objUser.displayName, objSheet, strDisplayNameColumn)

to this
            boolExists = Check_If_User_Already_In_Sheet(objUser.cn, objSheet, strDisplayNameColumn)


Regards,

Rob.
0
 
LVL 11

Author Comment

by:bsharath
ID: 22828729
Still dont get the contacts
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 22828739
Hmmm, under this line:
        ElseIf LCase(objUser.Class) = "contact" Then

put this
            MsgBox "Class: " & objUser.Class & vbCrLf & _
                        "CN: " & objUser.CN & vbCrLf & _
                        "DisplayName: " & objUser.DisplayName

and see if you get that contact name....

Regards,

Rob.
0
 
LVL 11

Author Comment

by:bsharath
ID: 22828748
I get this

---------------------------
Microsoft Excel
---------------------------
Class: contact

CN: Aruna kansn

DisplayName: Aruna Kansn
---------------------------
OK  
---------------------------

In Colum "J" if contact will display as contact and if user shows as User right?
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 22828779
Odd.....is this right:
strDisplayNameColumn = "D"

You are right about Column J

It checks if the contact is there first though......what about, under this
boolExists = Check_If_User_Already_In_Sheet(objUser.cn, objSheet, strDisplayNameColumn)

you put this
boolExists = False

That way, you force it to put the details there.....but it will double up on the next run.....

Rob.
0
 
LVL 11

Author Comment

by:bsharath
ID: 22828793
Thanks works fine now.

Colum "H" & "I" gets the managers name and email address that does not happen now.

Can you remove the other code which may not be required...
0
 
LVL 11

Author Comment

by:bsharath
ID: 22828794
Thanks works fine now.

Colum "H" & "I" gets the managers name and email address that does not happen now.

Can you remove the other code which may not be required...
0
 
LVL 11

Author Comment

by:bsharath
ID: 22842350
Rob any help...
0
 
LVL 65

Accepted Solution

by:
RobSampson earned 500 total points
ID: 22847542
Ah, I think I fixed an error with identifying the contact there....try this.

Regards,

Rob.
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(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"
        strDisplayNameColumn = "D"
        If LCase(objUser.Class) = "user" Then
            boolExists = Check_If_User_Already_In_Sheet(objUser.samAccountName, objSheet, strNTLoginColumn, "user")
        ElseIf LCase(objUser.Class) = "contact" Then
            boolExists = Check_If_User_Already_In_Sheet(objUser.displayName, objSheet, strDisplayNameColumn, "contact")
        End If
        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, ByVal strType) As Boolean
    boolAnswer = False
    For intRow = 1 To objSheet.Cells(65536, strColumn).End(xlUp).Row
        If LCase(objSheet.Cells(intRow, strColumn).Value) = LCase(strNTLogin) And LCase(strType) = LCase(objSheet.Cells(intRow, "J").Value) Then
            boolAnswer = True
            Exit For
        End If
    Next
    Check_If_User_Already_In_Sheet = boolAnswer
End Function

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 22847668
I dont get the manager name and Manager email id to "H" & "I" colums
All other is fine...
0
 
LVL 11

Author Comment

by:bsharath
ID: 22847669
I dont get the manager name and Manager email id to "H" & "I" colums
All other is fine...
0
 
LVL 11

Author Comment

by:bsharath
ID: 22856035
Thank U Rob works fine now... :-)))
0

Featured Post

Technology Partners: 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!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

The Windows functions GetTickCount and timeGetTime retrieve the number of milliseconds since the system was started. However, the value is stored in a DWORD, which means that it wraps around to zero every 49.7 days. This article shows how to solve t…
This article describes how you can use Custom Document Properties to store settings and other information in your workbook so that they will be available the next time you open the workbook.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

691 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question