Работа с элементом ActiveX Treeview (деревом)

Источник: msadimsign

Иногда без этого элемента не обойтись. Здесь приведен класс по работе с этим элементом.

Собственно, класс. Не путать с обычным модулем.) Назвать модуль класса можете, как хотите, главное не забыть потом правильно к нему обратиться в формах. У меня модуль класса назван "clsTreeClass".
Преимущество данного модуля, что он цепляется на любую таблицу, если она содержит хотя бы три поля (ключ, название, код родителя).

Option Compare Database
' Объявляем класс Tree с событиями
Public WithEvents Tree As TreeView
Public Tbl As String
Public fldParent As String
Public fldKey As String
Public fldText As String
Public createKey As Long

Private Sub Class_Initialize()
'Инициализируем переменные класса для работы с таблицей
'Tbl = "Tbl"
'fldParent = "Parent"
'fldKey = "Key"
'fldText = "Text"
End Sub

' События при управлении левой кнопкой мыши
Private Sub Tree_Click()
' MsgBox Tree.SelectedItem.Key
End Sub

'Добавление основного узла
Public Sub AddBaseNode(Key As String, Text As String)
    idx = Tree.Nodes.Add(, , Key).Index
    With Tree.Nodes(idx)
        .Text = Text
    End With
End Sub

'Добавление дочернего узла
Public Sub AddNode(Parent As String, Key As String, Text As String)
    idx = Tree.Nodes.Add(Parent, tvwChild, Key).Index
    With Tree.Nodes(idx)
        .Text = Text
    End With
End Sub

'Очистка дерева
Public Sub ClearNode()
Tree.Nodes.Clear
End Sub

Public Sub GenerateRecursive(Parent As String)
Dim r As DAO.Recordset
Dim Key As String
Dim Par As String
Dim Text As String
'========================================================================'
'                РЕКУРСИВНАЯ ГЕНЕРАЦИЯ ДЕРЕВА                    '
'========================================================================'
Set r = CurrentDb.OpenRecordset("SELECT * FROM " & Tbl & _
    " WHERE " & fldParent & "=" & Parent & ";", dbOpenDynaset)
If r.EOF And r.BOF Then
Else
    r.MoveFirst
    While Not r.EOF
        Key = "key" & r.Fields(fldKey)
        Par = "key" & r.Fields(fldParent)
        Text = r.Fields(fldText)
        If r.Fields(fldParent) = 0 Then
            AddBaseNode Key, Text
        Else
            AddNode Par, Key, Text
        End If
        GenerateRecursive r.Fields(fldKey)
        r.MoveNext
    Wend
End If
'========================================================================
r.Close
Set r = Nothing
End Sub

'Генерация дерева из таблицы
Public Sub GenerateTree()
Dim r As DAO.Recordset
Dim Key As String
Dim Par As String
Dim Text As String

ClearNode

GenerateRecursive "0"

End Sub

'Получить код элемента
Public Function GetKey() As Long
GetKey = DelKeyStr(Tree.SelectedItem.Key)
End Function

'Удалить префикс
Private Function DelKeyStr(Text As String) As Long
Dim stroka As String
stroka = Right(Text, Len(Text) - 3)
DelKeyStr = CLng(stroka)
End Function

'Добавить ветку
Public Sub AddTblNode(Parent As String, Text As String)
Dim Key As String
Dim Par As String
Dim LastId As Long

CurrentDb.Execute "INSERT INTO " & Tbl & " ( [" & fldText & "], " & fldParent & _
" ) SELECT """ & Text & """ AS Txt, " & DelKeyStr(Parent) & " AS Prn;"
LastId = DMax(fldKey, Tbl, "")

createKey = LastId
Key = "key" & LastId
If DelKeyStr(Parent) = 0 Then
AddBaseNode Key, Text
Else
AddNode Parent, Key, Text
End If
End Sub

'Обновить ветку
Public Sub UpdateTblNode(Key As String, UpdText As String)
CurrentDb.Execute "UPDATE " & Tbl & " SET " & fldText & "=""" & UpdText & """ WHERE " & fldKey & "=" & _
DelKeyStr(Key) & ";"
Tree.Nodes.Item(Key).Text = UpdText
End Sub

'Удалить ветку
Public Sub DelTblNode(Key As String)
CurrentDb.Execute "DELETE * FROM " & Tbl & " WHERE " & fldKey & "=" & _
DelKeyStr(Key) & ";"
Tree.Nodes.Remove Key
End Sub

'Рекурсивное удаление ветки (если есть дочерние и внучатые ветки)
Public Sub RecursiveDelTblNode(Key As String)
Dim r As Recordset

Set r = CurrentDb.OpenRecordset("SELECT * FROM " & Tbl & _
    " WHERE " & fldParent & "=" & DelKeyStr(Key) & ";", dbOpenDynaset)
If r.EOF And r.BOF Then
    CurrentDb.Execute "DELETE * FROM " & Tbl & " WHERE " & _
        fldKey & "=" & DelKeyStr(Key) & ";"
    Tree.Nodes.Remove Key
Else
    r.MoveFirst
    While Not r.EOF
        RecursiveDelTblNode "key" & r.Fields(fldKey)
        r.MoveNext
    Wend
    CurrentDb.Execute "DELETE * FROM " & Tbl & " WHERE " & _
        fldKey & "=" & DelKeyStr(Key) & ";"
    Tree.Nodes.Remove Key
End If

r.Close
Set r = Nothing
End Sub

Теперь в самой форме, где добавлен элемент, в загрузку поместим инициализацию класса. Еще добавим невидимое поле, в которое будем пихать текущий код элемента в дереве.

Private Sub Form_Load()
Set tr = New clsTreeClass
Set tr.Tree = Me.TrView.Object
tr.Tbl = "baseCats"
tr.fldKey = "idCat"
tr.fldParent = "idParentCat"
tr.fldText = "nmCat"
tr.GenerateTree
End Sub

Private Sub TrView_Click()
Me.Key = tr.GetKey
End Sub

Здесь присутствует необходимый минимум. Думается, сделать остальное будет уже не так сложно.