Create a drop-down list in an HTA populated with objects from Active Directory

danholme — Tue, 20 May 2008 17:28:23 GMT

The following code demonstrates how to create a drop-down list (also called a "combo box") in an HTA that is automatically populated by querying Active Directory.

<head>
<title>My Title</title>
<HTA:APPLICATION
    ID="oHTA" />
<style>
    body, tr, td, table, p, input {font-family: arial; font-size: 9pt;}
    textarea {font-family: arial; font-size: 8pt;}
    td {vertical-align:top;}
    .trodd {background-color: #cccccc;}
    .treven {background-color: #ffffff;}
    .tdlabel {width: 30%}
    .tdvalue {width: 70%}
</style>

Sub Window_Onload
Call FillResources
End Sub

Sub FillResources()
' Version 080520
' Creates a drop-down list based on an AD query

    Dim sHTML
    Dim rsObjects
    Dim sLDAPQuery, sSearchDN, sProperties, sSortProperty
    Dim sLabel, sValue
    ' Define the query for the drop-down list
    sLDAPQuery = "(&(objectCategory=person)(cn=*))"
    ' Define the scope of the search
    sSearchDN = "ou=people,dc=contoso,dc=com"
    ' Which properties do you want to bring back
    sProperties = "sAMAccountName,displayName"
    ' Which property do you want to sort by (must be in sProperties as well)
    sSortProperty = "displayName"
    Set rsObjects = AD_Query (sLDAPQuery, sSearchDN, "subtree", sProperties, sSortProperty)
    If rsObjects Is Nothing Then
        ' This is debug code--you'll want to change this (probably just keep it 'silent') in production
        MsgBox "No objects found"
        Exit Sub
    End If
    rsObjects.MoveFirst
    Do Until rsObjects.EOF
        ' Build each entry (<option> tag) in the drop down list
        ' the VALUE is what is actually stored as the selected item in the drop-down list,
        ' and should be unique
        ' the LABEL is what is actually displayed in the drop-down list.
        ' Note that IE6 does not allow separation of the two (value vs. label)
        ' so you need IE7 to view the HTA
        sLabel = rsObjects.Fields("displayName")
        sValue = rsObjects.Fields("samAccountName")
        sHTML = sHTML & "<option value=""" & sValue & """>" & sLabel & "</option>" & VbCrLf
        rsObjects.MoveNext
    Loop
    ' Build the drop-down list (the <select> tag) around the <option>s
    ' note the onchange event is hard wired in. Because you are 'recreating' the drop-down list,
    ' the name of the subroutine itself (cboList_OnChange) is not enough--it has to be specified
    ' in the <select> tag.
    sHTML = "<select id=""cboList"" name=""cboList"" onchange=""cboList_OnChange()"">" & VbCrLf & _
        sHTML
    sHTML = sHTML & "</select>"
    ' You need to have a <div> in your HTML with the ID and NAME of divCboList
    divCboList.innerHTML = sHTML
End Sub

Function AD_Query(ByVal sLDAPQuery, ByVal sSearchDN, ByVal sSearchScope, ByVal sProperties, ByVal sSortProperty)
    ' VERSION 080520
    ' Inputs:
    ' sLDAPQuery: an LDAP query
    ' sSearchDN: the DN within which to search (often, the DN of the domain, e.g. dc=contoso, dc=com)
    ' sSearchScope: the AD Search scope, which can be subtree or onelevel or base (subtree most common)
    ' sProperties: the attributes to return from matching objects, comma-delimited.
    '                if blank, ADsPath is returned
    ' sSortProperty: the property to sort on - must be included in sProperties as well
    '                  Can NOT be distinguished name see KB 842637 for alternate method
    '
    ' Change log 080520
    ' Added SORT
    ' Cleaned up code per KB 842637 example
    Dim oConnection
    Dim oCommand
    Dim oRecordset
    If trim(sProperties) = "" then sProperties = "ADsPath"
    ' Open an ADO connection using null credentials
    Set oConnection = CreateObject("ADODB.Connection")
    oConnection.Provider = "ADsDSOObject"
    oConnection.Properties("Encrypt Password") = True
    oConnection.Properties("ADSI Flag") = 1 ' adSecureAuthentication
    'On Error Resume Next
    oConnection.Open "Active Directory Provider", vbNullString, vbNullString
    If oConnection.State = 0 Then ' adStateClosed
         ' Error handling code
         ' WScript.Echo "ERROR: Connection to AD failed."
         Exit Function
    End If
    ' Build the LDAP Query
    sLDAPQuery = "<LDAP://" & sSearchDN & ">;" & _
        sLDAPQuery & ";" & _
        sProperties & ";" & sSearchScope
    Set oCommand = CreateObject("ADODB.Command")
    oCommand.ActiveConnection = oConnection
    oCommand.Properties("Sort On") = sSortProperty
    oCommand.CommandType = 1 ' adCmdText
    oCommand.CommandText = sLDAPQuery
    ' Debug code
    ' MsgBox sLDAPQuery
    Set oRecordset = CreateObject("ADODB.Recordset")
    oRecordset.Open oCommand, , 3, 1 ' adUseClient, adLockReadOnly
    ' Check to make sure we received at least one result
    If oRecordset.EOF and oRecordset.BOF Then
        ' Error handling code
        ' WScript.Echo "ERROR: No objects found." & VbCrLf & sLDAPQuery & vbCrLf & VbCrLf
        Set AD_Query = Nothing
    Else
        Set AD_Query = oRecordset.clone
    End If
    oRecordset.Close
    'oConnection.Close
End Function

Sub CboList_OnChange()
    Dim sSelected
    sSelected = cboList.value
    ' TEST CODE
    MsgBox "You selected: " & sSelected
End Sub

</script>

</head>
<body>

</body>

Dan Holme : HTA

Create a drop-down list in an HTA populated with objects from Active Directory