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.
<html>
<!--
This HTA demonstrates how to build a combo box filled with objects from Active Directory.
Note there may need to be optimizations made for environments with large numbers of records,
not just for search performance but to make the combo box a reasonable size.
-->
<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>
<script language="vbscript">
Option Explicit
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>
<div id="divCboList" name="divCboList"> </div>
</body>
Posted
May 20 2008, 08:28 AM
by
danholme