Discussion :

[Jordmund]

Bonjour,

Est il possible sous Access de faire un Drag & Drop entre 2 items de mon Treeview ?

Je sais que c'est possible sous VB, mais qu'en est il sous Access ?

Merci d'avance de vos réponses.

[Maxence HUBICHE]

oui, ca marche

puisque VB = VBA quant au langage

[Jordmund]

J'ai récupéré du code mais je n'arrive pas à l'intégrer dans mon projet.

Ce sont des fichiers
-> .frm .frx .vbp .vbw

Je pense qu'il n'est pas possible d'intégrer ces fichiers car ca doit être du VB6 et pas du VBA. A moins que je me trompe...

Je n'ai pas trouvé de sources drag & drop dans la FAQ. Peux tu me donner les liens, si tu les connais ?

[Maxence HUBICHE]

exact !
c'est bien ton souci.
Mais tous ces fichiers s'ouvrent avec le notepad

Donne-moi quelques instants.
J'ai fait un code de ce type il y a quelques temps...
Je te fournis les sources dès que je peux (pas tout de suite quand même : pas sur ce PC).

[Maxence HUBICHE]

retrouvé !!!

Voici le code (brut de fonderie).
Tu n'as plus qu'à adapter

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
Option Compare Database
Option Explicit
Private m_objMenu   As clsMenuPrincipal
Private m_objTool   As clsTools
Private m_strNodKey As String
Const conTableMenu  As String = "tblz_CC"
Const conTableCC    As String = "tblCentreDeCouts"
Private Sub cmdExportExcel_Click()
    Dim strpath     As String
    strpath = m_objTool.ExportXLTEMP(xpxlType_CentreDeCouts, "qryExportXL_CC")
    Shell "Excel.exe """ & strpath & """", vbMaximizedFocus
End Sub
Private Sub cmdRefresh_Click()
    DoCmd.RunCommand acCmdSaveRecord
    DrawNodes
End Sub
Private Sub Form_Open(Cancel As Integer)
    Set m_objTool = New clsTools
    Set m_objMenu = New clsMenuPrincipal
    m_objMenu.FieldName(mhChamp_ID) = "ccID"
    m_objMenu.FieldName(mhChamp_Parent) = "ccFKccID"
    m_objMenu.FieldName(mhChamp_Libelle) = "ccLib"
    m_objMenu.FieldName(mhChamp_IconeON) = 2
    m_objMenu.FieldName(mhChamp_IconeOff) = 1
    m_objMenu.FieldName(mhChamp_Formulaire) = "ccFKpersID"
    m_objMenu.FieldName(mhChamp_Parametre) = "ccDir"
 
    DrawNodes
End Sub
Private Function DrawNodes(Optional SKey As String = "")
    tvw.Nodes.Clear
    DoCmd.SetWarnings False
    DoCmd.RunSQL "SELECT * INTO tblz_CC FROM tblCentreDeCouts WHERE ccFKdirID='SDM'"
    DoCmd.SetWarnings True
    tvw.Nodes.Add , , "SDM", "SDM", 1, 2
    m_objMenu.Remplir tvw, conTableMenu, mhTypeSrc_Table, "SDM"
 
    DoCmd.SetWarnings False
    DoCmd.RunSQL "SELECT * INTO tblz_CC FROM tblCentreDeCouts WHERE ccFKdirID='SDV'"
    DoCmd.SetWarnings True
    tvw.Nodes.Add , , "SDV", "SDV", 1, 2
    m_objMenu.Remplir tvw, conTableMenu, mhTypeSrc_Table, "SDV"
 
    'tvw.Object.Extend
    tvw.Object.Nodes("SDV").Expanded = True
    tvw.Object.Nodes("SDM").Expanded = True
    If SKey = "" Then
        'rien à faire
    Else
        tvw.Nodes(SKey).Selected = True
    End If
End Function
 
Private Sub tvw_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Long, ByVal y As Long)
On Error Resume Next
    m_strNodKey = Trim(Mid(tvw.HitTest(x, y).Key, 3))
End Sub
Private Sub tvw_NodeClick(ByVal Node As Object)
    DoCmd.RunCommand acCmdSaveRecord
    m_strNodKey = Trim(Mid(Node.Key, 3))
    Me.Filter = "ccid='" & m_strNodKey & "'"
    Me.FilterOn = True
End Sub
Private Sub tvw_OLEDragDrop(Data As Object, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
 
    On Error GoTo GestErr
    Dim oTree As TreeView
    Dim strKey As String
    Dim nodDropped As Node
    Dim nodDragged As Node
    Dim rs As Recordset
    'Créer la référence à l'objet treeview
    Set oTree = tvw.Object
 
    'Gérer les options de sorties
    If oTree.SelectedItem Is Nothing Then Exit Sub
    If oTree.DropHighlight Is Nothing Then Exit Sub
    'Set nodDragged = oTree.SelectedItem
    Set nodDropped = oTree.DropHighlight
    strKey = Trim(Mid$(nodDropped.Key, 3))
    If m_strNodKey = strKey Then Exit Sub
 
    Set rs = CurrentDb.OpenRecordset("SELECT * FROM [" & conTableCC & "] WHERE ccID ='" & m_strNodKey & "'", dbOpenDynaset)
 
    'Ouvrir la table pour édition, en fonction du destinataire
    If nodDropped.Key Like "SD?" Then
        'Trouver l'enregistrement, et modifier
        With rs
            .Edit
            .Fields("ccFKccID").Value = Null
            .Fields("ccFKdirID").Value = nodDropped.Key
            .Update
        End With
    Else
        'Trouver l'enregistrement, et modifier
        With rs
            .Edit
            .Fields("ccFKccID").Value = strKey
            .Update
        End With
    End If
    Set tvw.Nodes("K_" & m_strNodKey).Parent = nodDropped
    tvw.Sorted = True
'Unhighlight the nodes.
Set oTree.DropHighlight = Nothing
FinProg:
    On Error Resume Next
    Set nodDropped = Nothing
    Exit Sub
GestErr:
    'If you create a circular branch.
    If Err.Number = 35614 Then
        MsgBox "A supervisor cannot report to a subordinate.", _
            vbCritical, "Move Cancelled"
    Else
        MsgBox "Une erreur est survenue lors du transfert." & vbNewLine & "Essayez à nouveau." & vbNewLine & Err.Description
    End If
    Resume FinProg
End Sub
Private Sub tvw_OLEDragOver(Data As Object, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
   Dim oTree As TreeView
    'Create a reference to the TreeView control.
    Set oTree = Me.tvw.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