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
449 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
  • 10
  • 5
15 Comments
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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
Comment Utility
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
Comment Utility
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 65

Expert Comment

by:RobSampson
Comment Utility
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
Comment Utility
Still dont get the contacts
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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
Comment Utility
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
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
Rob any help...
0
 
LVL 65

Accepted Solution

by:
RobSampson earned 500 total points
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
Thank U Rob works fine now... :-)))
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Over the years I have built up my own little library of code snippets that I refer to when programming or writing a script.  Many of these have come from the web or adaptations from snippets I find on the Web.  Periodically I add to them when I come…
Active Directory replication delay is the cause to many problems.  Here is a super easy script to force Active Directory replication to all sites with by using an elevated PowerShell command prompt, and a tool to verify your changes.
The viewer will learn how to create and use a small PHP class to apply a watermark to an image. This video shows the viewer the setup for the PHP watermark as well as important coding language. Continue to Part 2 to learn the core code used in creat…
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

763 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

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now