Beyond Excel: VBA and Database Manipulation

Aug 6 2015   4:18PM GMT

LDAP Phone Directory

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker


My users wanted an easy way to get a current phone directory.  The previous method had the receptionist type up new lists, print them and distribute them.  Not all of the old printed lists were trashed resulting in multiple versions of the directory scattered throughout the business.  No one knew which was current, or even if a current listing was available.

Since our new IP Phone system is integrated with Active Directory, I created a simple Excel workbook that queries LDAP and lists all active users with phone extensions.  Now, whenever anyone wants a current directory, they just open the Excel app and click a button.  If my users want to save trees, they can chose to not print it.  They can sort it, filter it, and re-arrange it.  Below is the code.

This LDAP query uses ADO and LDAP’s very restricted form of SQL.  If you know SQL, you can read and understand the SQL String  below.


NOTE! This routine uses BXL Error Handling described here:


Public Sub GetUsers()
'   Description:Get User names for a Domain
'   Inputs:     *None
'   Outputs:    *None       (tblUsers)
'   Requisites: *None
'   Example:    GetUsers
'   Notes:
'     Date   Ini Modification
'   12/30/13 CWH Initial Programming
'   Declarations
    Const cRoutine      As String = "GetUsers"
    Dim oRootDSE        As Object       'RootDSE
    Dim sDN             As String       'Domain Name
    Dim oCN             As Object       'ADO Connection
    Dim oRS             As Object       'ADO RecordSet
    Dim sSQL            As String       'SQL Request String
    Dim n               As Long         'Generic Counter
    Const sTable        As String = "tblUsers"
'   Error Handling Initialization
    On Error GoTo ErrHandler
'   Initialize Variables
'   Determine DNS domain name.
    Set oRootDSE = GetObject("LDAP://RootDSE")
    sDN = oRootDSE.Get("defaultNamingContext")
'   Procedure
'   Delete table if it exists
    If Not IsError(Evaluate(sTable)) Then
        With Evaluate(sTable)
            If .ListObject Is Nothing Then _
                .Delete Else _
        End With
    End If
'   Get Data
    sSQL = "SELECT  ipPhone, sn, givenName  " & _
           "FROM    'LDAP://" & sDN & "' " & _
           "WHERE   objectClass='Person' " & _
           "  And   proxyAddresses='*' " & _
           "  And   userAccountControl <> 514 " & _
           "  And   userAccountControl <> 546 " & _
           "  And   ipPhone > 0 "
    Set oCN = CreateObject("ADODB.Connection")
    Set oRS = CreateObject("ADODB.Recordset")
    oCN.Provider = "ADsDSOObject"
    oCN.Open "Active Directory Provider"
    oRS.Open sSQL, oCN
    With wksUsers
        n = .UsedRange.SpecialCells(xlCellTypeLastCell).row + 2
        With .ListObjects.Add(SourceType:=xlSrcQuery, _
                              Source:=oRS, _
                              Destination:=.Cells(n, 1))
            .Name = sTable
        '   Format Table
            .ListColumns(1).Name = "First Name"
            .ListColumns(2).Name = "Last Name"
            .ListColumns(3).Name = "Extension"
            .HeaderRowRange.Style = "Accent3"
        '   Sort Table
            .Sort.SortFields.Add .ListColumns(1).Range(1), _
                                 Excel.XlSortOn.xlSortOnValues, _
        '   Freeze Panes
            ActiveWindow.FreezePanes = False
            .HeaderRowRange.Cells(2, 1).Select
            ActiveWindow.FreezePanes = True
        End With
    End With
    Select Case Err.Number
        Case Is = NoError:                          'Do nothing
        Case Else:
            Select Case DspErrMsg(cModule & "." & cRoutine)
                Case Is = vbAbort:  Stop: Resume    'Debug mode - Trace
                Case Is = vbRetry:  Resume          'Try again
                Case Is = vbIgnore:                 'End routine
            End Select
    End Select
End Sub

 Comment on this Post

There was an error processing your information. Please try again later.
Thanks. We'll let you know when a new response is added.
Send me notifications when other members comment.

Forgot Password

No problem! Submit your e-mail address below. We'll send you an e-mail containing your password.

Your password has been sent to:

Share this item with your network: