Treeview avec drag & drop Access 97

Bonjour,

Je n'ai pas chargé la bd de Pierre mais ...
Peut-êre en passant à la propriété Key la concaténation de Id et IdNivSup
.Key= CStr(id) & "x" & CStr(IdNivSup) (ou l'autre sens ) - Voir
éventuellement avec Format() dans le cas d'id > 9 -
L'intégration du 'x' te permettra d'extraire, par la suite sur la key
soit l'Id soit l'IdNivSup en fonction des besoins.

Bonjour à tous...

J'ai trouver cette exemple sur le site de Pierre SALAÜN
(http://access.cfi.free.fr/fichiers.htm) et j'ai trouvé ça assez génial ;-)
!!!
Ma difficulté vient du fait que je tombe en erreur "Key is not unique in
collection" car je souhaiterais avoir une relation du type : un produit = X
composants et sous-composant et une composant ou sous-composant peut
appartenir à plusieurs produits...

Id IdNivSup Designation
1 0 Produit A
2 0 Produit B
3 1 Composant A
4 1 Composant B
3 2 Composant A

Si je rentre les 4 1ères lignes tout va bien mais à la 5ème j'ai l'erreur...

Merci pour votre aide envers un débutant...;-)

@ Bientôt

--
A+
Eric
http://www.mpfa.info/
Archives : http://groups.google.fr/group/microsoft.public.fr.access?hl=fr

Bonjour Eric...

Wahou !!! je t'avoue que c'est qq peu compliqué ce que tu me racontes là !!!
Je n'arrive pas à retrouver dans le code du formulaire ce que tu peux
m'évoquer !
Serait-il possible que tu regarde la db de Pierre et que tu me guide plus
précisemment afin de bien comprendre la démarche...

Merci d'avance.

Bonjour,

Je n'ai pas chargé la bd de Pierre mais ...
Peut-êre en passant à la propriété Key la concaténation de Id et IdNivSup
..Key= CStr(id) & "x" & CStr(IdNivSup) (ou l'autre sens ) - Voir
éventuellement avec Format() dans le cas d'id > 9 -
L'intégration du 'x' te permettra d'extraire, par la suite sur la key
soit l'Id soit l'IdNivSup en fonction des besoins.

Bonjour à tous...

J'ai trouver cette exemple sur le site de Pierre SALAÜN
(http://access.cfi.free.fr/fichiers.htm) et j'ai trouvé ça assez génial ;-)
!!!
Ma difficulté vient du fait que je tombe en erreur "Key is not unique in
collection" car je souhaiterais avoir une relation du type : un produit = X
composants et sous-composant et une composant ou sous-composant peut
appartenir à plusieurs produits...

Id IdNivSup Designation
1 0 Produit A
2 0 Produit B
3 1 Composant A
4 1 Composant B
3 2 Composant A

Si je rentre les 4 1ères lignes tout va bien mais à la 5ème j'ai l'erreur...

Merci pour votre aide envers un débutant...;-)

@ Bientôt

--
A+
Eric
http://www.mpfa.info/
Archives : http://groups.google.fr/group/microsoft.public.fr.access?hl=fr

Hi everybody...

Permettez-moi un tit up ;-)

Bonjour Eric...

Wahou !!! je t'avoue que c'est qq peu compliqué ce que tu me racontes là !!!
Je n'arrive pas à retrouver dans le code du formulaire ce que tu peux
m'évoquer !
Serait-il possible que tu regarde la db de Pierre et que tu me guide plus
précisemment afin de bien comprendre la démarche...

Merci d'avance.

Bonjour,

Je n'ai pas chargé la bd de Pierre mais ...
Peut-êre en passant à la propriété Key la concaténation de Id et IdNivSup
..Key= CStr(id) & "x" & CStr(IdNivSup) (ou l'autre sens ) - Voir
éventuellement avec Format() dans le cas d'id > 9 -
L'intégration du 'x' te permettra d'extraire, par la suite sur la key
soit l'Id soit l'IdNivSup en fonction des besoins.

Bonjour à tous...

J'ai trouver cette exemple sur le site de Pierre SALAÜN
(http://access.cfi.free.fr/fichiers.htm) et j'ai trouvé ça assez génial ;-)
!!!
Ma difficulté vient du fait que je tombe en erreur "Key is not unique in
collection" car je souhaiterais avoir une relation du type : un produit = X
composants et sous-composant et une composant ou sous-composant peut
appartenir à plusieurs produits...

Id IdNivSup Designation
1 0 Produit A
2 0 Produit B
3 1 Composant A
4 1 Composant B
3 2 Composant A

Si je rentre les 4 1ères lignes tout va bien mais à la 5ème j'ai l'erreur...

Merci pour votre aide envers un débutant...;-)

@ Bientôt

--
A+
Eric
http://www.mpfa.info/
Archives : http://groups.google.fr/group/microsoft.public.fr.access?hl=fr

Pour être plus précis voici le type de relation que j'aimerais avoir :
Artcc ArtccNivSup Artcl
1 0 Produit 1
2 0 Produit 2
3 0 Produit 3
4 1 Sous-Produit 4
4 2 Sous-Produit 4
5 1 Sous-Produit 5
6 1 Sous-Produit 6
7 2 Sous-Produit 7
7 3 Sous-Produit 7
8 3 Sous-Produit 8
9 3 Sous-Produit 8
10 7 Sous-Sous-Produit 10
11 8 Sous-Sous-Produit 11

Et voici le code :
Option Compare Database
Option Explicit


Private Const WM_SETREDRAW = &HB

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA"
(ByVal hwnd As Long, ByVal wMsg As _
Long, ByVal wParam As Long, lParam As Any) As Long
Sub SupprNodesTrvw()
Dim x As Integer
Dim oTree, NodeActif As Node
Dim i As Integer

Set oTree = Me.Xtree.Object
oTree.Nodes.Clear
Charger
End Sub
Private Sub Commande2_Click()
Dim oTree, NodeActif As Node
Dim i As Integer

Set oTree = Me.Xtree.Object
SupprNodesTrvw
End Sub
Sub Charger()
On Error GoTo Err_Charger
Dim db As DAO.Database, rst As DAO.Recordset, nodCurrent As Node
Dim objTree, strText As String, nodRoot As Node
Dim bk As String

Set db = CurrentDb

Set rst = db.OpenRecordset("tblNomenclature", dbOpenDynaset, dbReadOnly)
Set objTree = Me.Xtree.Object
objTree.Nodes.Clear
' Cherche le premier pere
rst.FindFirst "ArtccNivSup Is Null Or ArtccNivSup = 0"
Do Until rst.NoMatch
strText = rst("Artcl")
' Ajoute une branche père
Set nodCurrent = objTree.Nodes.Add(, , "a" & rst("Artcc"), strText)
' mémorise la place
bk = rst.Bookmark
' Lance une proc recursive pour trouver les fils
AddChildren nodCurrent, rst
' Retourne à sa place
rst.Bookmark = bk
' suite de la recherche
rst.FindNext "ArtccNivSup Is Null Or ArtccNivSup = 0"
Loop
objTree.Sorted = True
Exit_Charger:
Exit Sub
Err_Charger:
MsgBox Err.Description, vbCritical
Resume Exit_Charger
End Sub
'================================================================= Sub AddChildren(nodBoss As Node, rst As DAO.Recordset)
On Error GoTo ErrAddChildren
Dim nodCurrent As Node
Dim objTree, strText As String, bk As String
Dim HeyBoss
Set objTree = Me!Xtree.Object
' ** Cherche le premier fils, le No est dans la clé du boss
rst.FindFirst "ArtccNivSup =" & Mid(nodBoss.Key, 2)
Do Until rst.NoMatch
'** si commence la boucle, c'est qu'il y a au moins
'** un fils
strText = rst("Artcl")

' Ajoute le premier fils
Set nodCurrent = objTree.Nodes.Add(nodBoss, tvwChild, "a" &
rst("Artcc"), strText)
bk = rst.Bookmark
'** Ici on vérifie si ce fils est lui méme pére

AddChildren nodCurrent, rst

rst.Bookmark = bk
rst.FindNext "ArtccNivSup=" & Mid(nodBoss.Key, 2)
Loop


ExitAddChildren:
Exit Sub
ErrAddChildren:
MsgBox Err.Description, vbCritical
Resume ExitAddChildren
End Sub
Private Sub Détail_Click()

End Sub
Private Sub Form_Load()
Charger
End Sub
Private Sub Xtree_DblClick()
Dim oTree, NodeClic As Node
Set oTree = Me.Xtree.Object
DoCmd.OpenForm "saisie composants", , , "Artcc =" &
Mid(oTree.SelectedItem.Key, 2)
End Sub
Private Sub Xtree_NodeClick(ByVal Node As Object)
Dim oTree, NodeClic As Node
Set oTree = Me!Xtree.Object
' Debug.Print otree.SelectedItem.Index & " index ArtccNivSup " &
otree.SelectedItem.Parent.Index
End Sub
Private Sub Xtree_OLEDragDrop(Data As Object, Effect As Long, Button As
Integer, Shift As Integer, x As Single, y As Single)
On Error GoTo ErrxTree_OLEDragDrop
Dim oTree, strKey As String, strText As String
Dim nodNew As Node, nodDragged As Node
Dim db As DAO.Database, RS As DAO.Recordset
Dim DragTag
Set db = CurrentDb
' Open the Employees table for editing.
Set RS = db.OpenRecordset("tblNomenclature", dbOpenDynaset)
' Create a reference to the TreeView control.
Set oTree = Me!Xtree.Object
' If nothing is selected for drag, do nothing.
If oTree.SelectedItem Is Nothing Then
Else
' Reference the selected node as the one being dragged.
Set nodDragged = oTree.SelectedItem
' If the node was dragged to an empty space, update the Employees
' table and make this employee a root node.
'// DropHighLight donne le texte sur lequel on veut dropper
If oTree.DropHighlight Is Nothing Then
' Save the key and the text to use when you re-add the node.
strKey = nodDragged.Key
strText = nodDragged.Text
' Delete the current node for the employee.
oTree.Nodes.Remove nodDragged.Index
' Locate the record in the Employees table and update it.
RS.FindFirst "[Artcc]=" & Mid(strKey, 2)
RS.Edit
RS("ArtccNivSup") = 0
RS.Update
' Add this employee as a root node.
Set nodNew = oTree.Nodes.Add(, , strKey, strText)
' Add all the child nodes for this employee.
AddChildren nodNew, RS
' If you are not dropping the node on itself.
'Charger
ElseIf nodDragged.Index <> oTree.DropHighlight.Index Then
' Set the drop target as the selected node's parent.
Set nodDragged.Parent = oTree.DropHighlight
' Locate the record in the Employees table and update it.
RS.FindFirst "Artcc=" & Mid(nodDragged.Key, 2)
RS.Edit
RS("ArtccNivSup") = Mid(oTree.DropHighlight.Key, 2)
RS.Update
End If
'Charger
End If
'// mets à jour

Set nodDragged = Nothing
' Unhighlight the nodes.
Set oTree.DropHighlight = Nothing
ExitxTree_OLEDragDrop:
Exit Sub
ErrxTree_OLEDragDrop:
' If you create a circular branch.
If Err.Number = 35614 Then
MsgBox "A supervisor cannot report to a subordinate.", _
vbCritical, "Move Cancelled"
Else
MsgBox "An error occurred while trying to move the node. " & _
"Please try again." & vbCrLf & Error.Description
End If
Resume ExitxTree_OLEDragDrop
End Sub
Private Sub Xtree_OLEDragOver(Data As Object, Effect As Long, Button As
Integer, Shift As Integer, x As Single, y As Single, State As Integer)
Dim oTree
Set oTree = Me!Xtree.Object
' If no node is selected, select the first node you dragged over.
If oTree.SelectedItem Is Nothing Then
Set oTree.SelectedItem = oTree.HitTest(x, y)
End If
' Highlight the node being dragged over as a potential drop target.
Set oTree.DropHighlight = oTree.HitTest(x, y)
End Sub
Private Sub Xtree_OLEStartDrag(Data As Object, AllowedEffects As Long)
Me!Xtree.Object.SelectedItem = Nothing

End Sub

Ma question : Comment éviter le "Key is not unique in collection"

Merci à tous...