UNE COMBOBOX REMPLIE PAR ACCESS EN VBSCRIPT POUR VOS FORMULAIRES

'**********************************************************************************
'** Type:          SubRoutine
'** Name:          BuildList
'** Arguments:     Référence Objet
'** Return:        Nothing
'**********************************************************************************
'** Developped by: David Thueler
'** Creation Date: 10 Oct. 2006
'** Last Modified: -
'** Purpose:       Populate ComboBox object from MDB file and sort the list.
'**                ADO Shared Component 3.6 MUST be registered or it will hangs!
'**
'** Usage:         Set cboList = Item.GetInspector.ModifiedFormPages("OutlookPageName").Controls("ControlName")
'**                BuildList(cboList)
'**********************************************************************************
Sub BuildList(objListe)
    Dim rst		'Recordset
    Dim dao		'Reference DAO
    Dim wks		'Workspace
    Dim dbs		'Database
    Dim strAccessDir	'Chemin du fichier
    Dim strDBName	'Nom de fichier
    Dim EmployeeArray	'Enregistrement
    Dim arrEmployee()	'Tableau des Employés
    Dim indEmployee	'Indice du Tableau
    Dim RecEmployee	'Enregistrement en traitement
    Dim SortLoop	'Indice de boucle pour le tri par insertion
    Dim intSeekPos	'Position de l'insertion

    On Error Resume Next
 
    'Définit le nom et emplacement de la base de donnée
    strAccessDir = "R:\"
    strDBName = strAccessDir & "phonelist.mdb"
 
    'Set reference de la base Access. ADO36 doit être enregistré sinon le moteur doit être modifié en conséquence
    Set dao = Application.CreateObject("DAO.DBEngine.36")
    If Err > 0 Then
	'on quitte le sub si la connexion a échouée
        Exit Sub
    End If
    Set wks = dao.Workspaces(0)
    Set dbs = wks.OpenDatabase(strDBName)
 
    'Lien sur la table qui nous intéresse
    Set rst = dbs.OpenRecordset("Employees")

    'On parcours les enregistrements de la table
    indEmployee = 0
    With rst
        .MoveFirst
	While Not .EOF
	    EmployeeArray = rst.GetRows(1)
	    'On ajuste la dimension du tableau (très important dans le cas de ce script!)
	    ReDim Preserve arrEmployee(indEmployee)

	    'On construit la chaîne de caractère avec les enregistrements intéressants.
	    'Dans notre cas, [Nom de famille] [Prénom] ([Téléphone]) à l'aide des indices
	    RecEmployee = EmployeeArray(1,0) & " "
	    RecEmployee = RecEmployee & EmployeeArray(0,0) & " ("
	    RecEmployee = RecEmployee & Left(EmployeeArray(2,0),4) & ")"

	'On insert l'enregistrement à la bonne place dans la liste
	    For SortLoop = 0 To indEmployee
		If StrComp(RecEmployee, arrEmployee(SortLoop), vbTextCompare)<0 Then
		    intSeekPos = SortLoop
	    	    Exit For
		End If
	    Next
	    For SortLoop=indEmployee To intSeekPos+1 step -1
		arrEmployee(SortLoop)=arrEmployee(SortLoop-1)
	    Next
	    arrEmployee(intSeekPos)=RecEmployee
	
	    indEmployee = indEmployee + 1
	Wend
    	.Close
    End With

    'On met à jour la ComboBox
    objListe.List() = arrEmployee
End Sub