ctreeview.cls

用Treeview来显示每个Field

Private Sub oTree_OLESetData(Data As MSComctlLib.DataObject, DataFormat As Integer)
    #If DEBUGMODE = 1 Then
        Debug.Print dbgCtrlName; "::OLESetData -> Effect="; CStr(DataFormat)
    #End If

End Sub

Private Sub oTree_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
    #If DEBUGMODE = 1 Then
        Debug.Print dbgCtrlName; "::OLEStartDrag -> AllowedEffects="; CStr(AllowedEffects)
    #End If

End Sub

Private Sub oTree_Validate(Cancel As Boolean)
    #If DEBUGMODE = 1 Then
        Debug.Print dbgCtrlName; "::Validate -> Cancel="; CStr(Cancel)
    #End If

End Sub

'===========================================================================
'
Private Sub Class_Initialize()
    '## Set defaults...
    meContextMenuMode = [After Click]
    mbDragEnabled = False
End Sub

Private Sub Class_Terminate()
    '## release control
    UnHookCtrl
End Sub

'===========================================================================
' Public subroutines and functions
'
Public Function NodeAdd(Optional ByVal vRelative As Variant, _
                        Optional ByVal eRelationship As MSComctlLib.TreeRelationshipConstants, _
                        Optional ByVal sKey As String, _
                        Optional ByVal sText As String, _
                        Optional ByVal vImage As Variant, _
                        Optional ByVal vSelectedImage As Variant, _
                        Optional ByVal vTag As Variant, _
                        Optional ByVal bBold As Boolean = False, _
                        Optional ByVal bChecked As Boolean = False, _
                        Optional ByVal bEnsureVisible As Boolean = False, _
                        Optional ByVal bExpanded As Boolean = True, _
                        Optional ByVal bSelected As Boolean = False, _
                        Optional ByVal bVisible As Boolean = True, _
                        Optional ByVal lForeColor As OLE_COLOR, _
                        Optional ByVal lBackColor As OLE_COLOR, _
                        Optional ByVal vExpandedImage As Variant) As MSComctlLib.Node
Attribute NodeAdd.VB_Description = "Adds node to TreeView and sets properties in one call"

    Dim Node As MSComctlLib.Node

    On Error GoTo ErrorHandler

    Set Node = oTree.Nodes.Add(vRelative, eRelationship, sKey, sText, vImage, vSelectedImage)
    With Node
        #If DEBUGMODE = 1 Then
            Debug.Print "ADD-> Text = "; .Text; "   Index = "; CStr(.Index)
        #End If
        .Tag = vTag
        .Bold = bBold
        .Checked = bChecked
        If bEnsureVisible Then .EnsureVisible
        .Expanded = bExpanded
        .Selected = bSelected
        '.Visible = bVisible
        If lForeColor = 0 Then
            .ForeColor = vbWindowText
        Else
            .ForeColor = lForeColor
        End If
        If lBackColor = 0 Then
            .BackColor = vbWindowBackground
        Else
            .BackColor = lBackColor
        End If
        If Not IsMissing(vExpandedImage) Then
            .ExpandedImage = vExpandedImage
        End If
    End With
    
    Set NodeAdd = Node
    Exit Function

ErrorHandler:
    Err.Raise Err.Number, Err.Source, Err.Description
End Function

Public Sub ClearTreeView()
Attribute ClearTreeView.VB_Description = "A very fast way of clearing all nodes"
    '## Clear the treeview

    Dim hItem As Long
    Dim hWnd  As Long

    Redraw False
    hWnd = oTree.hWnd
    Do
        hItem = SendMessageLong(hWnd, TVM_GETNEXTITEM, TVGN_ROOT, 0)
        If hItem <= 0 Then Exit Do
        SendMessageLong hWnd, TVM_DELETEITEM, &O0, hItem
    Loop
    Redraw True

End Sub

Public Sub Redraw(Enabled As Boolean)
Attribute Redraw.VB_Description = "Enable/disable screen updates."

    Dim hWnd  As Long

    If Not (oTree Is Nothing) Then
        hWnd = oTree.hWnd
        If Enabled Then
            '## Lock the window update to avoid flickering
            SendMessageLong hWnd, WM_SETREDRAW, False, &H0
        Else
            '## Unlock the window
            SendMessageLong hWnd, WM_SETREDRAW, True, &H0
        End If
    End If

End Sub
Public Sub CollapseAll()
Attribute CollapseAll.VB_Description = "Hide all children"
    '## Collapse all nodes

    Dim Node  As Node

    Redraw False
    For Each Node In oTree.Nodes
        With Node
            If .Children Then .Expanded = False
        End With
    Next
    Redraw True

End Sub

Public Sub CollapseChildNodes(ByVal Node As MSComctlLib.Node)
Attribute CollapseChildNodes.VB_Description = " Collapse all children that belong to Node"

    Dim lCount As Long
    Dim lLoop  As Long

    Redraw False
    With Node
        If Not Node Is Nothing Then
            .Expanded = False
        End If

        If .Children Then               '## Does node have children?
            lCount = .Children
            Set Node = .Child
            For lLoop = 1 To lCount
                CollapseChildNodes Node '## Yes, collapse them as well (recursive)
                If lLoop < lCount Then
                    Set Node = .Next
                End If
            Next
        End If
    End With
    Redraw True

End Sub

Public Property Get ContextMenuMode() As eContextMenuMode
Attribute ContextMenuMode.VB_Description = "Raise ContextMenu Event before or after Click Event [Default = After]"
    ContextMenuMode = meContextMenuMode
End Property

Public Property Let ContextMenuMode(ByVal Mode As eContextMenuMode)
    meContextMenuMode = Mode
End Property

Public Property Get Ctrl() As MSComctlLib.TreeView
Attribute Ctrl.VB_UserMemId = 0
Attribute Ctrl.VB_MemberFlags = "640"
    '## Default Object
    Set Ctrl = oTree
End Property

Public Property Get DragEnabled() As Boolean
Attribute DragEnabled.VB_Description = "Enables/disables drag'n'drop"
    DragEnabled = mbDragEnabled
End Property

Public Property Let DragEnabled(ByVal Enabled As Boolean)
    mbDragEnabled = Enabled
End Property

Public Sub ExpandAll()
Attribute ExpandAll.VB_Description = "Show all children"
    '## Expand all nodes

    Dim Node  As Node

    On Error GoTo ErrorHandler                      '@@ v01.00.01
    Redraw False
    For Each Node In oTree.Nodes
        With Node
            If .Children Then .Expanded = True
        End With
    Next
    Redraw True
    Exit Sub

ErrorHandler:
    Select Case Err.Number
        Case 35606: ExpandAll
    End Select
End Sub

Public Sub ExpandChildNodes(ByVal Node As MSComctlLib.Node)
Attribute ExpandChildNodes.VB_Description = "Expand all children that belong to Node"

    Dim lCount As Long
    Dim lLoop  As Long

    Redraw False
    With Node
        If Not Node Is Nothing Then
            .Expanded = True
        End If

        If .Children Then               '## Does node have children?
            lCount = .Children
            Set Node = .Child
            For lLoop = 1 To lCount
                ExpandChildNodes Node   '## Yes, expand them as well (recursive)
                If lLoop < lCount Then
                    Set Node = .Next
                End If
            Next
        End If
    End With
    Redraw True

End Sub

Public Sub HookCtrl(Ctrl As MSComctlLib.TreeView)
Attribute HookCtrl.VB_Description = "Must be called before class will raise events"

    Dim bState As Boolean

    Set oTree = Ctrl                                '## Capture the Treeview control.
                                                    '   Class won't work if this isn't called first.
    With oTree
        #If DEBUGMODE = 1 Then
            dbgCtrlName = .Parent.Name + "." + .Name
        #End If
        '
        '## calculate the height (pixels) of a node '@@ v01.00.01
        '
        bState = .Scroll                            '## Remember if scrollbars are enabled
        .Scroll = False                             '## Turn them off
        mlNodeHeight = .Height \ .GetVisibleCount   '## calculate height
        .Scroll = bState                            '## restore scrollbar state
    End With

End Sub

Public Property Get ParentNodeText(Node As MSComctlLib.Node) As String
Attribute ParentNodeText.VB_Description = "Returns the parent node text (Safe routine to stop error condition if no parent node)"
    '## Returns the parent text
    '   NOTE: If a Node has no parent then VB raises an error.
    '         This is a much safer Node.Parent.Text routine.
    With Node
        ParentNodeText = IIf(.FullPath = .Text, "", .Parent)
    End With
End Property

Public Function IsParentNode(ChildNode As MSComctlLib.Node, _
                             ParentNode As MSComctlLib.Node) As Boolean
Attribute IsParentNode.VB_Description = "Checks if one node is the parent of another"
    '## Checks if one node is the parent of another.
    '   This is a recursive routine that steps down through
    '   the branches of the parent node.

    Dim lNDX As Long

    If ParentNode.Children Then             '## Does the parent node have children?
        lNDX = ParentNode.Child.Index       '## Yes, remember the first child
        Do                                  '## Step through all child nodes
            If lNDX = ChildNode.Index Then  '## is ChildNode the test node?
                IsParentNode = True         '## ParentNode is the parent of ChildNode.
                Exit Do
            End If
            If IsParentNode(ChildNode, oTree.Nodes(lNDX)) Then  '## Step down through the branches
                IsParentNode = True         '## ParentNode is the parent of ChildNode.
                Exit Do
            End If
            If lNDX <> ParentNode.Child.LastSibling.Index Then  '## Have we tested the last child node?
                lNDX = oTree.Nodes(lNDX).Next.Index             '## No. Point to the next child node
            Else
                Exit Do                                         '## Yes.
            End If
        Loop
    End If

End Function

Public Function IsRootNode(Node As MSComctlLib.Node) As Boolean
Attribute IsRootNode.VB_Description = "Check is selected node is a root node."
    '## Check is selected node is a root node.
    With Node
        IsRootNode = (.FullPath = .Text)
    End With
End Function

Public Sub UnHookCtrl()
Attribute UnHookCtrl.VB_Description = "Releases the hooked control."
    '## Release the hooked control
    Set oTree = Nothing
End Sub

Public Function NodeDelete(Node As MSComctlLib.Node, _
            Optional ByVal bSelect As Boolean = True) As Boolean
Attribute NodeDelete.VB_Description = "Deletes a Node  and optionally selects & ensures visibility of its parent"

    With Node
        If Not IsRootNode(Node) Then    '## Is this a root node?
            With .Parent                '## No.
                .EnsureVisible
                .Selected = bSelect
            End With
        End If
        '## Delete node
        oTree.Nodes.Remove .Index       '## Delete the node
    End With
    NodeDelete = True

End Function

Public Function NodeFind(oResultNode As MSComctlLib.Node, _
                   ByVal NodeText As String, _
          Optional ByVal NodeKey As String, _
          Optional ByVal bSelect As Boolean = True) As Boolean
Attribute NodeFind.VB_Description = "Finds a Node and optionally selects & ensures visibility"

    Dim Node     As Node
    Dim bCheckKey As Boolean
    Dim bKeyOK    As Boolean