Adaptation Code Treeview

Question

Bonjour le forum, j'ai récupéré un treeview dont le code est le suivant : Code : Sub Charger()' On Error GoTo Err_ChargerDim NodCurrent As Node Dim StrText AsStringDim NodRoot As Node Dim Bk AsStringSet Db = CurrentDb Set Rs Db.OpenRecordset("Menus", dbOpenDynaset, dbReadOnly)Set Menu Me.Xtree.Object Menu.Nodes.Clear Rs.FindFirst"Menu_Parent Is Null Or Menu_Parent = 0"' Cherche le premier pereDoUntil Rs.NoMatch StrText = Rs!Menu_Libelle Set NodCurrent = Menu.Nodes.Add(, , "a" & Rs!ID_Menu, StrText)' Ajoute une branche père Bk = Rs.Bookmark' mémorise la place AddChildren NodCurrent, Rs ' Lance une proc recursive pour trouver les fils Rs.Bookmark = Bk ' Retourne à sa place Rs.FindNext"Menu_Parent Is Null Or Menu_Parent = 0"' suite de la rechercheLoop Menu.Sorted = True Bulle "Sélectionnez votre formulaire ou votre état.", "cliquez sur :", "+ pour étendre", "- pour réduire" Exit_Charger: ExitSub Err_Charger: Bulle "Chargement rubrique", "Erreur chargement", Rs("Menu_Libelle"), ""Resume Exit_Charger EndSub Sub AddChildren(nodBoss As Node, Rst As DAO.Recordset)OnErrorGoTo ErrAddChildren Dim NodCurrent As Node Dim objTree As TreeView, StrText AsString, Bk AsStringDim HeyBoss Set objTree = Me!Xtree.Object' ** Cherche le premier fils, le No est dans la clé du boss Rst.FindFirst"Menu_Parent =" & Mid(nodBoss.Key, 2)DoUntil Rst.NoMatch StrText Rst("Menu_Libelle")' Ajoute le premier filsSet NodCurrent objTree.Nodes.Add(nodBoss, tvwChild, "a" & Rst("ID_Menu"), StrText) Bk = Rst.Bookmark' on vérifie si ce fils est lui méme pére AddChildren NodCurrent, Rst Rst.Bookmark = Bk Rst.FindNext"Menu_Parent=" & Mid(nodBoss.Key, 2)Loop ExitAddChildren: ExitSub ErrAddChildren: Bulle "Chargement rubrique", "Erreur chargement", "", ""Resume ExitAddChildren EndSub Je souhaite adapter ce code à une autre table. Mon problème c'est que je ne comprends pas pourquoi le code n'est pas compatible avec des champs au format texte (en ce qui concerne les clés Péres et fils). Il n'accepte que le type numérique. En espérant que ce soit plus clair pour vous. Merci.

clemasson · Answer

Oups voici le code :

Sub Charger()
  '    On Error GoTo Err_Charger
      Dim NodCurrent As Node
      Dim StrText AsString
      Dim NodRoot As Node
      Dim Bk AsString
      Set Db = CurrentDb
      Set Rs = Db.OpenRecordset("Menus", dbOpenDynaset, dbReadOnly)
      Set Menu = Me.Xtree.Object
      Menu.Nodes.Clear
      Rs.FindFirst"Menu_Parent Is Null Or Menu_Parent = 0"  ' Cherche le premier pere
      DoUntil Rs.NoMatch
         StrText = Rs!Menu_Libelle
         Set NodCurrent = Menu.Nodes.Add(, , "a" & Rs!ID_Menu, StrText)' Ajoute une branche père
         Bk = Rs.Bookmark     ' mémorise la place
         AddChildren NodCurrent, Rs   ' Lance une proc recursive pour trouver les fils
         Rs.Bookmark = Bk        ' Retourne à sa place
         Rs.FindNext"Menu_Parent Is Null Or Menu_Parent = 0"  ' suite de la recherche
      Loop
      Menu.Sorted = True
    Bulle "Sélectionnez votre formulaire ou votre état.", "cliquez sur :", "+ pour étendre", "- pour réduire"
Exit_Charger:
    ExitSub
Err_Charger:
    Bulle "Chargement rubrique", "Erreur chargement", Rs("Menu_Libelle"), ""
    Resume Exit_Charger
EndSub
 
Sub AddChildren(nodBoss As Node, Rst As DAO.Recordset)
      OnErrorGoTo ErrAddChildren
      Dim NodCurrent As Node
      Dim objTree As TreeView, StrText AsString, Bk AsString
      Dim HeyBoss
      Set objTree = Me!Xtree.Object
      ' ** Cherche le premier fils, le No est dans la clé du boss
      Rst.FindFirst"Menu_Parent =" & Mid(nodBoss.Key, 2)
      DoUntil Rst.NoMatch
         StrText = Rst("Menu_Libelle")
         ' Ajoute le premier fils
         Set NodCurrent = objTree.Nodes.Add(nodBoss, tvwChild, "a" & Rst("ID_Menu"), StrText)
         Bk = Rst.Bookmark
         ' on vérifie si ce fils est lui méme pére
         AddChildren NodCurrent, Rst
         Rst.Bookmark = Bk
         Rst.FindNext"Menu_Parent=" & Mid(nodBoss.Key, 2)
      Loop
ExitAddChildren:
         ExitSub
ErrAddChildren:
        Bulle "Chargement rubrique", "Erreur chargement", "", ""
         Resume ExitAddChildren
      EndSub

clemasson · Answer

pour ceux que ça intéresse :

C'était dû à une erreur classique (gestion du texte # du numérique). 



Sub Charger1()


                    '''''''''''''''''''''''''''''
                   '  1ER Treeview : Equipement  '
                    '''''''''''''''''''''''''''''
                    
      On Error GoTo Err_Charger1
      Dim NodCurrent1 As Node
      Dim StrText1 As String
      Dim NodRoot1 As Node
      Dim Bk1 As String
      Set Db = CurrentDb
      Set Rs1 = Db.OpenRecordset("Equipement", dbOpenDynaset, dbReadOnly)
      Set Menu1 = Me.Xtree1.Object
      Menu1.Nodes.Clear
      Dim strPere1 As String
      strPere1 = "EQP1NIV"
      Rs1.FindFirst "Menu_Parent = '" & strPere1 & "'" ' Cherche le premier pere


      Do Until Rs1.NoMatch
         StrText1 = Rs1!Menu_Libelle
         Set NodCurrent1 = Menu1.Nodes.Add(, , "a" & Rs1!ID_Menu, StrText1) ' Ajoute une branche père
         Bk1 = Rs1.Bookmark     ' mémorise la place
         AddChildren1 NodCurrent1, Rs1   ' Lance une proc recursive pour trouver les fils
         Rs1.Bookmark = Bk1        ' Retourne à sa place
         Rs1.FindNext "Menu_Parent = '" & strPere1 & "'"  ' suite de la recherche
      Loop
      Menu1.Sorted = True
Exit_Charger1:
        Exit Sub
Err_Charger1:
    Resume Exit_Charger1
    
End Sub

Adaptation Code Treeview

2 réponses

Votre réponse

Discussions similaires