Option Explicit
'=========================
Private Const c_strModule As String = "clsTreeRecordset"
'=========================
' Описание      : Переходы в иерархических запросах
' Версия        : 1.1.5.436486368
' Дата          : 02.07.2019 15:17:00
' Автор         : Кашкин Р.В. (KashRus@gmail.com)
' Примечания    : Очень медленно и неэффективно - надо полностью переписать. _
'                 Имена полей и сортировку необходимо задавать до указания источника данных
' v.1.1.5       : 11.12.2017 -
' v.1.0.0       : 10.11.2017 - исходная версия
'=========================
'Основные свойства и методы:
'-------------------------
'Recordset - объект запрос - источник записей дерева
'KeyName/ParentName - имя ключевого поля/имя поля родительской записи рекордсета по которым осуществляется связь записей
'Parents/Childs/Siblings - объекты запрос - содержащие соответственно родительские/подчиненные/соседние записи(узлы) текущей записи
'Key/Parent - код текущей/родительской вершины (записи) (значение поля KeyName соответствующей записи)
'Level - уровень текущей вершины (записи) в дереве записей
'MovePrev/MoveNext - перходы к первой/последней записям. в зависимости от параметра - внутри уровня либо с заходом
'MoveFirst/MoveLast - перходы между записями. в зависимости от параметра - внутри уровня либо с заходом
'MoveUp/MoveDown - переходы к родительской/подчинённой записям

'ShowAllParents = True - выводит все родительские записи по восходящей, а не только те, что отвечают условиям фильтра
'               = False - выводит только те родительские вершины, что отвечают условиям фильтра
'ShowRoot       = True - включает корневую вершину (при наличиии) в список доступных,
'               = False - корневая вершина отстутствует среди узлов дерева

Private Const c_colPref = "i"
Private Const c_strName = "NAME" ' имя текстового поля по-умолчанию
Private mstrKeyFieldName As String
Private mstrParFieldName As String

Private m_daoSource As DAO.Recordset
Private m_daoRecordset As DAO.Recordset
Private m_daoParents As DAO.Recordset
Private m_daoSiblings As DAO.Recordset
Private m_daoChilds As DAO.Recordset
Private m_lngLevel As Long
Private m_lngChilds As Long
Private m_lngKey As Long
Private m_varRootKey As Variant
Private m_lngParent As Long

Private m_strRecordSource As String
Private m_strFilter As String, m_strRealFilter As String, m_strRootFilter As String
Private m_strOrderBy As String

Private m_bolAllParents As Boolean
Private m_bolShowRoot As Boolean
Private m_bolNoMatch As Boolean

Private Sub Class_Initialize()
    m_bolAllParents = True
    m_bolShowRoot = True
    m_bolNoMatch = False
    mstrKeyFieldName = c_strKey
    mstrParFieldName = c_strParent
End Sub
Private Sub Class_Terminate()
    Set m_daoSource = Nothing
    Set m_daoRecordset = Nothing
    Set m_daoParents = Nothing
    Set m_daoSiblings = Nothing
    Set m_daoChilds = Nothing
End Sub
Public Property Get ShowRoot() As Boolean: ShowRoot = m_bolShowRoot: End Property
Public Property Let ShowRoot(ByVal bolNewValue As Boolean)
    m_bolShowRoot = bolNewValue
    If Not m_daoSource Is Nothing Then
        p_SetFilter             ' пользуемся средствами дерева для отбора нужных вершин дерева
        p_InitRecordsets (Key)  ' инициализируем дерево только с нужными вершинами
    End If
'    MoveFirst
End Property
Public Property Get ShowAllParents() As Boolean: ShowAllParents = m_bolAllParents: End Property
Public Property Let ShowAllParents(ByVal bolNewValue As Boolean)
    m_bolAllParents = bolNewValue
    If Not m_daoSource Is Nothing Then
        m_strRealFilter = p_GetRealFilter()
        p_SetFilter             ' пользуемся средствами дерева для отбора нужных вершин дерева
        p_InitRecordsets (Key)  ' инициализируем дерево только с нужными вершинами
    End If
End Property
Public Function GetPath( _
    Optional NodeKey, _
    Optional FieldName As String = c_strName, _
    Optional Delim As String = "\", _
    Optional ShowRoot As Boolean = False, _
    Optional ShowCurrent As Boolean = True _
    ) As String
' возвращает строку пути до указанной вершины отверхней родительской
Const c_strProcedure = "GetPath"
' NodeKey - вершина для которой строится путь
' FieldName - имя поля запроса значения которого будут указаны в качестве обозначения вершин пути
' Delim - разделитель вершин в итоговой строке
' ShowRoot - включать в путь верхнюю корневую вершину (Key = 0)
Dim bRet As Boolean
Dim lKey As Long, cPar As Collection, i As Long
Dim Result As String

    Result = vbNullString
    On Error GoTo HandleError
    If IsMissing(NodeKey) Then
        lKey = m_daoRecordset.Fields(mstrKeyFieldName)
    Else
        lKey = CLng(NodeKey)
    End If
    bRet = p_GetUpwardNodes(lKey, cPar, FieldName, ShowRoot, ShowCurrent)
    If bRet Then
        With cPar
            i = .Count
            Do Until i = 0
                Result = Result & Delim & cPar(i)
                i = i - 1
            Loop
        End With
    End If
    Result = Mid$(Result, Len(Delim) + 1)
HandleExit:
    GetPath = Result
    Exit Function
HandleError:
    Result = vbNullString
    Err.Clear
    Resume HandleExit
End Function
Public Function FieldExists(FieldName As String) As Boolean
' проверяет наличие поля в таблице источнике
' при отсутствии mstrTypField невозможно присвоить иконку
' при отсутствии mstrNumField невозможно упорядочивать записи вручную
Dim Result As Boolean
    On Error GoTo NotInRecordset
    Result = False
    If FieldName = vbNullString Then GoTo HandleExit
    ' проверяем существует ли такое поле
    With m_daoSource.Fields(FieldName)
        Result = .NAME = .NAME
    End With
    GoTo HandleExit
NotInRecordset:    ' если нет
    Err.Clear
HandleExit:
    FieldExists = Result
End Function
Public Property Get NoMatch() As Boolean: NoMatch = m_bolNoMatch: End Property
Public Property Get RecordSource() As String: RecordSource = m_strRecordSource: End Property
Public Property Let RecordSource(rData As String)
' открываем источник
'    Dim rst As DAO.Recordset
'    Set rst = CurrentDb.OpenRecordset(rData, dbOpenSnapshot): rst.MoveLast 'App.AppData.OpenRecordset(rData, dbOpenSnapshot): rst.MoveLast
    Set Me.Recordset = CurrentDb.OpenRecordset(rData, dbOpenSnapshot)
End Property
Public Property Get Recordset() As DAO.Recordset: Set Recordset = m_daoRecordset: End Property ' recordset по записям которого осуществляется переход
Public Property Set Recordset(ByVal objNewValue As DAO.Recordset)
' открываем источник
    Set m_daoSource = objNewValue:  m_strRecordSource = objNewValue.NAME
    Set m_daoRecordset = m_daoSource.OpenRecordset: m_daoRecordset.MoveLast
' инициализируем запросы исходного дерева
    p_InitRecordsets   ' инициализируем ВСЁ дерево (плохо!)
    MoveFirst          ' переходим к первому узлу дерева
    If IsEmpty(m_varRootKey) Then m_varRootKey = Me.Parent  ' в исходного качестве корня берём верхний узел исходного дерева
' готовим фильтры вершин дерева
    m_strRootFilter = p_GetRootFilter() ' фильтр по корневой вершине
    m_strRealFilter = p_GetRealFilter() ' произвольный фильтр
    p_SetFilter        ' пользуемся средствами дерева для отбора нужных вершин дерева
' инициализируем дерево с учётом фильтров
    p_InitRecordsets   ' инициализируем дерево только с нужными вершинами
    MoveFirst          ' переходим к первому узлу дерева
End Property
Public Property Get RootKey(): RootKey = m_varRootKey: End Property
Public Property Let RootKey(lKey)
' устанавливаем код корневого узла
Const c_strProcedure = "RootKey"
    On Error GoTo HandleError
    If IsNumeric(lKey) Then m_varRootKey = CLng(lKey) Else m_varRootKey = Null
    If Not m_daoSource Is Nothing Then
        m_strRootFilter = p_GetRootFilter()
        p_SetFilter             ' пользуемся средствами дерева для отбора нужных вершин дерева
        p_InitRecordsets (Key)  ' инициализируем дерево только с нужными вершинами
    End If
'    MoveFirst
HandleExit:
    Exit Property
HandleError:
    Err.Clear
    Resume HandleExit
End Property
Public Property Let Key(lKey As Long)
' переход к вершине с указаным кодом
Const c_strProcedure = "Key"
Dim Result As Boolean

    Result = False
    On Error GoTo HandleError
    m_bolNoMatch = m_daoRecordset.Fields(mstrKeyFieldName) <> lKey
    If m_bolNoMatch Then m_bolNoMatch = Not p_InitRecordsets(lKey)
    
HandleExit:
    Exit Property
HandleError:
    Result = False
    Resume HandleExit
End Property
Public Property Get Key() As Long
' возвращает код текущей вершины
    'mlngKey = m_daoRecordset.Fields(mstrKeyFieldName)
    Key = m_daoRecordset.Fields(mstrKeyFieldName) 'mlngKey
End Property
Public Property Get Parent() As Long
' код родителя текущей вершины
    'mlngPar = m_daoRecordset.Fields(mstrParFieldName)
    Parent = m_daoRecordset.Fields(mstrParFieldName) 'mlngPar
End Property

Public Property Get KeyName() As String: KeyName = mstrKeyFieldName: End Property ' имя ключевого поля рекордсета
Public Property Let KeyName(rData As String): mstrKeyFieldName = rData: End Property
Public Property Get ParentName() As String: ParentName = mstrParFieldName: End Property ' имя поля родительской записи рекордсета
Public Property Let ParentName(rData As String): mstrParFieldName = rData: End Property
Public Property Get Childs() As DAO.Recordset: Set Childs = m_daoChilds: End Property
Public Property Get Parents() As DAO.Recordset: Set Parents = m_daoParents: End Property
Public Property Get Siblings() As DAO.Recordset: Set Siblings = m_daoSiblings: End Property
Public Property Get ChildsCount() As Long
    If m_daoChilds Is Nothing Then ChildsCount = 0 Else ChildsCount = m_daoChilds.RecordCount
End Property
Public Property Get ParentsCount() As Long
    If m_daoParents Is Nothing Then ParentsCount = 0 Else ParentsCount = m_daoParents.RecordCount
End Property
Public Property Get SiblingsCount() As Long
    If m_daoSiblings Is Nothing Then SiblingsCount = 0 Else SiblingsCount = m_daoSiblings.RecordCount
End Property
Public Property Get HasParents() As Boolean
' есть родители
    If Me.Parent = Me.Key Then
    ' вырожденный случай - вершина указана собственным родителем
        HasParents = False
    ElseIf Me.Key = m_varRootKey Then
        HasParents = False
    ElseIf m_daoParents Is Nothing Then
        HasParents = False
    Else
        HasParents = m_daoParents.RecordCount > 0
    End If
End Property
Public Property Get HasChilds() As Boolean
' есть подчинённые
    If m_daoChilds Is Nothing Then HasChilds = False Else HasChilds = m_daoChilds.RecordCount > 0
End Property
Public Property Get HasLeftSibling() As Boolean
' есть сосед слева
    If m_daoSiblings Is Nothing Then
        HasLeftSibling = False
    ElseIf m_daoSiblings.BOF Then
        HasLeftSibling = False
    ElseIf m_daoSiblings.AbsolutePosition = 0 Then
        HasLeftSibling = False
    Else
        HasLeftSibling = True
    End If
End Property
Public Property Get HasRightSibling() As Boolean
' есть сосед справа
    If m_daoSiblings Is Nothing Then
        HasRightSibling = False
    ElseIf m_daoSiblings.EOF Then
        HasRightSibling = False
    ElseIf m_daoSiblings.AbsolutePosition = m_daoSiblings.RecordCount - 1 Then
        HasRightSibling = False
    Else
        HasRightSibling = True
    End If
End Property
Public Property Get Level() As Long: Level = m_lngLevel: End Property ' уровень текущего узла в дереве

Public Function MoveUp() As Boolean
' переход к родителю
Const c_strProcedure = "MoveUp"
Dim Result As Boolean

    Result = False
    On Error GoTo HandleError
    If HasParents Then
    ' если есть родитель - переход вверх на один уровень (к родительскому узлу)
        ' родственные узлы становятся подчинёнными
        Set m_daoChilds = m_daoSiblings ': m_daoChilds.Bookmark = m_daoSiblings.Bookmark
        ' родительские узлы становятся родственными
        Set m_daoSiblings = m_daoParents ': m_daoSiblings.Bookmark = m_daoParents.Bookmark
        ' открываем родительские узлы для текущего
        Set m_daoParents = m_daoRecordset.Clone ': m_daoParents.Bookmark = m_daoRecordset.Bookmark
        Result = p_GotoRecord(m_daoParents, m_daoSiblings.Fields(mstrParFieldName))
        If Result Then
            Set m_daoParents = p_GetSiblings(m_daoParents.Fields(mstrParFieldName))
            Result = p_GotoRecord(m_daoParents, m_daoSiblings.Fields(mstrParFieldName))
        Else
            Set m_daoParents = Nothing
        End If
        ' переходим в основном запросе к родительской записи
        Result = p_GotoRecord(m_daoRecordset, m_daoSiblings.Fields(mstrKeyFieldName))
        ' изменяем уровень
        m_lngLevel = m_lngLevel - 1
        'If Not Result Then GoTo HandleExit
    Else
    ' тупик - некуда переходить
        Result = False
    End If
    
HandleExit:
    MoveUp = Result
    Exit Function
HandleError:
    Result = False
    Err.Clear
    Resume HandleExit
End Function
Public Function MoveFirst() As Boolean
Const c_strProcedure = "MoveFirst"
Dim Result As Boolean

    Result = False
    On Error GoTo HandleError
'    m_daoRecordset.MoveFirst:p_InitRecordsets
    Do While HasParents Or HasLeftSibling: MovePrev: Loop
    ' определяем уровень текущей записи
    Result = p_GetLevel
    Result = True
HandleExit:
    MoveFirst = Result
    Exit Function
HandleError:
    Result = False
    Resume HandleExit
End Function

Public Function MoveLast(Optional OnCurLevel As Boolean = False) As Boolean
Const c_strProcedure = "MoveLast"
Dim Result As Boolean

    Result = False
    On Error GoTo HandleError
    If OnCurLevel Then
        m_daoSiblings.MoveLast  ' переходим к последнему на текущем уровне
    Else
        Do While MoveUp: Loop   ' поднимаемся на самый верх
        m_daoSiblings.MoveLast  ' переходим к последнему на верхнем уровне
        Do While MoveDown(True): Loop   ' спускаемся вниз к последнему на нижнем уровне
    End If
    ' определяем уровень текущей записи
    Result = p_GetLevel
    Result = True
HandleExit:
    MoveLast = Result
    Exit Function
HandleError:
    Result = False
    Err.Clear
    Resume HandleExit
End Function

Public Function MoveDown(Optional GotoLast As Boolean = False) As Boolean
' переход к первому подчинённому если GotoLast=False
' или последнему подчинённому если GotoLast=True
Const c_strProcedure = "MoveDown"
Dim Result As Boolean

    Result = False
    On Error GoTo HandleError
    If HasChilds Then
    ' если есть подчинённые
    ' переход вниз на один уровень
        ' родственные узлы становятся родительскими
        Set m_daoParents = m_daoSiblings ': m_daoParents.Bookmark = m_daoSiblings.Bookmark
        ' подчинённые узлы становятся родственными
        Set m_daoSiblings = m_daoChilds ': m_daoSiblings.Bookmark = m_daoChilds.Bookmark
        If GotoLast Then
            m_daoSiblings.MoveLast ' переход к последнему подчинённому
        Else
            m_daoSiblings.MoveFirst ' переход к первому подчинённому
        End If
        ' переходим в основном запросе к родительской записи
        Result = p_GotoRecord(m_daoRecordset, m_daoSiblings.Fields(mstrKeyFieldName))
        ' открываем подчинённые узлы для текущего
        Set m_daoChilds = p_GetSiblings(m_daoSiblings.Fields(mstrKeyFieldName))
        If Not Result Then GoTo HandleExit
        m_lngLevel = m_lngLevel + 1
    Else
    ' тупик - некуда переходить
        Result = False
    End If
HandleExit:
    MoveDown = Result
    Exit Function
HandleError:
    Result = False
    Err.Clear
    Resume HandleExit
End Function
Public Function MovePrev(Optional StepInto As Boolean = True) As Boolean
' переход к предыдущей
Const c_strProcedure = "MovePrev"
Dim Result As Boolean

    Result = False
    On Error GoTo HandleError
' производим смещение относительно текущей позиции
    If HasLeftSibling Then
    ' если есть сосед слева
        m_daoSiblings.MovePrevious ' переход к соседу слева
        Result = p_GotoRecord(m_daoRecordset, m_daoSiblings.Fields(mstrKeyFieldName))
        Set m_daoChilds = p_GetSiblings(Key): If Not m_daoChilds Is Nothing Then m_daoChilds.MoveLast
        If StepInto Then
        ' если движение назад с заходом
        ' пока есть подчинённые - переходим на уровень вниз к последней на уровне
            Do While HasChilds: Result = MoveDown(True): Loop
        End If
    ElseIf HasParents Then
    ' если нет соседа слева, но есть родитель
    ' переход вверх на один уровень (к родительскому узлу)
        Result = MoveUp
    Else
    ' тупик - некуда переходить
    End If
HandleExit:
    MovePrev = Result
    Exit Function
HandleError:
    Result = False
    Err.Clear
    Resume HandleExit
End Function
Public Function MoveNext(Optional StepInto As Boolean = True) As Boolean
' переход к следующей
Const c_strProcedure = "MoveNext"
Dim Result As Boolean

    Result = False
    On Error GoTo HandleError
' производим смещение относительно текущей позиции
    If StepInto And HasChilds Then
    ' если движение вперёд с заходом и есть подчинённые:
        Result = MoveDown ' переход вниз на один уровень (к первому подчинённому узлу)
    ElseIf HasRightSibling Then
    ' если нет подчинённых, но есть сосед справа
        m_daoSiblings.MoveNext ' переход к соседу справа
        Result = p_GotoRecord(m_daoRecordset, m_daoSiblings.Fields(mstrKeyFieldName))
        Set m_daoChilds = p_GetSiblings(Key): If Not m_daoChilds Is Nothing Then m_daoChilds.MoveFirst
    ElseIf HasParents Then
    ' если нет подчинённых, нет соседа справа, но есть родитель
        Result = MoveUp ' переход вверх на один уровень (к родительскому узлу)
        Result = MoveNext(False)  ' рекурсивный переход к следующему узлу (на уровне родительского узла)
    '
    Else
        Result = False ' тупик - некуда переходить
    End If
HandleExit:
    MoveNext = Result
    Exit Function
HandleError:
    Result = False
    Err.Clear
    Resume HandleExit
End Function
Public Sub Init(Optional RootKeyCode)
    p_InitRecordsets
    If Not IsMissing(RootKeyCode) Then Me.RootKey = RootKeyCode
End Sub
Public Property Get Sort() As String: Sort = m_strOrderBy: End Property
Public Property Let Sort(ByVal strNewValue As String)
    If m_strOrderBy = strNewValue Then Exit Property
    m_strOrderBy = strNewValue
    If Not m_daoSource Is Nothing Then
        p_SetFilter             ' пользуемся средствами дерева для отбора нужных вершин дерева
        p_InitRecordsets (Key)  ' инициализируем дерево только с нужными вершинами
    End If
End Property
Public Property Get Filter() As String: Filter = m_strFilter: End Property
Public Property Let Filter(ByVal strNewValue As String)
    If m_strFilter = strNewValue Then Exit Property
    m_strFilter = strNewValue
    If Not m_daoSource Is Nothing Then
        m_strRealFilter = p_GetRealFilter()
        p_SetFilter             ' пользуемся средствами дерева для отбора нужных вершин дерева
        p_InitRecordsets (Key)  ' инициализируем дерево только с нужными вершинами
    End If
End Property
Private Function p_InitRecordsets(Optional GotoKey) As Boolean
' открываембазовые запросы класса
Const c_strProcedure = "p_InitRecordsets"
Dim lKey As Long, lPar As Long
Dim strFilter As String
Dim Result As Boolean
'If GotoKey = 46 Then Stop
    Result = False
    On Error GoTo HandleError
' открываем запросы
    'Set m_daoRecordset = m_daoRecordset.OpenRecordset: m_daoRecordset.MoveLast
    If Not IsMissing(GotoKey) Then p_GotoRecord m_daoRecordset, CLng(GotoKey)
    lKey = m_daoRecordset.Fields(mstrKeyFieldName): lPar = Nz(m_daoRecordset.Fields(mstrParFieldName), 0)
    ' определяем уровень текущей записи
    Result = p_GetLevel
    ' открываем родственные узлы
    Set m_daoSiblings = p_GetSiblings(lPar): If Not m_daoSiblings Is Nothing Then Call p_GotoRecord(m_daoSiblings, lKey)
    ' открываем подчинённые узлы
    Set m_daoChilds = p_GetSiblings(lKey): If Not m_daoChilds Is Nothing Then m_daoChilds.MoveFirst
    ' открываем родительские узлы
    Set m_daoParents = m_daoRecordset.Clone: Result = p_GotoRecord(m_daoParents, lPar)
    If Result Then Set m_daoParents = p_GetSiblings(m_daoParents.Fields(mstrParFieldName)) Else Set m_daoParents = Nothing
    If m_daoParents Is Nothing Then Else Call p_GotoRecord(m_daoParents, lPar)
    Result = True
HandleExit:
    p_InitRecordsets = Result
    Exit Function
HandleError:
    Result = False
    Resume HandleExit
End Function
Private Function p_SetFilter() As Boolean
Const c_strProcedure = "p_SetFilter"
' создаем фильтр записей
Dim bolShowRoot As Boolean
Dim strFilter As String
Dim Result As Boolean
    Result = False
    bolShowRoot = m_bolShowRoot 'And Not IsEmpty(m_varRootKey)
    On Error GoTo HandleError
    If Len(m_strRootFilter) > 0 And Len(m_strRealFilter) > 0 Then
    ' заданы фильтр по корневому узлу и произвольный фильтр
        strFilter = m_strRootFilter & sqlAnd & m_strRealFilter
    ElseIf Len(m_strRootFilter) > 0 Then
    ' задан фильтр по корневому узлу
        strFilter = m_strRootFilter
    ElseIf Len(m_strRealFilter) > 0 Then
    ' задан произвольный фильтр
        strFilter = m_strRealFilter
    Else
        strFilter = vbNullString
    End If
    If Not bolShowRoot And Len(strFilter) > 0 Then
    ' указано не выводить корневой узел и задан фильтр по записям
        strFilter = mstrKeyFieldName & sqlNotEqual & m_varRootKey & sqlAnd & strFilter
    ElseIf bolShowRoot And Len(strFilter) > 0 Then
    ' указано выводить корневой узел и задан фильтр по записям
        strFilter = mstrKeyFieldName & sqlEqual & m_varRootKey & sqlOR & "(" & strFilter & ")"
    ElseIf Not bolShowRoot Then
    ' указано не выводить корневой узел и не задан фильтр по записям
        strFilter = mstrKeyFieldName & sqlNotEqual & m_varRootKey
    Else
    ' указано выводить корневой узел и не задан фильтр по записям
        strFilter = vbNullString
    End If
' применяем фильтр записей и сортировку
    Set m_daoRecordset = m_daoSource.Clone
    With m_daoRecordset
        .Filter = strFilter
        .Sort = m_strOrderBy
    End With
    Set m_daoRecordset = m_daoRecordset.OpenRecordset: m_daoRecordset.MoveLast
    Result = True
HandleExit:
    p_SetFilter = Result
    Exit Function
HandleError:
    Result = False
    Err.Clear
    Resume HandleExit
End Function

Private Function p_GetRootFilter() As String
' создает фильтр по ключу корневого узла, отсекая все узлы для которых указанный не является родителем
Const c_strProcedure = "p_SetRootKey"
Dim strWhere As String, strParent As String, lRootKeyParent 'As Long
Dim Result As Boolean

    Result = False
    On Error GoTo HandleError
    If m_daoRecordset Is Nothing Then Err.Raise vbObjectError + 512
    If IsEmpty(m_varRootKey) Then
        strWhere = vbNullString
        GoTo HandleExit
    ElseIf IsNull(m_varRootKey) Then
         strWhere = vbNullString
        GoTo HandleExit
    End If
' если задан ключ корневого узла - формируем фильтр записей
    ' отбираем все от корневого узла вниз вправо
    ' до следующего узла с тем же родителем что и заданный корневой
    If p_GotoRecord(m_daoSource, CLng(m_varRootKey)) Then
    ' есть корневой узел в запросе
        Me.Key = m_varRootKey ': strKey = rKey
        lRootKeyParent = Me.Parent
    Else
    ' нет корневого узла в запросе
        'Me.MoveFirst
        lRootKeyParent = Null 'm_varRootKey
    End If
    Do While Me.MoveNext
    ' обходим дерево и запоминаем всех родителей
        strParent = Me.Parent
        If strWhere = vbNullString Then
        ' пустая строка фильтра - добавляем
            strWhere = strParent
        ElseIf strWhere = strParent Then
        ' совпадает с единственным элементом строки - пропускаем
        ElseIf Left$(strWhere, Len(strParent & c_strInDelim)) = strParent & c_strInDelim Then
        ' совпадает с первым элементом строки - пропускаем
        ElseIf Right$(strWhere, Len(c_strInDelim & strParent)) = c_strInDelim & strParent Then
        ' совпадает с последним элементом строки - пропускаем
        ElseIf InStr(strWhere, c_strInDelim & strParent & c_strInDelim) Then
        ' совпадает с элементом внутри строки - пропускаем
        Else
        ' отсутствуют совпадения в строке фильтра - добавляем
            strWhere = strWhere & c_strInDelim & strParent
        End If
        
    ' выходим если прошли все узлы подчинённые корневому
        If Me.HasRightSibling Then
        ElseIf Me.Parent = lRootKeyParent Then
            Exit Do
        End If
    Loop
    If Len(strWhere) > 0 Then strWhere = mstrParFieldName & sqlIn & "(" & strWhere & ")"
HandleExit:
    p_GetRootFilter = strWhere
    Exit Function
HandleError:
    Err.Clear
    Resume HandleExit
End Function
Private Function p_GetLevel() As Boolean
' возвращает уровень текущей записи
Const c_strProcedure = "p_GetLevel"
Dim rst As DAO.Recordset
Dim lKey As Long
Dim Result As Boolean

    On Error GoTo HandleError
    Set rst = m_daoRecordset.Clone: rst.Bookmark = m_daoRecordset.Bookmark
    With rst
        If .Fields(mstrKeyFieldName) = m_varRootKey Then
        ' если текущий узел - корневой -
        ' ставим ему уровень 0 и выходим
            m_lngLevel = 0
            Result = True
            GoTo HandleExit
        Else
            m_lngLevel = 1
        End If
        
        Do
            'If IsNull(.Fields(mstrParFieldName)) Then Exit Do
            'lKey = .Fields(mstrParFieldName)
            If p_GotoRecord(rst, .Fields(mstrParFieldName)) Then
                If .Fields(mstrKeyFieldName) = m_varRootKey Then Exit Do
                m_lngLevel = m_lngLevel + 1
            Else
                Exit Do
            End If
        Loop
    End With
    'rst.Close
    Result = True
HandleExit:
    Set rst = Nothing
    p_GetLevel = Result
    Exit Function
HandleError:
    Result = False
    Err.Clear
    Resume HandleExit
End Function
Private Function p_GotoRecord(rst As DAO.Recordset, Key As Long) As Boolean
Const c_strProcedure = "p_GotoRecord"
' переход к указаной записи в указанном запросе
Dim Result As Boolean
    On Error GoTo HandleError
    rst.FindFirst mstrKeyFieldName & sqlEqual & Key
    Result = Not rst.NoMatch
HandleExit:
    p_GotoRecord = Result
    Exit Function
HandleError:
    Result = False
    Err.Clear
    Resume HandleExit
End Function
Private Function p_GetSiblings(Par As Long) As DAO.Recordset
Const c_strProcedure = "p_GetSiblings"
' возвращает запрос с указанным родителем
Dim rst As DAO.Recordset

    Set rst = Nothing
    On Error GoTo HandleError
    Set rst = m_daoRecordset.Clone ': rst.Bookmark = m_daoRecordset.Bookmark
    With rst
        .Filter = mstrParFieldName & sqlEqual & Par
        .Sort = m_strOrderBy 'm_daoSource.Sort
    End With
    Set rst = rst.OpenRecordset: rst.MoveLast
    If rst.EOF And rst.BOF Then Err.Raise vbObjectError + 512
HandleExit:
    Set p_GetSiblings = rst
    Exit Function
HandleError:
    Set rst = Nothing
    Err.Clear
    Resume HandleExit
End Function
Private Function p_GetRealFilter() As String
Const c_strProcedure = "p_GetRealFilter"
' возвращает строку фильтра
' включающую перечень всех родительских узлов по восходящей
' для указанной строки фильтра
Dim cPar As Collection
Dim strFilter As String
Dim Result As Boolean

    strFilter = m_strFilter
    On Error GoTo HandleError
    If Not m_bolAllParents Or Len(m_strFilter) = 0 Then GoTo HandleExit
    If m_daoRecordset Is Nothing Then Err.Raise vbObjectError + 512
Dim rst As DAO.Recordset, lKey As Long
Dim aPar() As Long
' получаем запрос с вершинами отобранными по фильтру
    Set rst = m_daoSource.Clone
    With rst
        .Filter = m_strFilter
        .Sort = m_strOrderBy
    End With
    Set rst = rst.OpenRecordset: rst.MoveLast
' получаем список родительских вершин для каждого узла из отобранных по фильтру
    With rst
        .MoveFirst
        Do Until .EOF
            lKey = rst.Fields(mstrKeyFieldName).Value
            Result = p_GetUpwardNodes(lKey, cPar)  '
            .MoveNext
        Loop
    End With
' объединяем номера вершин из коллекции родителей в строку фильтра
' и добавляем к заданному фильтру
    If cPar.Count > 0 Then
    Dim tmp  As String, lPar
        For Each lPar In cPar: tmp = tmp & c_strInDelim & lPar: Next lPar
        strFilter = "(" & m_strFilter & ")" & sqlOR & _
            mstrKeyFieldName & sqlIn & "(" & Mid$(tmp, Len(c_strInDelim) + 1) & ")"
    End If
HandleExit:
    Set rst = Nothing
    p_GetRealFilter = strFilter
    Exit Function
HandleError:
    Err.Clear
    Resume HandleExit
End Function
Private Function p_GetUpwardNodes(NodeKey As Long, ByRef cPar As Collection, Optional FieldName As String, _
    Optional ShowRoot As Boolean = True, Optional ShowCurrent As Boolean = False) As Boolean
' получает список всех родительских узлов по восходящей для заданной вершинны
Const c_strProcedure = "p_GetParents"
Dim lKey As Long, iKey As String, sText
Dim Result As Boolean

    Result = False
    lKey = NodeKey
    On Error GoTo HandleExit
    If Len(FieldName) = 0 Then FieldName = mstrKeyFieldName
    On Error Resume Next
    Set cPar = New Collection
    'If cPar Is Nothing Then Set cPar = New Collection
    Do While p_GotoRecord(m_daoSource, lKey)
        ' если текущий узел - исходный
        If lKey = m_varRootKey And Not ShowCurrent Then GoTo HandleNext
        ' если текущий узел - корневой
        If lKey = m_varRootKey Then
            If Not ShowRoot Then Exit Do
            If FieldName = mstrKeyFieldName Then sText = lKey Else sText = "[root]"
        End If
        iKey = c_colPref & lKey
        sText = m_daoSource(FieldName).Value
        cPar.Add sText, iKey: If Err Then Err.Clear
HandleNext:
        If lKey = m_varRootKey Then Exit Do
        lKey = m_daoSource.Fields(mstrParFieldName).Value
    Loop
    Result = True
HandleExit:
    p_GetUpwardNodes = Result
    Exit Function
HandleError:
    Result = False
    Err.Clear
    Resume HandleExit
End Function
Private Function p_CreateTreeRecordset()
'' создает вспомогательный Recordset для хранения данных о вершинах и их связях
'    Set adoRst = CreateObject("ADODB.Recordset")
'    With adoRst
'        ii = LBound(arrFields): iiMax = UBound(arrFields)
'        Do While ii <= iiMax
'            .Fields.Append arrFields(ii), adVarChar, 13
'            ii = ii + 1
'        Loop
'        .Open

'        i = LBound(arrCodes): iMax = UBound(arrCodes)
'        Do While i <= iMax
'            .AddNew
'            Do While ii <= iiMax
'                .Fields(arrFields(ii)).Value = Trim$(arrValues(ii))
'                ii = ii + 1
'            Loop
'            .UpdateBatch
'            i = i + 1
'        Loop
'HandleSetData:
'    End With
End Function

1. Создать поле и вывести в него текстовую метку
2. Если у текущей записи есть подчиненные - 
  2.1 Если есть родители 
    2.1.1 Если Параметр1 родителя = 2 Вывести Набор контролов 2
    2.1.2 Иначе Если Параметр1 родителя = 3 Вывести Набор контролов 3
3. Если нет подчиненных 
  3.1 Если есть родители и Параметр1 родителя = 2
    3.1.1 Если нет левого соседа вывести Набор контролов 1.1  ' << первый подчиненный родителя типа 2
    3.1.2 Иначе вывести Набор контролов 1.2                   ' << прочие подчиненные родителя типа 2
    3.1.3 Перейти к Шагу 4
  3.2 Создать набор контролов 1
4. Перейти к следующей записи в дереве                        ' << переход к следующей записи
  4.1 Если есть подчиненная - переход к первой подчиненной
  4.2 Иначе Если есть сосед - справа переход к соседу справа
  4.3 Иначе Если есть родитель и у родителя есть сосед справа - переход к соседу справа родителя
  4.4 Иначе Стоп                                              ' << обход дерева закончен
5. Переход к Шагу 1                                           ' << переход к выводу контролов для следующей записи

                          [Кнопка1],[Кнопка2]..[КнопкаN] ' Групповые кнопки. 
1.Текст 1 уровня                                         ' Есть подчиненные
  1.1.Текст 2 уровня      [Кнопка1],[Кнопка2]..[КнопкаN] ' Параметр = 1, нет подчиненных
                          [Поле1  ],[Поле2  ]..[ПолеN  ]
  1.2.Текст 2 уровня      [вспомогательная информация  ] ' Параметр = 3
                          [Кнопка1],[Кнопка2]..[КнопкаN]
    1.2.1.Текст 3 уровня  [Поле1  ],[Поле2  ]..[ПолеN  ]
    1.2.2/Текст 3 уровня  [Поле1  ]
    ...
    1.2.N.Текст 3 уровня  [Поле1  ]
2.Текст 1 уровня          [вспомогательная информация  ] ' Параметр = 2
  2.1.Текст 2 уровня      [Кнопка1],[Кнопка2]..[КнопкаN]
                          [Поле1  ],[Поле2  ]..[ПолеN  ]
  ...
  2.N.Текст 2 уровня      [Кнопка1],[Кнопка2]..[КнопкаN]
                          [Поле1  ],[Поле2  ]..[ПолеN  ]
3.Текст 1 уровня          [Кнопка1],[Кнопка2]..[КнопкаN] ' Параметр = 1, нет подчиненных
                          [Поле1  ],[Поле2  ]..[ПолеN  ]