Wrox Programmer Forums
Go Back   Wrox Programmer Forums > Microsoft Office > Excel VBA > Excel VBA
|
Excel VBA Discuss using VBA for Excel programming.
Welcome to the p2p.wrox.com Forums.

You are currently viewing the Excel VBA section of the Wrox Programmer to Programmer discussions. This is a community of software programmers and website developers including Wrox book authors and readers. New member registration was closed in 2019. New posts were shut off and the site was archived into this static format as of October 1, 2020. If you require technical support for a Wrox book please contact http://hub.wiley.com
 
Old February 13th, 2013, 06:35 PM
Registered User
 
Join Date: Feb 2013
Posts: 1
Thanks: 0
Thanked 0 Times in 0 Posts
Default Query Active Directory /ladp

Hello,

Thanks for your time and input first off...My issue is I have an excel document, whereby this is my issue: I have a userform that initializes, and when it does, I would like Excel to retrieve the name of a person, and also the department they work in. Which active directory is populated with.

Ive been experimenting with code, but I haven't been able to really find something that does this...Has anyone developed anything that does this or know how to get VBA to make an LADP request? I have Active X Data Objects Library enabled, I have a code that can ask you to enter an outlook group and retrieve the members from that group - but thats about as far as Ive gotten. Anyone ever able to do this? thanks for your help...would it help if I provided the ability to download my sheet?

Code:
Sub LDAPQueryDevices()
'****
' VBSCRIPT to interogate AD/LDAP for a given group and report the following
'
' 1) tally of the number of members of the given group
' 2) list user details against group
'
' Author    Jim Ward
' Creation  27th May 2011
'
' Gleaned from various sources and assembled into the following
'
'****
'
'****
' declare some array storage for names and paths
'****
'
Dim grouppaths(500) As String
Dim groupnames(500) As String
numheader2 = 4
Dim headers2(4) As String
headers2(1) = "GroupName"
headers2(2) = "DeviceName"
headers2(3) = "OperatingSystem"
headers2(4) = "DistinguishedName"
NoEntry = "No Entry"
Const xlAscending = 1
Const xlDescending = 2
Const xlYes = 1
Const TallyName = "Counts"
Const ListName = "Devices"
'
'****
' prompt user for group to find
'****
'
groupname = InputBox("Please enter the name of the group:")
If groupname = "" Then
    Exit Sub
End If
'
'****
' set up our ADO query and excute it to find group matches
'****
'
Application.StatusBar = "Searching for Records..."
Set cmd = CreateObject("ADODB.Command")
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
    
cn.Open "Provider=ADsDSOObject;"
    
cmd.CommandText = "SELECT adspath,cn from 'LDAP://" & getNC & _
              "' WHERE objectCategory = 'Group' and cn = '" & groupname & "'"
cmd.ActiveConnection = cn
    
Set rs = cmd.Execute
'
'****
' process the results of the query into our arrays for later
'****
'
i = 0
While rs.EOF <> True And rs.BOF <> True
    grouppaths(i) = rs.Fields("adspath").Value
    groupnames(i) = rs.Fields("cn").Value
    rs.MoveNext
    i = i + 1
Wend
cn.Close
If i = 0 Then
    MsgBox "Nothing Found, Exiting"
    Exit Sub
End If
Application.StatusBar = "Records Found..." & i
'
'****
' Turn off updates and calculations
'****
'
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = True
'
'****
' found something so create the output files and write the headers
'****
'
Application.StatusBar = "Creating Worksheet headers..."
If i > 0 Then
'
'****
' Copy Field names to header row of worksheet 1
'****
'
    Set objsheet = Worksheets(1)
    objsheet.Cells(1, 1).Value = "GroupName"
    objsheet.Cells(1, 1).Font.Bold = True
    objsheet.Cells(1, 2).Value = "Count"
    objsheet.Cells(1, 2).Font.Bold = True
'
'****
' Copy Field names to header row of worksheet 2
'****
'
    Set objsheet = Worksheets(2)
    For h = 1 To numheader2
        objsheet.Cells(1, h) = headers2(h)
        objsheet.Cells(1, h).Font.Bold = True
    Next
End If
'
'****
' now process each group found and extract all members
'****
'
cl = 1      'count lines
gl = 1      'group lines
Application.StatusBar = "Populating Worksheets..."
For j = 0 To i - 1
    Application.StatusBar = "Writing Group " & j & " of " & i
    Set objgroup = GetObject(grouppaths(j))
    Set objsheet = Worksheets(1)
    cl = cl + 1
    objsheet.Cells(cl, 1).Value = groupnames(j)
    objsheet.Cells(cl, 2).Value = objgroup.Members.Count
    c = objgroup.Members.Count
    g = 0
    Set objsheet = Worksheets(2)
    If objgroup.Members.Count > 0 Then
        For Each objmember In objgroup.Members
            g = g + 1
            Application.StatusBar = "Writing Group Details " & g & " of " & c
            gl = gl + 1
            objsheet.Cells(gl, 1).Value = groupnames(j)
            objsheet.Cells(gl, 2).Value = Right(objmember.Name, Len(objmember.Name) - 3)
            objsheet.Cells(gl, 3).Value = objmember.OperatingSystem
            objsheet.Cells(gl, 4).Value = objmember.distinguishedName
        Next
    Else
        gl = gl + 1
        objsheet.Cells(gl, 1).Value = groupnames(j)
        For h = 2 To numheader2
            objsheet.Cells(gl, h) = NoEntry
        Next
    End If
Next
'
'****
' All done, name sheet, sort data, autofit columns, close up and exit
'****
'
'
'****
' to sort the data we have to actually select the required sheet before we can do anything
'****
'
Application.StatusBar = "Sorting Worksheets..."
Set objworksheet = Worksheets(1)
objworksheet.Name = TallyName
objworksheet.Select
Set objRange = objworksheet.UsedRange
Set objRange2 = Range("A1")
objRange.Sort objRange2, xlAscending, , , , , , xlYes
ActiveSheet.UsedRange.Columns.EntireColumn.AutoFit
Set objworksheet = Worksheets(2)
objworksheet.Name = ListName
objworksheet.Select
Set objRange = objworksheet.UsedRange
Set objRange2 = Range("A1")
Set objRange3 = Range("B1")
objRange.Sort objRange2, xlAscending, objRange3, , xlAscending, , , xlYes
ActiveSheet.UsedRange.Columns.EntireColumn.AutoFit
'
'****
' Turn ON updates and calculations
'****
'
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
MsgBox "All Done"
End Sub
Function getNC()
    Set objRoot = GetObject("ldap://RootDSE")
    getNC = objRoot.get("defaultNamingContext")
End Function





Similar Threads
Thread Thread Starter Forum Replies Last Post
query active directory dummies2 SQL Server 2000 4 August 21st, 2007 08:33 AM
Active Directory TCSE305 Windows Server 1 November 22nd, 2006 01:26 AM
About Active Directory apalmero VS.NET 2002/2003 1 November 9th, 2003 01:06 PM





Powered by vBulletin®
Copyright ©2000 - 2020, Jelsoft Enterprises Ltd.
Copyright (c) 2020 John Wiley & Sons, Inc.