Solved

treeview ahhhhhh?

Posted on 2000-04-03
370 Views
I need a sorting code that work like this:
I have two variable values X & Y. I need to get them listed in this order with the smallest value first in a treeview list. The Y Values must be sorted by the X values.

*************** Example  ***************

Treeview list:

X------+----Y
|        |
|         +----Y
|        |
|         +----Y
|
X-----+---Y
|        |
|        +---Y
|        |
|        +---Y
|
|
X-----+----Y
|
+---Y

Treeview list with values:

1------+----12
|        |
|         +----54
|        |
|         +----84
|
2-----+---1
|        |
|        +---2
|        |
|        +---3
|
|
3-----+----45
|
+---100

After this I need to put the values from the treeview to  two listbox'es
Like this:

X                                          Y
************                     ************
* Listbox1 *                    * Listbox1 *
************                     ************
*       1         *                    *       12      *
*       1         *                    *       54      *
*       1         *                    *       84      *
*       2         *                    *         1      *
*       2         *                    *         2      *
*       2         *                    *         3      *
*       3         *                    *       45      *
*       3         *                    *     100     *
************                      ************

It must be easy to add new X & Y values in the treeview list. And every time
new values are added they must be sorted in the same order. The small first.

Thanks
0
Question by:thor918
• 8
• 2
• 2
• +1

LVL 142

Expert Comment

ID: 2679705
To get your treeview sorted, simply set the .Sorted Property of the treeview to True.
For your children, you need to change the .Sorted Property of your X nodes to true
To fill your Listboxes, simply do this:

DIM nodParent as Node
DIM nodChild as Node
SET nodParent = TreeView.Nodes.Root.FirstSibling

WHILE NOT( nodParent IS NOTHING )
SET nodChild = nodParent.Child
WHILE NOT (nodChild IS NOTHING)

Set nodChild = nodCHild.Next
WEND

SET nodParent = nodParent.Next
WEND

Good luck
0

LVL 2

Author Comment

ID: 2682719
Adjusted points from 200 to 400
0

LVL 2

Author Comment

ID: 2682720
Nice. I going to try it at once!
0

LVL 2

Author Comment

ID: 2699608
I don't get the code you posted to work angelIII...
TreeView.Nodes.Root.FirstSibling
There's no  root under nodes
0

LVL 2

Author Comment

ID: 2699621
e-mail me at
thor918@postkassa.no
0

LVL 142

Expert Comment

ID: 2699622
uups (this is because i typed the code directly here...) shame on me...

TreeView.Nodes(1).Root.FirstSibling

0

LVL 2

Author Comment

ID: 2699624
is someone want's to send me examples send it on my e-mail
0

LVL 2

Author Comment

ID: 2699627
okey. going to try it once more.
later...
0

LVL 2

Author Comment

ID: 2699630
okey. going to try it once more.
later...
0

Expert Comment

ID: 2699783
Hi,

First set the treeview.sorterd property true. Whenever adding a node, set that node.sorted=true. This will sort the values in a way u like. if ur having a numeric values to be sorterd prfix it blank spcces or zero for the length u want.

have any clarificatons get back to me....

okay!!!!!!!!!

sample code for ur reference......

Dim x As Node
Set x = TreeView1.Nodes.Add(, , , "4")
x.Sorted = True
TreeView1.Sorted = True
End Sub

I hope this will work out for u

Cheers
rbsubra
(*_*)
0

LVL 2

Author Comment

ID: 2702239
Thanks.
That worked.
But how do you add one value under the same X node. And how do you prevent that there is not more of the same value?

regards
0

Expert Comment

ID: 2702831
Hey,

its so simple...........

have a look at this

End Sub

Private Function AddNode(x As String, y As String)
Dim nodeX As Node
Dim relNode As Node
If TreeView1.Nodes.Count > 0 Then
Set nodeX = TreeView1.Nodes(1)
Do While (nodeX Is Nothing) = False
If nodeX.Text = x Then
Set relNode = nodeX
Set nodeX = Nothing
Else
Set nodeX = nodeX.Next
End If
Loop
End If
If relNode Is Nothing Then
Set relNode = TreeView1.Nodes.Add(, , , x)
End If
TreeView1.Sorted = True
relNode.Sorted = True
End Function

0

Accepted Solution

duboiss earned 400 total points
ID: 2711370
Try these example of manipulation of treeview and listview.
There are 1 form and 3 classes.

'---------------------------------------------------
' frmExplorer Form

Option Explicit

Dim WithEvents Explorer As CExplorer2

RefreshTree
End Sub

Private Sub Form_Resize()
TreeView1.Move 0, 0, ScaleWidth / 2, ScaleHeight
ListView1.Move ScaleWidth / 2, 0, ScaleWidth / 2, ScaleHeight
End Sub

Sub RefreshTree()
Set Explorer = New CExplorer2
Explorer.Init TreeView1, ListView1, 1, 2, 3

On Error Resume Next

Dim rootDir As New CDirectory2
rootDir.Path = "C:\"
Set Explorer.Root = rootDir
End Sub

'---------------------------------------------------
' CDIRECTORY2 Class
'
' This is primarily an example of a class that
' can be showed in a treeview control by implementing
' the IExplorerItem interface
'---------------------------------------------------

Option Explicit

Const CLASS_NAME = "CDirectory2"

Implements IExplorerItem

Public Path As String

' the "name" of the directory is simply the portion of
' the path that follows the last backslash, or the whole
' path if this is a root directory

Property Get Name() As String
Dim i As Integer
' get the last backslash
i = InstrLast(1, Path, "\")
If i = Len(Path) Then
Name = Path
Else
Name = Mid\$(Path, i + 1)
End If
End Property

' return the collection of subdirectories

Function Subdirs(Optional justOneIsOK As Boolean) As Collection
Dim newDir As CDirectory2, path2 As String, dirPath As String

Set Subdirs = New Collection

' add a backslash to the path if necessary
path2 = Path & IIf(Right\$(Path, 1) <> "\", "\", "")

On Error Resume Next

dirPath = Dir\$(path2 & "*.*", vbDirectory)
Do While Len(dirPath)
If (GetAttr(path2 & dirPath) And vbDirectory) = 0 Then
' it's a file or an error
' (we need this because GetAttr raises an error
'  when applied to WinNT's PAGEFILE.SYS )
Else
' it is a directory, now discard "." and ".."
If Left\$(dirPath, 1) <> "." Then
Set newDir = New CDirectory2
newDir.Path = path2 & dirPath
' exit if we don't need more
If justOneIsOK Then Exit Function
End If
End If
' get the next item, exit if null string
dirPath = Dir\$()
Loop
End Function

' returns the collection of files in the directory

Function Files() As Collection
Dim path2 As String, dirPath As String

Set Files = New Collection

' add a backslash to the path if necessary
path2 = Path & IIf(Right\$(Path, 1) <> "\", "\", "")

dirPath = Dir\$(path2 & "*.*")
Do While Len(dirPath)
' get the next item, exit if null string
dirPath = Dir\$()
Loop
End Function

' get the last occurrence of a string

Private Function InstrLast(ByVal Start As Long, ByVal Source As String, ByVal Search As String, Optional Compare As VbCompareMethod) As Long
Start = Start - 1
Do
Start = InStr(Start + 1, Source, Search, Compare)
If Start = 0 Then Exit Function
InstrLast = Start
Loop
End Function

'---------------------------------------------------
' The IExplorerItem interface
'---------------------------------------------------

Private Property Get IExplorerItem_Text() As String
IExplorerItem_Text = Name
End Property

Private Property Let IExplorerItem_Text(ByVal RHS As String)
' prevent from renaming a directory
Err.Raise 999
End Property

Private Function IExplorerItem_HasChildren() As Boolean
IExplorerItem_HasChildren = Subdirs(True).Count
End Function

Private Function IExplorerItem_GetChildren() As Collection
Set IExplorerItem_GetChildren = Subdirs(False)
End Function

Private Sub IExplorerItem_ShowItems(Explorer As CExplorer2)
Dim file As Variant
Explorer.ClearItems
For Each file In Files
Next
End Sub

Private Sub IExplorerItem_Delete()
' refuse deletion by raising an error
Err.Raise 999, CLASS_NAME, "Unable to delete this object"
End Sub

'-------------------------------------------------
'  CEXPLORER2 Class
'-------------------------------------------------

Option Explicit

Const CLASS_NAME = "CExplorer2"

Event GetChildren(Data As Variant)
Event GetItems(Data As Variant)
Event RenameNode(Data As Variant, NewName As String, Cancel As Integer)

' public boolean properties
Public AllowRename As Boolean
Public AllowDelete As Boolean

' allocation unit for m_ItemData()
Const ITEMDATA_CHUNK = 50
' text used for dummy children
Const DUMMY_CHILD = "dummy99999999"

Private Type TItemData
Node As ComctlLib.Node
Data As Variant
End Type

' the attached TreeView and ListView controls
Private WithEvents TV As ComctlLib.TreeView
Private WithEvents LV As ComctlLib.ListView

' the default icon for TreeView items (can be Missing)
Private m_Image As Variant
' the default icon for selected TreeView items (can be Missing)
Private m_SelectedImage As Variant
' the default icon for ListView items (can be Missing)
Private m_ItemImage As Variant

' this array stores the ItemData values
Dim m_ItemData() As TItemData
' the number of used items in the array
Private m_ItemDataCount As Long

Private m_Root As IExplorerItem

Property Get Root() As IExplorerItem
Set Root = m_Root
End Property

Property Set Root(newValue As IExplorerItem)
Set m_Root = newValue
ClearNodes
End Property

' initialize the class with attached TreeView and ListView controls

Sub Init(TreeView As ComctlLib.TreeView, Optional ListView As ComctlLib.ListView, Optional Image As Variant, Optional SelectedImage As Variant, Optional ItemImage As Variant)
' storeinfo about the attached TreeView control
Set TV = TreeView
m_Image = Image
m_SelectedImage = SelectedImage
TV.LabelEdit = tvwManual

' storeinfo about the attached ListView control, if not omitted
Set LV = ListView
m_ItemImage = ItemImage

' clear the two controls
ClearNodes
If Not (LV Is Nothing) Then ClearItems
End Sub

'--------------------------------------------
'  TreeView management
'--------------------------------------------

' clear all nodes

Sub ClearNodes()
TV.Nodes.Clear
ReDim m_ItemData(0) As TItemData
m_ItemDataCount = 0
End Sub

Function AddNode(text As String, Optional Data As Variant, Optional HasChildren As Boolean, Optional parent As Variant, Optional Image As Variant, Optional SelectedImage As Variant) As ComctlLib.Node
Dim newNode As ComctlLib.Node, parentNode As ComctlLib.Node

' provide default for missing arguments
If IsMissing(Image) Then Image = m_Image
If IsMissing(SelectedImage) Then SelectedImage = Image

If IsMissing(parent) Then
Set newNode = TV.Nodes.Add(, , , text, Image, SelectedImage)
Else
' add as a child node, so we need to retrieve the parent node
Set parentNode = m_ItemData(GetItemDataIndex(parent)).Node
' following code will raise error if parentNode hasn't been found
If parentNode.Children = 1 Then
' if the parent has a dummy child, delete it now
If parentNode.Child.text = DUMMY_CHILD Then
TV.Nodes.Remove parentNode.Child.Index
End If
End If
Set newNode = TV.Nodes.Add(parentNode.Index, tvwChild, , text, Image, SelectedImage)
End If

' store the companion data
If Not IsMissing(Data) Then
m_ItemDataCount = m_ItemDataCount + 1
If m_ItemDataCount > UBound(m_ItemData) Then
ReDim Preserve m_ItemData(UBound(m_ItemData) + ITEMDATA_CHUNK) As TItemData
End If
Set m_ItemData(m_ItemDataCount).Node = newNode
' objects and non-objects must be dealt with separatedly
If IsObject(Data) Then
Set m_ItemData(m_ItemDataCount).Data = Data
Else
m_ItemData(m_ItemDataCount).Data = Data
End If
End If

' if this node has children, add a dummy node just to show the "+" symbol
If HasChildren Then
End If
End Function

' ensure that there is a "+" symbol besides the node

If Node.Children = 0 Then
End If
End Sub

' remove a node
' the argument may be the node itself or its companion item data

Sub RemoveNode(Item As Variant)
Dim dataIndex As Long, nodeIndex As Long

If TypeOf Item Is ComctlLib.Node Then
' it is a TreeView node
nodeIndex = Item.Index
dataIndex = GetNodeIndex(TV.Nodes(nodeIndex))
Else
' it is something else - search in the array
dataIndex = GetItemDataIndex(Item)
If dataIndex = 0 Then Exit Sub
nodeIndex = m_ItemData(dataIndex).Node.Index
End If

' if there is an associated element in ItemData, delete it
If dataIndex Then
' check if the object supports the IExplorerItem interface
On Error Resume Next
Err.Clear
Dim tvItem As IExplorerItem
Set tvItem = m_ItemData(dataIndex).Data
If Err = 0 Then
' the interface is supported, now inform the
' object that we are going to delete it
tvItem.Delete
' if the object refuses to be deleted, exit
If Err Then Exit Sub
End If

' delete the item by moving the last one in this position
m_ItemData(dataIndex) = m_ItemData(m_ItemDataCount)
m_ItemDataCount = m_ItemDataCount - 1
End If

' finally, remove the node itself
TV.Nodes.Remove nodeIndex
End Sub

' get/let the ItemData associated to a node
' the argument may be the node's index or key, or the node itself

' Get returns empty/nothing if no data is associated to that note

Property Get ItemData(Item As Variant) As Variant
Dim Node As ComctlLib.Node, dataIndex As Long

If TypeOf Item Is ComctlLib.Node Then
Set Node = Item
Else
' the argument is the node's key or index
Set Node = TV.Nodes(Item)
End If
' find the corresponding data item
dataIndex = GetNodeIndex(Node)
If dataIndex Then
' objects and non-objects must be dealt with separatedly
If IsObject(m_ItemData(dataIndex).Data) Then
Set ItemData = m_ItemData(dataIndex).Data
Else
ItemData = m_ItemData(dataIndex).Data
End If
End If
End Property

Property Let ItemData(Item As Variant, newValue As Variant)
Dim Node As ComctlLib.Node, dataIndex As Long

If TypeOf Item Is ComctlLib.Node Then
Set Node = Item
Else
' the argument is the node's key or index
Set Node = TV.Nodes(Item)
End If
' find the corresponding data item
dataIndex = GetNodeIndex(Node)

If dataIndex Then
If IsEmpty(newValue) Then
' we want to delete an existing item
m_ItemData(dataIndex) = m_ItemData(m_ItemDataCount)
m_ItemDataCount = m_ItemDataCount - 1
Else
' we want to replace an element
m_ItemData(dataIndex).Data = newValue
End If
Else
' the item doesn't exist - let's add a new element
If Not IsEmpty(newValue) Then
m_ItemDataCount = m_ItemDataCount + 1
If m_ItemDataCount > UBound(m_ItemData) Then
ReDim Preserve m_ItemData(UBound(m_ItemData) + ITEMDATA_CHUNK) As TItemData
End If
Set m_ItemData(m_ItemDataCount).Node = Node
m_ItemData(m_ItemDataCount).Data = newValue
End If
End If

End Property

Property Set ItemData(Item As Variant, newValue As Object)
Dim Node As ComctlLib.Node, dataIndex As Long

If TypeOf Item Is ComctlLib.Node Then
Set Node = Item
Else
' the argument is the node's key or index
Set Node = TV.Nodes(Item)
End If
' find the corresponding data item
dataIndex = GetNodeIndex(Node)

If dataIndex Then
If newValue Is Nothing Then
' if we want to delete an existing item
m_ItemData(dataIndex) = m_ItemData(m_ItemDataCount)
m_ItemDataCount = m_ItemDataCount - 1
Else
' we want to replace an element
Set m_ItemData(dataIndex).Data = newValue
End If
Else
' the item doesn't exist - let's add a new element
If Not (newValue Is Nothing) Then
m_ItemDataCount = m_ItemDataCount + 1
If m_ItemDataCount > UBound(m_ItemData) Then
ReDim Preserve m_ItemData(UBound(m_ItemData) + ITEMDATA_CHUNK) As TItemData
End If
Set m_ItemData(m_ItemDataCount).Node = Node
Set m_ItemData(m_ItemDataCount).Data = newValue
End If
End If

End Property

' return the node corresponding to a given path

Function GetNodeFromPath(FullPath As String) As ComctlLib.Node
Dim Node As ComctlLib.Node
' perform sequential search (might be optimized)
For Each Node In TV.Nodes
If Node.FullPath = FullPath Then
Set GetNodeFromPath = Node
Exit Function
End If
Next
End Function

' returns the index of the element in ItemData()
' that corresponds to a given item value

Private Function GetItemDataIndex(ItemData As Variant) As Long
Dim i As Long
If IsObject(ItemData) Then
' return zero if the argument is Nothing
If ItemData Is Nothing Then Exit Function
' search the object in the array
For i = 1 To m_ItemDataCount
If m_ItemData(i).Data Is ItemData Then
GetItemDataIndex = i
Exit Function
End If
Next
Else
' return zero if the argument is null
If IsEmpty(ItemData) Or IsNull(ItemData) Then Exit Function
' search the value in the array
For i = 1 To m_ItemDataCount
If m_ItemData(i).Data = ItemData Then
GetItemDataIndex = i
Exit Function
End If
Next
End If
End Function

' returns the index of the item in ItemData()
' that corresponds to a given node

Private Function GetNodeIndex(Node As ComctlLib.Node) As Long
Dim i As Long
For i = 1 To m_ItemDataCount
If m_ItemData(i).Node Is Node Then
GetNodeIndex = i
Exit Function
End If
Next
End Function

'-------------------------------------------------
' TreeView event procedures
'-------------------------------------------------

' before expanding a node, replace any dummy child
' and ask the main program for the real children

Private Sub TV_Expand(ByVal Node As ComctlLib.Node)
Dim itemIndex As Long, Item As Variant, ParentItem As Variant
Dim tvItem As IExplorerItem, tvChild As IExplorerItem

' exit if no need to ask for children
If Node.Children <> 1 Then Exit Sub
If Node.Child.text <> DUMMY_CHILD Then Exit Sub
' remove the dummy child
TV.Nodes.Remove Node.Child.Index

itemIndex = GetNodeIndex(Node)
If itemIndex = 0 Then Exit Sub

' we need to create a reference to the parent item in a simple variant
' because if we pass the array item to the AddNode method the m_ItemData
' array would be locked and it would be prevented from being expanded
If IsObject(m_ItemData(itemIndex).Data) Then
Set ParentItem = m_ItemData(itemIndex).Data
Else
ParentItem = m_ItemData(itemIndex).Data
End If

On Error Resume Next
Err.Clear

' does the item support the IExplorerItem interface?
Set tvItem = m_ItemData(itemIndex).Data
If Err = 0 Then
For Each Item In tvItem.GetChildren
' retrieve the child's secondary interface
Set tvChild = Item
' add to the treeview control
Dim parent As Variant

Next
Else
' no, we may only ask the main program to expand the node
RaiseEvent GetChildren(ParentItem)
End If
End Sub

' trap key to delete objects

Private Sub TV_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyDelete
' delete the node ony if allowed
If AllowDelete Then RemoveNode TV.SelectedItem
End Select
End Sub

' refuse to rename an object, if AllowRename = False

Private Sub TV_BeforeLabelEdit(Cancel As Integer)
If Not AllowRename Then Cancel = True
End Sub

' inform the program that an item has been renamed

Private Sub TV_AfterLabelEdit(Cancel As Integer, NewString As String)
Dim itemIndex As Long, tvItem As IExplorerItem
itemIndex = GetNodeIndex(TV.SelectedItem)
If itemIndex = 0 Then Exit Sub

On Error Resume Next
Err.Clear

' retrieve the IExplorerItem interface
Set tvItem = m_ItemData(itemIndex).Data
If Err = 0 Then
' the interface is supported - try to modify its text property
tvItem.text = NewString
If tvItem.text <> NewString Then Cancel = True
Else
' the interface is not supported, we may only raise an event
RaiseEvent RenameNode(m_ItemData(itemIndex).Data, NewString, Cancel)
End If

End Sub

' inform the program that a node has been clicked
' and that information should be showed in the ListView control

Private Sub TV_NodeClick(ByVal Node As ComctlLib.Node)
Dim itemIndex As Long, tvItem As IExplorerItem
itemIndex = GetNodeIndex(Node)
If itemIndex = 0 Then Exit Sub

On Error Resume Next
Err.Clear
' try to retrieve the IExplorerItem interface
Set tvItem = m_ItemData(itemIndex).Data
If Err = 0 Then
' the interface is supported - ask the object to show its properties
tvItem.ShowItems Me
Else
' the interface is not supported
' ask the program to show the object's properties
RaiseEvent GetItems(m_ItemData(itemIndex).Data)
End If
End Sub

'--------------------------------------------
'  ListView management
'--------------------------------------------

' clear all listview items

Sub ClearItems()
LV.ListItems.Clear
End Sub

' add a new item, and optionally up to 5 subitems

Function AddItem(text As String, ParamArray subitems() As Variant) As ComctlLib.ListItem
Dim newItem As ComctlLib.ListItem, i As Integer

Set newItem = LV.ListItems.Add(, , text, m_ItemImage, m_ItemImage)

' add any subitems, if specified
For i = 0 To UBound(subitems)
newItem.subitems(i + 1) = subitems(i)
Next
End Function

' remove an item

Sub RemoveItem(Index As Variant)
LV.ListItems.Remove Index
End Sub

' set the columns caption and width
' arguments are in pair (caption, width)
' if the width argument of the last pair is omitted, it extends to the right edge of the control

Sub SetColumns(ParamArray args() As Variant)
Dim i As Long, colWidth As Long

For i = LBound(args) To UBound(args) Step 2
If i < UBound(args) Then
colWidth = args(i + 1)
Else
If colWidth < 2000 Then colWidth = 2000
End If
Next
End Sub

'------------------------------------------------------
' IExplorerItem Abstract Class
'
' Classes that support this interface can be assigned
' to the Root property of the TreeView class
'------------------------------------------------------

Option Explicit

' the string that must be showed on the TreeView
' the object should refuse invalid assignments
Public text As String

' returns True if this node has any children

Function HasChildren() As Boolean
'
End Function

' returns the collection of children

Function GetChildren() As Collection
'
End Function

' show the properties

Sub ShowItems(Explorer As CExplorer2)
'
End Sub

' delete the object

Sub Delete()
'
End Sub

0

Featured Post

Suggested Solutions

Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…