VBNet - Форум

Вопрос: TreeView Добавлено: 06.07.04 21:38

Автор вопроса: Дмитрий_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

Ответить

Ответы Всего ответов: 2

Номер ответа: 1 Автор ответа: dNW Вопросов: 30 Ответов: 683	Профиль \| Цитата \| #1	Добавлено: 07.07.04 07:27
	Не всякий станет тебе отвечать, по причине огромного кода. Дай тот кусок, в котором ошибка Ответить

Номер ответа: 2 Автор ответа: sne Разработчик Offline Client ICQ: 233286456 Вопросов: 34 Ответов: 5445	Web-сайт: hw.t-k.ru Профиль \| Цитата \| #2	Добавлено: 07.07.04 11:25
	а лучше не используй чужого и сделае все сам И лучше на АПИ ) Шучу Ответить

Страница: 1 |