vbAccelerator - Contents of code file: frmTestTreeView.frm

VERSION 5.00
Object = "{A3A35BDB-3B6A-46F3-B662-08B8F72ECD03}#11.1#0"; "vbalTreeView.ocx"
Object = "{8245A918-4CF7-11D2-8E21-10B404C10000}#8.1#0"; "vbalIml.ocx"
Begin VB.Form frmTestTreeView 
   Caption         =   "vbAccelerator TreeView Control Demonstration"
   ClientHeight    =   4230
   ClientLeft      =   1845
   ClientTop       =   2145
   ClientWidth     =   11085
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmTestTreeView.frx":0000
   LinkTopic       =   "Form1"
   OLEDropMode     =   1  'Manual
   ScaleHeight     =   4230
   ScaleWidth      =   11085
   Begin VB.CheckBox chkHistory 
      Caption         =   "&History Mode"
      Height          =   195
      Left            =   8400
      TabIndex        =   11
      Top             =   3720
      Value           =   1  'Checked
      Width           =   2595
   End
   Begin VB.CommandButton cmdRepopulate 
      Caption         =   "&Repopulate"
      Height          =   315
      Left            =   2520
      TabIndex        =   10
      Top             =   3660
      Width           =   1155
   End
   Begin VB.CommandButton cmdClear 
      Caption         =   "&Clear"
      Height          =   315
      Left            =   1260
      TabIndex        =   9
      Top             =   3660
      Width           =   1155
   End
   Begin VB.CommandButton cmdNewInstance 
      Caption         =   "&New..."
      Height          =   315
      Left            =   60
      TabIndex        =   8
      Top             =   3660
      Width           =   1155
   End
   Begin vbalIml.vbalImageList vbalImageList1 
      Left            =   7320
      Top             =   3780
      _ExtentX        =   953
      _ExtentY        =   953
      ColourDepth     =   8
      Size            =   10332
      Images          =   "frmTestTreeView.frx":1272
      Version         =   131072
      KeyCount        =   9
      Keys            =   ""
   End
   Begin vbalTreeViewLib.vbalTreeView tvwDemo 
      Height          =   3255
      Left            =   60
      TabIndex        =   1
      Top             =   360
      Width           =   2655
      _ExtentX        =   4683
      _ExtentY        =   5741
      NoCustomDraw    =   0   'False
      FullRowSelect   =   -1  'True
      LineStyle       =   0
      Style           =   3
      LabelEdit       =   -1  'True
      OLEDropMode     =   1
      DragAutoExpand  =   -1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin vbalTreeViewLib.vbalTreeView tvwColours 
      Height          =   3255
      Left            =   2820
      TabIndex        =   3
      Top             =   360
      Width           =   2655
      _ExtentX        =   4683
      _ExtentY        =   5741
      BackColor       =   0
      CheckBoxes      =   -1  'True
      NoCustomDraw    =   0   'False
      ForeColor       =   3182688
      LineColor       =   1393968
      SelectedBackColor=   3182688
      SelectedForeColor=   6353088
      SelectedBackColor=   3182688
      SelectedForeColor=   6353088
      SelectedBackColor=   3182688
      SelectedForeColor=   6353088
      SelectedBackColor=   3182688
      SelectedForeColor=   6353088
      OLEDropMode     =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin vbalTreeViewLib.vbalTreeView tvwHistory 
      Height          =   3255
      Left            =   8340
      TabIndex        =   7
      Top             =   360
      Width           =   2655
      _ExtentX        =   4683
      _ExtentY        =   5741
      BorderStyle     =   0
      NoCustomDraw    =   0   'False
      HistoryStyle    =   -1  'True
      FullRowSelect   =   -1  'True
      SingleSel       =   -1  'True
      Style           =   1
      OLEDropMode     =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin vbalTreeViewLib.vbalTreeView tvwNumbers 
      Height          =   3255
      Left            =   5580
      TabIndex        =   5
      Top             =   360
      Width           =   2655
      _ExtentX        =   4683
      _ExtentY        =   5741
      NoCustomDraw    =   0   'False
      LabelEdit       =   -1  'True
      OLEDropMode     =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.Label lblInfo 
      BackColor       =   &H80000010&
      Caption         =   " History Style"
      Height          =   255
      Index           =   3
      Left            =   8340
      TabIndex        =   6
      Top             =   60
      Width           =   2655
   End
   Begin VB.Label lblInfo 
      BackColor       =   &H80000010&
      Caption         =   " Item Numbering"
      Height          =   255
      Index           =   2
      Left            =   5580
      TabIndex        =   4
      Top             =   60
      Width           =   2655
   End
   Begin VB.Label lblInfo 
      BackColor       =   &H80000010&
      Caption         =   " Global Colours and Checkboxes"
      Height          =   255
      Index           =   1
      Left            =   2820
      TabIndex        =   2
      Top             =   60
      Width           =   2655
   End
   Begin VB.Label lblInfo 
      BackColor       =   &H80000010&
      Caption         =   " Per-Item Formatting"
      Height          =   255
      Index           =   0
      Left            =   60
      TabIndex        =   0
      Top             =   60
      Width           =   2655
   End
   Begin VB.Menu mnuContextTOP 
      Caption         =   ""
      Visible         =   0   'False
      Begin VB.Menu mnuContext 
         Caption         =   "&Add Child Node..."
         Index           =   0
      End
      Begin VB.Menu mnuContext 
         Caption         =   "-"
         Index           =   1
      End
      Begin VB.Menu mnuContext 
         Caption         =   "&Count Child Nodes..."
         Index           =   2
      End
      Begin VB.Menu mnuContext 
         Caption         =   "-"
         Index           =   3
      End
      Begin VB.Menu mnuContext 
         Caption         =   "&Clear Child Nodes..."
         Index           =   4
      End
   End
End
Attribute VB_Name = "frmTestTreeView"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, tP As
 POINTAPI) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Private m_cIml As cVBALSysImageList
Private m_colKey As New Collection
Private contextNode As cTreeViewNode
Private m_lNewKeyID As Long

Private Sub PrepareImageList()
   
   ' Create a System Image List:
   Set m_cIml = New cVBALSysImageList
   m_cIml.IconSizeX = 16
   m_cIml.IconSizeY = 16
   m_cIml.Create
   
   ' Assign it to all of the TreeView controls:
   tvwDemo.ImageList = m_cIml.hIml
   tvwColours.ImageList = vbalImageList1.hIml
   tvwNumbers.ImageList = m_cIml.hIml
   tvwHistory.ImageList = m_cIml.hIml
   
   ' Enumerate the shell's desktop folder for files
   Dim shl As New Shell
   Dim desktopFolder As Folder
   Set desktopFolder = shl.NameSpace(ssfDESKTOP)
   Dim desktopItem As FolderItem
   Dim count As Long
   For Each desktopItem In desktopFolder.Items
      If (InStr(desktopItem.Path, "\") > 0 Or InStr(desktopItem.Path, "::{") >
       0) Then
         m_colKey.Add desktopItem.Path, CStr(count)
         count = count + 1
      End If
   Next
   
End Sub

Private Sub AddToTree(tvw As vbalTreeView, Optional ByVal iter As Long = 1)
Dim nodTop As cTreeViewNode
Dim nodSub As cTreeViewNode
Dim nodSubSub As cTreeViewNode
Dim i As Long
Dim j As Long
Dim childCount As Long
Dim fnt As StdFont
Dim subIcon As Long
Dim subSubIcon As Long
Dim children As cTreeViewNodes
Dim subChildren As cTreeViewNodes

   Set fnt = New StdFont
   fnt.Name = "Times New Roman"
   fnt.Size = 10
   fnt.Italic = True
   
   Set nodTop = tvw.Nodes.Add(, etvwFirst, iter & "TOP", "Test Top",
    IIf(tvw.BackColor = &H0, Int(Rnd * vbalImageList1.ImageCount),
    m_cIml.ItemIndex(m_colKey(CStr(Int(Rnd * m_colKey.count))))))
   If (tvw Is tvwDemo) Then
      nodTop.Bold = True
      nodTop.BackColor = &HB7FBFA
      nodTop.ForeColor = vbWindowText
      nodTop.SelectedBackColor = nodTop.BackColor
      nodTop.SelectedForeColor = vbWindowText
      nodTop.MouseOverBackColor = nodTop.BackColor
      nodTop.MouseOverForeColor = &H477574
      nodTop.SelectedMouseOverBackColor = nodTop.BackColor
      nodTop.SelectedMouseOverForeColor = vbWindowText
      nodTop.SelectedNoFocusBackColor = nodTop.BackColor
      nodTop.SelectedNoFocusForeColor = vbWindowText
      
   ElseIf (tvw.BackColor = &H0) Then
      nodTop.Bold = True
      nodTop.NoCheckBox = True
      
   ElseIf (tvw.HistoryStyle) Then
      nodTop.Selected = True
      
   End If
   
   Set children = nodTop.children
   
   subIcon = IIf(tvw.BackColor = &H0, Int(Rnd * vbalImageList1.ImageCount),
    m_cIml.ItemIndex(m_colKey(CStr(Int(Rnd * m_colKey.count)))))
   For i = 1 To 10
      
      Set nodSub = children.Add(, etvwChild, iter & "SUB" & i, "Sub-item " & i,
       subIcon)
      If (tvw Is tvwDemo) Then
         If (i Mod 2) = 0 Then
            nodSub.BackColor = &H95E3E2
            nodSub.ForeColor = vbWindowText
            nodSub.SelectedBackColor = nodSub.BackColor
            nodSub.MouseOverBackColor = nodSub.BackColor
            nodSub.SelectedMouseOverBackColor = nodSub.BackColor
            nodSub.SelectedNoFocusBackColor = nodSub.BackColor
         Else
            nodSub.BackColor = &HAAE6B7
            nodSub.ForeColor = vb3DHighlight
            nodSub.SelectedBackColor = nodSub.BackColor
            nodSub.MouseOverBackColor = nodSub.BackColor
            nodSub.SelectedMouseOverBackColor = nodSub.BackColor
            nodSub.SelectedNoFocusBackColor = nodSub.BackColor
         End If
         nodSub.Font = fnt
      End If
      
      childCount = 2 + Rnd * 5
      If (tvw.ShowNumber) Then
         nodSub.ItemNumber = childCount
      End If
      subSubIcon = IIf(tvw.BackColor = &H0, Int(Rnd *
       vbalImageList1.ImageCount), m_cIml.ItemIndex(m_colKey(CStr(Int(Rnd *
       m_colKey.count)))))
      Set subChildren = nodSub.children
      For j = 1 To childCount
         Set nodSubSub = subChildren.Add(, etvwChild, iter & "SUB" & i & " SUB"
          & j, "Sub-item " & i & ", child " & j, subSubIcon)
      Next j
      If Not (tvw.HistoryStyle) Then
         nodSub.Expanded = True
      End If
   Next i
   
   If Not (tvw.HistoryStyle) Then
      nodTop.Expanded = True
   End If

End Sub

Private Sub chkHistory_Click()
   tvwHistory.HistoryStyle = (chkHistory.Value = Checked)
End Sub

Private Sub cmdClear_Click()
   tvwDemo.Nodes.Clear
   tvwColours.Nodes.Clear
   tvwNumbers.Nodes.Clear
   tvwHistory.Nodes.Clear
End Sub

Private Sub cmdNewInstance_Click()
   Dim fNew As New frmTestTreeView
   fNew.left = Me.left + 20 * Screen.TwipsPerPixelX
   fNew.tOp = Me.tOp + 20 * Screen.TwipsPerPixelY
   fNew.Show
End Sub

Private Sub cmdRepopulate_Click()
   AddToTree tvwDemo
   AddToTree tvwColours
   AddToTree tvwNumbers
   Dim i As Long
   For i = 1 To 6
      AddToTree tvwHistory, i
   Next i
End Sub

Private Sub Form_Load()

   Me.Show
   Me.Refresh

   ' This speeds things up a bit (approx 100ms)
   tvwDemo.Visible = False
   tvwColours.Visible = False
   tvwNumbers.Visible = False
   tvwHistory.Visible = False

   PrepareImageList
   
   Dim lTime As Long
   lTime = timeGetTime()
   tvwDemo.FullRowSelect = True
   AddToTree tvwDemo
   tvwDemo.Visible = True
   Debug.Print timeGetTime() - lTime
   
   lTime = timeGetTime()
   tvwColours.BackColor = &H0&
   tvwColours.ForeColor = &HC080&
   tvwColours.LineColor = &H6030&
   AddToTree tvwColours
   tvwColours.Visible = True
   Debug.Print timeGetTime() - lTime
   
   lTime = timeGetTime()
   tvwNumbers.ShowNumber = True
   AddToTree tvwNumbers
   tvwNumbers.Visible = True
   Debug.Print timeGetTime() - lTime
   
   lTime = timeGetTime()
   Dim i As Long
   For i = 1 To 6
      AddToTree tvwHistory, i
   Next i
   tvwHistory.Visible = True
   Debug.Print timeGetTime() - lTime
   
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   If (Forms.count = 2) Then ' only me and frmEvents still showing
      Unload frmEvents
   End If
End Sub

Private Sub Form_Resize()
Dim lHeight As Long
Dim lWidth As Long
   
   lWidth = (Me.ScaleWidth - tvwDemo.left * 5) \ 4
   If (lWidth < 128 * Screen.TwipsPerPixelX) Then
      lWidth = 128 * Screen.TwipsPerPixelX
   End If
   lHeight = Me.ScaleHeight - tvwDemo.tOp * 2
   
   On Error Resume Next
   
   tvwDemo.Move tvwDemo.left, tvwDemo.tOp, lWidth, lHeight
   lblInfo(0).Move tvwDemo.left, lblInfo(0).tOp, lWidth
   
   tvwColours.Move tvwDemo.left + tvwDemo.Width + tvwDemo.left, tvwDemo.tOp,
    lWidth, lHeight
   lblInfo(1).Move tvwColours.left, lblInfo(0).tOp, lWidth
   
   tvwNumbers.Move tvwColours.left + tvwColours.Width + tvwDemo.left,
    tvwDemo.tOp, lWidth, lHeight
   lblInfo(2).Move tvwNumbers.left, lblInfo(0).tOp, lWidth
   
   tvwHistory.Move tvwNumbers.left + tvwNumbers.Width + tvwDemo.left,
    tvwDemo.tOp, lWidth, lHeight
   lblInfo(3).Move tvwHistory.left, lblInfo(0).tOp, lWidth
   
   cmdNewInstance.tOp = tvwDemo.tOp + tvwDemo.Height + Screen.TwipsPerPixelY
   cmdClear.tOp = cmdNewInstance.tOp
   cmdRepopulate.tOp = cmdNewInstance.tOp
   chkHistory.Move tvwHistory.left, cmdNewInstance.tOp, tvwHistory.Width
   
End Sub

Private Sub mnuContext_Click(Index As Integer)
   Select Case Index
   Case 0
      Dim sR As String
      sR = InputBox("Enter new caption")
      If (Len(sR) > 0) Then
         m_lNewKeyID = m_lNewKeyID + 1
         contextNode.children.Add , , "NEW" & m_lNewKeyID, sR
      End If
   Case 2
      MsgBox "Child Nodes: " & contextNode.children.count, vbInformation
   Case 4
      If (contextNode.children.count = 0) Then
         If (vbYes = MsgBox("Are you sure you want to delete the node " &
          contextNode.Text & "?", vbQuestion Or vbYesNo)) Then
            contextNode.Delete
         End If
      Else
         If (vbYes = MsgBox("Are you sure you want to delete all the children
          of node " & contextNode.Text & "?", vbQuestion Or vbYesNo)) Then
            contextNode.children.Clear
         End If
      End If
   End Select
End Sub

Private Sub tvwColours_NodeCheck(node As vbalTreeViewLib.cTreeViewNode)
   frmEvents.LogEvent tvwColours, "NodeCheck", node.Key & ", Checked=" &
    node.Checked
End Sub

Private Sub tvwDemo_AfterLabelEdit(node As vbalTreeViewLib.cTreeViewNode,
 NewString As String, Cancel As Boolean)
   frmEvents.LogEvent tvwDemo, "AfterLabelEdit", node.Key & ", NewString=" &
    NewString & ",Cancel=" & Cancel
End Sub

Private Sub tvwDemo_BeforeCollapse(node As vbalTreeViewLib.cTreeViewNode,
 Cancel As Boolean)
   frmEvents.LogEvent tvwDemo, "BeforeCollapse", node.Text & " (" & node.Key &
    ")"
End Sub

Private Sub tvwDemo_BeforeExpand(node As vbalTreeViewLib.cTreeViewNode, Cancel
 As Boolean)
   frmEvents.LogEvent tvwDemo, "BeforeExpand", node.Text & " (" & node.Key & ")"
End Sub

Private Sub tvwDemo_BeforeLabelEdit(node As vbalTreeViewLib.cTreeViewNode,
 Cancel As Boolean)
   frmEvents.LogEvent tvwDemo, "BeforeLabelEdit", node.Key & ",Cancel=" & Cancel
End Sub

Private Sub tvwDemo_Click()
   frmEvents.LogEvent tvwDemo, "Click", ""
End Sub

Private Sub tvwDemo_Collapse(node As vbalTreeViewLib.cTreeViewNode)
   frmEvents.LogEvent tvwDemo, "Collapse", node.Text & " (" & node.Key & ")"
End Sub

Private Sub tvwDemo_DblClick()
   frmEvents.LogEvent tvwDemo, "DblClick", ""
End Sub

Private Sub tvwDemo_DragDropRequest(Data As DataObject, nodeOver As
 vbalTreeViewLib.cTreeViewNode, ByVal bAbove As Boolean, ByVal hitTest As Long)
   frmEvents.LogEvent tvwDemo, "DragDropRequest", IIf(nodeOver Is Nothing, "No
    Node", nodeOver.Text) & ",Above=" & bAbove & ",HitTest=" & hitTest
End Sub

Private Sub tvwDemo_Expand(node As vbalTreeViewLib.cTreeViewNode)
   frmEvents.LogEvent tvwDemo, "Expand", node.Text & " (" & node.Key & ")"
End Sub

Private Sub tvwDemo_GotFocus()
   frmEvents.LogEvent tvwDemo, "GotFocus", ""
End Sub

Private Sub tvwDemo_KeyDown(KeyCode As Integer, Shift As Integer)
   frmEvents.LogEvent tvwDemo, "KeyDown", "Key=" & KeyCode & ",Shift=" & Shift
End Sub

Private Sub tvwDemo_KeyPress(KeyAscii As Integer)
   frmEvents.LogEvent tvwDemo, "KeyPress", "KeyAscii=" & KeyAscii
End Sub

Private Sub tvwDemo_LostFocus()
   frmEvents.LogEvent tvwDemo, "LostFocus", ""
End Sub

Private Sub tvwDemo_MouseDown(Button As Integer, Shift As Integer, x As Single,
 y As Single)
   frmEvents.LogEvent tvwDemo, "MouseDown", "Button=" & Button & ",Shift=" &
    Shift & ",X=" & x & ",Y=" & y
End Sub

Private Sub tvwDemo_MouseMove(Button As Integer, Shift As Integer, x As Single,
 y As Single)
   frmEvents.LogEvent tvwDemo, "MouseMove", "Button=" & Button & ",Shift=" &
    Shift & ",X=" & x & ",Y=" & y
End Sub

Private Sub tvwDemo_MouseUp(Button As Integer, Shift As Integer, x As Single, y
 As Single)
   frmEvents.LogEvent tvwDemo, "MouseUp", "Button=" & Button & ",Shift=" &
    Shift & ",X=" & x & ",Y=" & y
End Sub

Private Sub tvwDemo_NodeCheck(node As vbalTreeViewLib.cTreeViewNode)
   Debug.Assert tvwDemo.CheckBoxes ' should not occur unless we have checkboxes
   frmEvents.LogEvent tvwDemo, "NodeCheck", node.Text & " (" & node.Key & ")"
End Sub

Private Sub tvwDemo_NodeClick(node As vbalTreeViewLib.cTreeViewNode)
   frmEvents.LogEvent tvwDemo, "Click", node.Text & " (" & node.Key & ")"
End Sub

Private Sub tvwDemo_NodeDblClick(node As vbalTreeViewLib.cTreeViewNode)
   frmEvents.LogEvent tvwDemo, "NodeDblClick", node.Text & " (" & node.Key & ")"
End Sub

Private Sub tvwDemo_NodeRightClick(node As vbalTreeViewLib.cTreeViewNode)
   frmEvents.LogEvent tvwDemo, "NodeRightClick", node.Text & " (" & node.Key &
    ")"
   Dim tP As POINTAPI
   GetCursorPos tP
   ScreenToClient tvwDemo.hwnd, tP
   If (node.children.count > 0) Then
      mnuContext(2).Enabled = True
      mnuContext(4).Caption = "&Delete Child Nodes..."
   Else
      mnuContext(2).Enabled = False
      mnuContext(4).Caption = "&Delete Node..."
   End If
   Set contextNode = node
   Me.PopupMenu mnuContextTOP, , tvwDemo.left + tP.x * Screen.TwipsPerPixelX,
    tvwDemo.tOp + tP.y * Screen.TwipsPerPixelY
End Sub

Private Sub tvwDemo_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
   frmEvents.LogEvent tvwDemo, "OLEStartDrag", ""
   AllowedEffects = vbDropEffectMove
End Sub

Private Sub tvwDemo_SelectedNodeChanged()
   frmEvents.LogEvent tvwDemo, "SelectedNodeChanged", tvwDemo.SelectedItem.Text
End Sub