Программирование на Visual Basic

Данный пример показывает как можно использовать элемент 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