Unlimited Sub-Category Functions VBScript permettant le tri d'un Array

Tout annuaire qui se respecte utilise un système de classement par Catégories. Jusque là, vous me direz qu'il n'y a rien de très complexe à réaliser. Mais combien d'entre vous ont déjà essayé ce système qui se résume, pour un développeur non-confirmé, à une série de requêtes SQL recursives qui récuperent les Categories filles au fur et a mesure du traitement.

Et bien sachez que ces petits outils VBScript vous permettront de ressortir toutes vos Catégories en une seule requête SQL, je m'occupe du reste :).

Posons plus sérieusement le problème :

Imaginons la table suivante :

Table AVE_Categories Champs Type CatID Numérique ou AutoNumber CatIDParent Numérique CatDescription Texte CatSort Numérique Vous remarquerez la présence d'un ou plusieurs CatIDParent = 0. La valeur 0 a été choisie comme le parent d'une Catégorie Racine. CatSort représente l'ordre d'affichage par groupe de CatIDParent.

Contenu AVE_Categories CatID CatIDParent CatDescription CatSort 1 0 Accueil 1 2 0 Membres 2 3 2 Login 1 4 2 Logout 3 5 2 Profil 2 6 5 Editer 1 7 5 Supprimer 2 8 0 Contact 3

Voici le résultat attendu :

Accueil

Membres

Login

Profil

Editer

Supprimer

Logout

Contact

Solution proposé :

Le but est de construire l'arbre à partir d'un RecordSet venant de la requête SQL :
"SELECT CatID, CatIDParent, CatDescription FROM AVE_Categories ORDER BY CatIDParent, CatSort;"

Première Etape :
On commence par stocker le RecordSet dans un Array Multi-Dimensionnel

Deuxième Etape :
Si le RecordSet contient au moins un résultat, on lance la procédure tri / affichage

' On verifie la présence d'au moins un résultat If IsArray(tempArray) Then   Response.Write "<table border=""0"" cellspacing=""0"" cellpadding=""0"">"   Response.Write "  <tr>"   Response.Write "    <td>"   First = 1   ' On tri tempArray sur le couple CatID, CatIDParent   tempSort = SortIdIdPar(tempArray, 0, 1, 0)   leStrImgOpt = " width=""16"" height=""22"" border=""0"" align=""absmiddle"">"   leStrImg = ""   ' On boucle sur l'Array trié   For i = 0 To UBound(tempSort, 2)     If First = 1 Then       First = 0     Else       Response.Write "    </td>"       Response.Write "  </tr>"       Response.Write "  <tr>"       Response.Write "    <td>"     End If     ' On recupere la Node a afficher     laNode = UCase(GetNode(tempSort, i, 0, 1, 0))     Select Case laNode       Case "LAST"         img = "<img src=""http://www.efrance.fr/moussland/tree_nlm.gif""" & leStrImgOpt       Case "NOTLAST"         img = "<img src=""http://www.efrance.fr/moussland/tree_nm.gif""" & leStrImgOpt       Case "LASTNODE"         img = "<img src=""http://www.efrance.fr/moussland/tree_nl.gif""" & leStrImgOpt       Case "NODE"         img = "<img src=""http://www.efrance.fr/moussland/tree_nt.gif""" & leStrImgOpt     End Select     Response.Write leStrImg & img & "&nbsp;" & tempSort(2, i) & "&nbsp;" & laNode     Select Case laNode       Case "LAST"         leStrImg = leStrImg & "<img src=""http://www.efrance.fr/moussland/tree_blank.gif""" & leStrImgOpt       Case "NOTLAST"         leStrImg = leStrImg & "<img src=""http://www.efrance.fr/moussland/tree_nv.gif""" & leStrImgOpt       Case "LASTNODE"         If i + 1 >= UBound(tempSort, 2) Then           leStrImg = ""         Else           ' On casse le String d'images en fonction des levels d'affichage           leLevel_1 = GetLevel(tempSort, i, 0, 1, 0)           leLevel_2 = GetLevel(tempSort, i + 1, 0, 1, 0) - 1           If leLevel_1 > leLevel_2 Then             For j = leLevel_1 To leLevel_2 Step -1               If leStrImg <> "" Then                 leStrImg = Left(leStrImg, InStrRev(leStrImg, "<img") - 1)               End If             Next           Else             For j = leLevel_2 To leLevel_1 Step -1               If leStrImg <> "" Then                 leStrImg = Left(leStrImg, InStrRev(leStrImg, "<img") - 1)               End If             Next           End If         End If     End Select   Next   Response.Write "    </td>"   Response.Write "  </tr>"   Response.Write "</table>" End If

Et voici les fonctions permettant l'execution de ce script :

SortIdIdPar :

Public Function SortIdIdPar(ByRef tempToSort, posId, posPar, racine)   ' Cette fonction permet le tri d'un array sur le principe d'un couple ID / IDParent   ' Parametres :   '   - tempToSort : Array a trier   '   - posId : Position de l'ID de la categorie dans l'Array   '   - posPar : Position de l'IDParent de la categorie dans l'Array   '   - racine : Valeur d'IDParent pour une categorie Racine   ' On recupere les nombre de colonnes et de lignes de l'array a trier   nbC = UBound(tempToSort, 1)   nbR = UBound(tempToSort, 2)   ' On prepare un Array de sortie a la taille de l'array a trier   ReDim tempSort(nbC, nbR)   nbOK = 0   sortPos = 0   sortOK = 0   leId = racine   ' Premiere etape, on transfere les categories Racine dans l'Array final   For i = 0 To nbR     If tempToSort(posPar, i) = racine Then       For j = 0 To nbC         tempSort(j, sortPos) = tempToSort(j, i)       Next       ' On compte le nombre de transfert       nbOK = nbOK + 1       sortPos = sortPos + 1     End If   Next   sortPos = 0   insPos = sortPos + 1   posOK = 0   ' Tant que le tri n'est pas fini   Do While sortOK = 0     ' On recupere le ID de la premiere categorie     leId = tempSort(posId, sortPos)     ' On cherche s'il y a une categorie fille     For i = 0 To nbR       If tempToSort(posPar, i) = leId Then         ' Si categorie fille, on decale l'array trié d'une position pour insertion fille         For j = nbOK To insPos + 1 Step -1           For k = 0 To nbC             tempSort(k, j) = tempSort(k, j - 1)           Next         Next         For j = 0 To nbC           tempSort(j, insPos) = tempToSort(j, i)         Next         ' On incremente le nb transfert         nbOK = nbOK + 1         If nbOK + 1 > nbR + 1 Then           i = nbR + 1         Else           insPos = insPos + 1         End If       End If     Next     sortPos = sortPos + 1     insPos = sortPos + 1     ' Si nb transfert > nb lignes ==> tri fini     If nbOK + 1 > nbR + 1 Then       sortOK = 1     End If   Loop   ' On assigne l'array trié au retour de funtion   SortIdIdPar = tempSort End Function

GetNode :

Public Function GetNode(ByRef tempSort, row, posId, posPar, racine)   ' Cette function permet de trouver l'image a afficher en fonction d'un array trié   ' Parametres :   '   - tempSort : Array trié   '   - row : Ligne de travail dans l'Array trié   '   - posId : Position de l'ID de la categorie dans l'Array   '   - posPar : Position de l'IDParent de la categorie dans l'Array   '   - racine : Valeur d'IDParent pour une categorie Racine   laNode = ""   ' On cherche s'il existe un autre element de meme IDParent plus loin dans l'Array trié   For j = row + 1 To UBound(tempSort, 2)     If tempSort(posPar, j) = tempSort(posPar, row) Then       ' Si oui, on affiche une node en t       laNode = "NODE"     End If   Next   If laNode = "" Then     ' Si non, c'est la derniere node du Level     laNode = "LASTNODE"   End If   ' On cherche les filles de la categories selectionne pour changer la node en + ou -   If row + 1 <= UBound(tempSort, 2) Then     ' Si filles     If tempSort(posPar, row + 1) = tempSort(posId, row) Then       If laNode = "NODE" Then         laNode = "NOTLAST"       Else         laNode = "LAST"       End If     End If   End If   GetNode = laNode End Function

GetLevel :

Public Function GetLevel(ByRef tempSort, row, posId, posPar, racine)   ' Cette function permet de trouver le Level d'une categorie en fonction d'un array trié   ' Parametres :   '   - tempSort : Array trié   '   - row : Ligne de travail dans l'Array trié   '   - posId : Position de l'ID de la categorie dans l'Array   '   - posPar : Position de l'IDParent de la categorie dans l'Array   '   - racine : Valeur d'IDParent pour une categorie Racine     pos = row     leLevel = 0     ' On compte le nb de lignes jusqu'a la racine     Do While tempSort(posPar, pos) <> racine         leLevel = leLevel + 1         pos = pos - 1     Loop     GetLevel = leLevel + 1 End Function

Et bien voila ma première page finie ....
Surtout n'hésitez pas à me reporter les différents buggs trouvés car j'ai tellement de version de ces fonctions qu'il se pourrait que ce ne soit pas les dernières ...

Ma prochaine page portera sur une gestion multi-page via ADO ...

Bon Dev à tous ...