Данный пример показывает как можно использовать элемент TreeView в Microsoft Access. Не забудьте подключить в новых файлах C:\Windows\System32\mscomctl.ocx
Public WithEvents myTV As MicrosoftTree
' Управление Microsoft TreeView c демонстрацией событий
Private Sub butCreate_Click()
If myTV Is Nothing Then
' Создание объекта
Set myTV = New MicrosoftTree
Set myTV.Tree = Me.myTree.Object
' Загружаем узлы дерева
myTV.Load "SELECT * FROM [TableTreeView] Order By [Index]"
End If
End Sub
' Добавим событие-сообщение для нового класса
Public Sub myTV_Progress(myMsg As String)
If Me.butEvents Then
Me.myEvents = myMsg vbNewLine Me.myEvents
DoEvents
End If
End Sub
Private Sub myTree_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Long, ByVal y As Long)
myTV_Progress "MouseDown"
myTV.MouseDown Button, Shift, x, y
End Sub
Private Sub butEvents_AfterUpdate()
Me.myEvents = ""
End Sub
' Освобождение ресурса
Private Sub Form_Close()
Set myTV = Nothing
End Sub
' ------------ Класс -----------
'==============================================================
' Переменные и события
' Объявляем класс Tree
Public WithEvents Tree As TreeView
' Объявляем событие для сообщений
Public Event progress(strMsg As String)
' Переменные для перемещения
Private Type DropDrag
idxStart As Long ' Начальный узел перемещения
idxEnd As Long ' Конечный узел перемещения
End Type
Private drag As DropDrag ' Переменная перемещения
'==============================================================
' События при создании/уничтожении класса
Private Sub Class_Initialize()
' Инициализация
'funPrintEvent "Class_Initialize"
End Sub
Private Sub Class_Terminate()
' Сохраняем данные
'funPrintEvent "Class_Terminate"
End Sub
'==============================================================
' События до/после редактирования метки узла
Private Sub Tree_BeforeLabelEdit(Cancel As Integer)
funPrintEvent "BeforeLabelEdit"
End Sub
Private Sub Tree_AfterLabelEdit(Cancel As Integer, NewString As String)
funPrintEvent "AfterLabelEdit: " NewString
Me.Tree.SelectedItem.ForeColor = 255
End Sub
'==============================================================
' События при работе с узлами дерева
Private Sub Tree_NodeClick(ByVal node As node)
funPrintEvent "NodeClick: " node.Text
End Sub
Private Sub Tree_NodeCheck(ByVal node As node)
funPrintEvent "NodeCheck: " node.Text
End Sub
Private Sub Tree_Expand(ByVal node As node)
funPrintEvent "Expand: " node.Text
End Sub
Private Sub Tree_Collapse(ByVal node As node)
funPrintEvent "Collapse: " node.Text
End Sub
'==============================================================
' События при управлении левой кнопкой мыши
Private Sub Tree_Click()
funPrintEvent "Click"
End Sub
Private Sub Tree_DblClick()
funPrintEvent "DblClick"
End Sub
'==============================================================
' События клавиатуры
Private Sub Tree_KeyUp(KeyCode As Integer, ByVal Shift As Integer)
funPrintEvent "KeyUp (KeyCode: " KeyCode ", Shift = " Shift ")"
End Sub
Private Sub Tree_KeyDown(KeyCode As Integer, ByVal Shift As Integer)
funPrintEvent "KeyDown (KeyCode: " KeyCode ", Shift = " Shift ")"
End Sub
Private Sub Tree_KeyPress(KeyAscii As Integer)
funPrintEvent "KeyPress: " KeyAscii
End Sub
'==============================================================
' События для перемещения типа DragDrop. Возможны только при
' настройках TreeView. Например,
' .OLEDragMode = ccOLEDragAutomatic
' .OLEDropMode = ccOLEDropManual
' Событие. Начало перемещения.
Private Sub Tree_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
' AllowedEffects = ccOLEDropEffectCopy ' Доступные режимы
funPrintEvent "OLEStartDrag"
Set Me.Tree.DropHighlight = Nothing ' Освобождение ресурса
drag.idxEnd = -1 ' Освобождение позиции
End Sub
' Событие. Изменение координат мыши x и y.
' Для определения текущего узла используем: DropHighlight, HitTest(X, y)
Private Sub Tree_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
funPrintEvent "OLEDragOver: x=" x ", y=" y
With Me.Tree
Set .DropHighlight = .HitTest(x, y)
End With
End Sub
' Событие - Срабатывает после OLEDragOver
Private Sub Tree_OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
funPrintEvent "OLEGiveFeedback: Effect=" Effect ", defaultCursors=" DefaultCursors
End Sub
' Событие. Последние событие до завершения перемещения.
Private Sub Tree_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
With Me.Tree
Set .DropHighlight = .HitTest(x, y) ' Узел завершения
funPrintEvent "OLEDragDrop: " Nz(.HitTest(x, y))
If Not .DropHighlight Is Nothing Then
drag.idxEnd = .HitTest(x, y).Index
End If
End With
End Sub
' Событие. Завершение перемещения
' Для определения действий с узлами использем DropHighlight и SelectedItem
Private Sub Tree_OLECompleteDrag(Effect As Long)
Dim strKey As String
'Me.Tree.MousePointer = ccArrow
With Me.Tree
Set .DropHighlight = Nothing ' Освобождаем объект
If (drag.idxStart = -1) Or _
(drag.idxEnd = -1) Or _
(drag.idxStart = drag.idxEnd) Then
funPrintEvent "OLECompleteDrag: None"
Else
funPrintEvent "OLECompleteDrag: " .Nodes(drag.idxStart).Text " - " .Nodes(drag.idxEnd).Text
' Функция обработки операции DragDrop
strKey = "la_" Time
' Добавляем узел красного цвета
Set .SelectedItem = .Nodes.Add(.Nodes(drag.idxEnd).Key, tvwChild, strKey, "Новый узел")
.SelectedItem.ForeColor = 255
End If
End With
End Sub
' Событие. Установка данных
Private Sub Tree_OLESetData(Data As DataObject, DataFormat As Integer)
funPrintEvent "OLESetData"
End Sub
' Событие. Обработка нажатия клавиши
Public Sub MouseDown(Button As Integer, Shift As Integer, x As Long, y As Long)
With Me.Tree
If .HitTest(x, y) Is Nothing Then
drag.idxStart = -1
Else
Set .SelectedItem = .HitTest(x, y)
drag.idxStart = .SelectedItem.Index
End If
End With
If Button = acLeftButton Then
drag.idxEnd = -1 ' Индекс последнего элемента не известен
End If
End Sub
'==============================================================
' Собственные свойства класса
Public Function Load(strSQL As String) As Boolean
Dim myУзел As String, myКлюч As String, idx As Long
Dim rst As ADODB.Recordset
On Error GoTo 999
' Загрузка дерева
Set rst = New ADODB.Recordset
rst.Open strSQL, Application.CurrentProject.Connection
Me.Tree.Nodes.Clear
Do Until rst.EOF
' Создание узла и его ключей
myУзел = "la_" rst!Relative
myКлюч = "la_" rst!Key
If Not IsNull(rst!Relative) Then
idx = Me.Tree.Nodes.Add(myУзел, tvwChild, myКлюч).Index
Else
idx = Me.Tree.Nodes.Add(, , myКлюч).Index
End If
' Изменение нового узла
With Me.Tree.Nodes(idx)
.Text = Nz(rst!Text)
.Selected = True
End With
rst.MoveNext
Loop
' Настраиваем класс
With Me.Tree
' Разрешаем операцию DragDrop
.OLEDragMode = ccOLEDragAutomatic
.OLEDropMode = ccOLEDropManual
' Настраиваем дерево
.Style = tvwTreelinesPlusMinusText ' Общий вид дерева
.LineStyle = tvwRootLines ' Использование корневого узла
.Indentation = 300 ' Длина штриха узла
.Checkboxes = True ' Показываем флажки
End With
Load = True
998:
rst.Close
Set rst = Nothing
Err.Clear
Exit Function
999:
Load = False
MsgBox Err.Description
On Error Resume Next
Resume 998
End Function
'==============================================================
' Функция сообщающая о получении событий
Private Function funPrintEvent(myMsg As String)
RaiseEvent progress(myMsg) ' Генерируем событие для узла
End Function