TreeView

[JDV]

Подскажите пожалуйста!!!!
Почему при удалении узлов всегда остается одна запись в таблице esTreeViewNodes, в своей работе использую указанный ниже класс,
проблема где-то в функции Remove в этой строке Do Until NodeRS.NoMatch, программа показывает значение True при необходимости перехода к данной строке...и
далее получается ее пропуск в следствии чего она остается в таблице....



Public Object As MSComctlLib.TreeView
Public vInspect_Root As Variant
Private NodeRS As DAO.Recordset
Dim Key As String
Dim sNomer As Variant
Dim sParent As Variant
Dim sKey As Variant


'----------------------------------------------------------------------
' Процедуры и функции для работы с классом MSComctlLib.TreeCtrl.2
'----------------------------------------------------------------------

Function NodeRight(Text As String, _
Optional RootNode As Boolean) As Boolean
' Добавление узла к TreeView (True при удачном добавлении)
' Аргументы:
' Text - Подпись узла
' RootNode - При значении True добавляется новый корневой узел
Dim cKey$

'On Error GoTo Break

' Структура таблицы:
' ID dbLong - (Счетчик)
' Parent dbText (255)
' Text dbText (255)
' Key dbText (255)
' Checked dbBoolean
' Tag dbText (255)


If Not RootNode Then

With NodeRS
.AddNew
!Text = Object.SelectedItem.Text & 1
!Key = "a" & !Id
!Index = 1
cKey = "a" & !Id
' sKey = cKey
.Update
End With

' Смена значения Parent

With NodeRS
.FindFirst "[Key] = '" & Object.SelectedItem.Key & "'"
If Not .NoMatch Then
.Edit
!Parent = cKey
' !Index = !Index + 1
.Update
End If
End With

Key = Object.SelectedItem.Key

Call Change_NodeRight

Object.Nodes.Add(Object.SelectedItem.Key, tvwPrevious, cKey) = Object.SelectedItem.Text & 1

Else


' !Parent = Object.SelectedItem.Key
' ' Определить номер подчинненого элемента и добавить к нему единицу......
' sNomer_Index
' !Index = sNomer
' !Parent = sParent


Object.Nodes.Add(Object.SelectedItem.Key, tvwNext, cKey) = Text
Object.Nodes(Object.SelectedItem.Key).Expanded = True

End If
NodeRight = True
Exit Function
'Break:
' With New esAsk: .Error "NodeAdd"
' End With
End Function

Private Function Change_NodeRight() As Boolean
' Изменяет значения Index дочерними узлов выбранного узла из таблицы типа TreeViewNodes
'
' ОСОБЕННОСТИ ФУНКЦИИ:
' функция является РЕКУРСИВНОЙ

'Меняем знаечение Index выбранной функции

Dim krit As String

'On Error GoTo Break
krit = "Key = '" & Key & "'"
NodeRS.FindFirst krit
If Not NodeRS.NoMatch Then
With NodeRS
.Edit
!Index = !Index + 1
.Update
End With

krit = "Parent = '" & Key & "'"
NodeRS.FindFirst krit

Do Until NodeRS.NoMatch

Key = NodeRS!Key

Call Change_NodeRight
NodeRS.FindNext krit
Loop
End If

Change_NodeRight = True
Exit Function
'Break:
' With New esAsk: .Error "Remove"
' End With
End Function

'Private Function Change_NodeRight() As Boolean
'' Изменяет значения Index дочерними узлов выбранного узла из таблицы типа TreeViewNodes
''
'' ОСОБЕННОСТИ ФУНКЦИИ:
'' функция является РЕКУРСИВНОЙ
'
''Меняем знаечение Index выбранной функции
'
'Dim krit As String
'
''On Error GoTo Break
'krit = "Key = '" & Key & "'"
'NodeRS.FindFirst krit
'If Not NodeRS.NoMatch Then
' With NodeRS
' .Edit
' !Index = !Index + 1
' .Update
' End With
'
' krit = "Parent = '" & Key & "'"
' NodeRS.FindFirst krit
'
' Do Until NodeRS.NoMatch
' Key = NodeRS!Key
'
' Call Change_NodeRight
' NodeRS.FindNext krit
' Loop
'End If
'
'Change_NodeRight = True
'Exit Function
''Break:
'' With New esAsk: .Error "Remove"
'' End With
'End Function

Function NodeNext(Text As String, _
Optional RootNode As Boolean) As Boolean
' Добавление узла к TreeView (True при удачном добавлении)
' Аргументы:
' Text - Подпись узла
' RootNode - При значении True добавляется новый корневой узел
Dim cKey$

'On Error GoTo Break

' Структура таблицы:
' ID dbLong - (Счетчик)
' Parent dbText (255)
' Text dbText (255)
' Key dbText (255)
' Checked dbBoolean
' Tag dbText (255)



With NodeRS
.AddNew
!Text = Text
!Key = "а" & !Id
!Parent = Object.SelectedItem.Key
' Определить номер подчинненого элемента и добавить к нему единицу......
sNomer_Index
!Index = sNomer
!Parent = sParent

cKey = "а" & !Id
.Update
End With

If RootNode Then
Object.Nodes.Add(Object.SelectedItem.Key, tvwLast, cKey) = Text

Else
Object.Nodes.Add(Object.SelectedItem.Key, tvwNext, cKey) = Text
Object.Nodes(Object.SelectedItem.Key).Expanded = True
End If
NodeNext = True
Exit Function
'Break:
' With New esAsk: .Error "NodeAdd"
' End With
End Function


Function NodeAdd(Text As String, _
Optional RootNode As Boolean) As Boolean

' Добавление узла к TreeView (True при удачном добавлении)
' Аргументы:
' Text - Подпись узла
' RootNode - При значении True добавляется новый корневой узел
Dim cKey$

'On Error GoTo Break

' Структура таблицы:
' ID dbLong - (Счетчик)
' Parent dbText (255)
' Text dbText (255)
' Key dbText (255)
' Checked dbBoolean
' Tag dbText (255)

With NodeRS
.AddNew
!Text = Text
!Key = "а" & !Id
' If Not RootNode Then
!Parent = Object.SelectedItem.Key
' End If
cKey = "а" & !Id

sNomer_Index
!Index = sNomer + 1

.Update
End With

'If RootNode Then
'' Object.Nodes.Add(, tvwChild, cKey) = Text
' Exit Function
'Else
Object.Nodes.Add(Object.SelectedItem.Key, tvwChild, cKey) = Text
Object.Nodes(Object.SelectedItem.Key).Expanded = True

'End If
NodeAdd = True
Exit Function
'Break:
' With New esAsk: .Error "NodeAdd"
' End With
End Function
Function NodeDel() As Boolean
' Удаление узла из TreeView (True при удачном удалении)
' On Error GoTo Break
Key = Object.SelectedItem.Key
Object.Nodes.Remove Key
Call Remove

NodeDel = True
Exit Function
'Break:
' With New esAsk: .Error "NodeDel"
' End With
End Function

Private Function Remove() As Boolean
' Удаляет узел с дочерними узлами из таблицы типа TreeViewNodes
'
' ОСОБЕННОСТИ ФУНКЦИИ:
' функция является РЕКУРСИВНОЙ
Dim krit As String

'On Error GoTo Break
krit = "Key = '" & Key & "'"

NodeRS.FindFirst krit

If Not NodeRS.NoMatch Then
NodeRS.Delete

krit = "Parent = '" & Key & "'"
NodeRS.FindFirst krit
Do Until NodeRS.NoMatch
Key = NodeRS!Key
Call Remove
NodeRS.FindNext krit
Loop
End If

Remove = True
Exit Function

End Function

Function TreeExpand(Optional Expand As Boolean = True) As Boolean
' Разворачивает / сворачивает все узлы дерева
' Аргументы:
' Expand - Разворачивать|сворачивать
Dim i As node

'On Error GoTo Break

'Цикл по узлам дерева
For Each i In Object.Nodes
'Если узел свернут - разворачиваем его
If i.Expanded = Not Expand Then
i.Expanded = Expand
End If
Next i

TreeExpand = True
Exit Function
'Break:
' With New esAsk: .Error "TreeExpand"
' End With
End Function

Function RootsExpand(Optional Expand As Boolean = True) As Boolean
' Разворачивает / сворачивает корневые узлы дерева
' Аргументы:
' Expand - Разворачивать (по умолчанию) или сворачивать

Dim i As node

'On Error GoTo Break
'Цикл по узлам дерева
For Each i In Object.Nodes
'Если узел свернут - разворачиваем его
If i.Expanded = Not Expand And i.Parent Is Nothing Then
i.Expanded = Expand
End If
Next i

RootsExpand = True
Exit Function
'Break:
' With New esAsk: .Error "RootsExpand"
' End With
End Function

Function NodeEdit() As Boolean
' Редактирование текста узла

Dim cKey As String, cText As String
Dim nd As node

' On Error GoTo Break

cKey = Object.SelectedItem.Key
Set nd = Object.Nodes(cKey)
cText = nd.Text

cText = InputBox("Введите новый текст," _
& vbCrLf & "который будет помещен в узел" _
& vbCrLf & "или нажмите Cancel, если этого делать не нужно.", _
"Изменить название узла?", cText)
If Len(cText) = 0 Then Exit Function
nd.Text = cText

With NodeRS
.FindFirst "[Key] = '" & cKey & "'"
If Not .NoMatch Then
.Edit
![Text] = cText
.Update
End If
End With

NodeEdit = True
Exit Function
'Break:
' With New esAsk: .Error "NodeEdit"
' End With
End Function

Function NodeCheck(Optional NodeKey As String, _
Optional Checked As Boolean = True) As Boolean
' Uncheck / Check указанный узел дерева или всё дерево, _
если аргумент Key не передан.
' Аргументы:
' Checked - Признак, Uncheck или Check указанный узел

Dim CurrentNode As node
Dim Item As node, ParentKey As String
'On Error GoTo Break

If NodeKey = vbNullString Then
For Each Item In Object.Nodes
Item.Checked = Checked
Next
With NodeRS
.MoveFirst
Do Until .EOF
.Edit
!Checked = Checked
.Update
.MoveNext
Loop
End With
GoTo ExitHere
End If

Set CurrentNode = Object.Nodes(NodeKey)
CurrentNode.Checked = Checked
With NodeRS
.FindFirst "[Key] = '" & NodeKey & "'"
If Not .NoMatch Then
.Edit
!Checked = Checked
.Update
End If
End With
'Если у текущего узла есть дочерние узлы
If CurrentNode.Children <> 0 Then
'Цикл по узлам дерева
For Each Item In Object.Nodes
On Error Resume Next
ParentKey = Item.Parent.Key
If Err.Number = 0 Then
If Len(ParentKey) > 0 Then
If ParentKey = NodeKey Then
Call NodeCheck(Item.Key, Checked)
End If
End If
End If
Next
End If

ExitHere:
NodeCheck = True
Exit Function
'Break:
' With New esAsk: .Error "NodeCheck"
' End With
End Function

Function CreateTree(SourceName As String) As DAO.Recordset
' Формирование дерева из Recordset типа esTreeView.
' Аргументы:
' SourceName - Имя таблицы или запроса.
' Структура таблицы:
' ID dbLong - (Счетчик)
' Parent dbText (255)
' Text dbText (255)
' Key dbText (255)
' Checked dbBoolean
' Tag dbText (255)


Dim SQL$


SQL = "SELECT * FROM " & SourceName & " ORDER BY Index,ID"
Set NodeRS = CurrentDb.OpenRecordset(SQL, dbOpenDynaset)
With NodeRS
Do Until .EOF

If Nz(!Parent) = vbNullString Then
Object.Nodes.Add(, tvwChild, !Key.Value) = !Text.Value
Else
Object.Nodes.Add(!Parent.Value, tvwChild, !Key.Value) = !Text.Value
End If

Object.Nodes(!Key.Value).Checked = !Checked.Value

.MoveNext
Loop
End With
' Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!Я идиот! Убейте меня, кто-нибудь!????
Set CreateTree = NodeRS
End Function

Sub ShowInfo()
' Вспомогательная функция. Позволяет просмотреть доступные параметры.
Dim Msg As String

With Object.SelectedItem
On Error Resume Next
Msg = Msg & vbCrLf & "Text= " & .Text
Err.Clear
Msg = Msg & vbCrLf & "Key= " & .Key
Err.Clear
Msg = Msg & vbCrLf & "Index= " & .Index
Err.Clear
Msg = Msg & vbCrLf & "Selected= " & .Selected
Err.Clear
Msg = Msg & vbCrLf & "Checked= " & .Checked
Err.Clear
Msg = Msg & vbCrLf & "Expanded= " & .Expanded
Err.Clear
Msg = Msg & vbCrLf & "FullPath= " & .FullPath
Err.Clear
Msg = Msg & vbCrLf & "Root= " & .Root
Err.Clear
Msg = Msg & vbCrLf & "Parent= " & .Parent
Err.Clear
Msg = Msg & vbCrLf & "Child= " & .Child
Err.Clear
Msg = Msg & vbCrLf & "Children= " & .Children
Err.Clear
Msg = Msg & vbCrLf & "Next= " & .Next
Err.Clear
Msg = Msg & vbCrLf & "Previous= " & .Previous
Err.Clear
Msg = Msg & vbCrLf & "FirstSibling= " & .FirstSibling
Err.Clear
Msg = Msg & vbCrLf & "LastSibling= " & .LastSibling
Err.Clear
Msg = Msg & vbCrLf & "Visible= " & .Visible
Err.Clear
End With
If MsgBox(Msg, vbInformation + vbOKCancel, "Свойства ctlTV") = vbCancel Then Stop
' Все эти параметры доступны, на их основании можно выводить _
на экран любую информацию из БД
End Sub
Sub sNomer_Index()
Dim cnnlocal As New ADODB.Connection
Dim rstCurr As New ADODB.Recordset
Dim fldCurr As ADODB.Field

Set cnnlocal = CurrentProject.Connection
rstCurr.Open "Select * from esTreeViewNodes", cnnlocal, adOpenDynamic, adLockPessimistic
With rstCurr
Do Until .EOF

If !Key = Object.SelectedItem.Key Then
sNomer = !Index
sParent = !Parent
Exit Sub
End If

.MoveNext
Loop
End With
rstCurr.Close

End Sub

[Igor_123]

А если не удалять построчно, а выполнить SQL-запрос на удаление по ключу, его все равно больше нет. А после переоткыть

Код: Выделить всё

SQL = "SELECT * FROM " & SourceName & " ORDER BY Index,ID"
Set NodeRS = CurrentDb.OpenRecordset(SQL, dbOpenDynaset)


но уже не делая новое построение дерева
Хотя может я неправильно понял