home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Controls / Visual Basic Controls.iso / vbcontrol / axtree / axtree.ctl < prev    next >
Encoding:
Visual Basic user-defined control file  |  1999-01-21  |  87.4 KB  |  2,427 lines
  1. VERSION 5.00
  2. Begin VB.UserControl axTree 
  3.    ClientHeight    =   4410
  4.    ClientLeft      =   0
  5.    ClientTop       =   0
  6.    ClientWidth     =   4140
  7.    ScaleHeight     =   4410
  8.    ScaleWidth      =   4140
  9.    ToolboxBitmap   =   "axTree.ctx":0000
  10.    Begin VB.PictureBox Picture1 
  11.       AutoRedraw      =   -1  'True
  12.       BackColor       =   &H00FFFFFF&
  13.       BorderStyle     =   0  'None
  14.       Height          =   3180
  15.       Left            =   315
  16.       ScaleHeight     =   3180
  17.       ScaleWidth      =   2655
  18.       TabIndex        =   0
  19.       Top             =   405
  20.       Width           =   2655
  21.       Begin VB.VScrollBar VScroll1 
  22.          Height          =   1935
  23.          Left            =   2205
  24.          TabIndex        =   1
  25.          Top             =   360
  26.          Visible         =   0   'False
  27.          Width           =   255
  28.       End
  29.    End
  30.    Begin VB.Image Image1 
  31.       Height          =   195
  32.       Index           =   0
  33.       Left            =   0
  34.       Picture         =   "axTree.ctx":0312
  35.       Top             =   0
  36.       Visible         =   0   'False
  37.       Width           =   195
  38.    End
  39.    Begin VB.Image Image1 
  40.       Height          =   195
  41.       Index           =   1
  42.       Left            =   240
  43.       Picture         =   "axTree.ctx":03FC
  44.       Top             =   0
  45.       Visible         =   0   'False
  46.       Width           =   195
  47.    End
  48.    Begin VB.Image Image1 
  49.       Height          =   195
  50.       Index           =   2
  51.       Left            =   480
  52.       Picture         =   "axTree.ctx":04E6
  53.       Top             =   0
  54.       Visible         =   0   'False
  55.       Width           =   195
  56.    End
  57.    Begin VB.Image Image1 
  58.       Height          =   195
  59.       Index           =   3
  60.       Left            =   720
  61.       Picture         =   "axTree.ctx":05D0
  62.       Top             =   0
  63.       Visible         =   0   'False
  64.       Width           =   195
  65.    End
  66.    Begin VB.Image Image1 
  67.       Height          =   195
  68.       Index           =   4
  69.       Left            =   960
  70.       Picture         =   "axTree.ctx":06BA
  71.       Top             =   0
  72.       Visible         =   0   'False
  73.       Width           =   195
  74.    End
  75.    Begin VB.Image Image1 
  76.       Height          =   195
  77.       Index           =   5
  78.       Left            =   1200
  79.       Picture         =   "axTree.ctx":07A4
  80.       Top             =   0
  81.       Visible         =   0   'False
  82.       Width           =   195
  83.    End
  84.    Begin VB.Image Image1 
  85.       Height          =   195
  86.       Index           =   6
  87.       Left            =   1440
  88.       Picture         =   "axTree.ctx":088E
  89.       Top             =   0
  90.       Visible         =   0   'False
  91.       Width           =   195
  92.    End
  93.    Begin VB.Image Image1 
  94.       Height          =   195
  95.       Index           =   7
  96.       Left            =   1680
  97.       Picture         =   "axTree.ctx":0978
  98.       Top             =   0
  99.       Visible         =   0   'False
  100.       Width           =   195
  101.    End
  102.    Begin VB.Image Image1 
  103.       Height          =   195
  104.       Index           =   8
  105.       Left            =   1920
  106.       Picture         =   "axTree.ctx":0A62
  107.       Top             =   0
  108.       Visible         =   0   'False
  109.       Width           =   195
  110.    End
  111. End
  112. Attribute VB_Name = "axTree"
  113. Attribute VB_GlobalNameSpace = False
  114. Attribute VB_Creatable = True
  115. Attribute VB_PredeclaredId = False
  116. Attribute VB_Exposed = True
  117. 'GMG 980811 : added Option Explicit
  118. Option Explicit
  119. Option Base 1
  120.  
  121. Private mOtlSet As OtlSetup
  122. Private mOtlData() As OtlData
  123. Private OrderByFields As String
  124.  
  125. Private mNodes As New CollectionEx
  126.  
  127. Const m_def_BorderStyle = 2, m_def_BorderStyleInner = 4
  128. Const m_def_Lines = True, m_def_PlusSigns = True, m_def_CheckMarks = True, m_def_Bitmaps = True
  129. Const m_def_SelectColor = vbHighlight, m_def_SelectTextColor = vbHighlightText, m_def_AutoCheckParents = True
  130. Const m_def_NewIndex = -1
  131. Private m_def_Setup As OtlSetup
  132.  
  133. Private m_BorderStyle As Integer, m_BorderStyleInner As Integer, iLast As Integer, m_PlusSign
  134. Private m_Plus As Boolean, m_Lines As Boolean, m_CheckMarks As Boolean, m_Bitmaps As Boolean
  135. Private m_SelectColor As Long, m_SelectTextColor As Long, m_AutoCheckParents As Boolean
  136. Private m_AutoRefresh As Boolean, m_NewIndex As Integer
  137.  
  138. Private m_PictureItemSelected As Picture
  139. Private m_PictureItemNotSelected As Picture
  140. Private m_PictureOpen As Picture
  141. Private m_PictureOpenSome As Picture
  142. Private m_PictureOpenAll As Picture
  143. Private m_PictureClosed As Picture
  144. Private m_PictureClosedSome As Picture
  145. Private m_PictureClosedAll As Picture
  146.  
  147. Public Enum AxBorderStyles
  148.     [No Border] = 0
  149.     [Single] = 1
  150.     [Thin Raised] = 2
  151.     [Thick Raised] = 3
  152.     [Thin Inset] = 4
  153.     [Thick Inset] = 5
  154.     [Etched] = 6
  155.     [Bump] = 7
  156. End Enum
  157.  
  158. Public Enum InnerBorderStyles
  159.     [iNo Border] = 0
  160.     [iSingle] = 1
  161.     [iThin Raised] = 2
  162.     [iThick Raised] = 3
  163.     [iThin Inset] = 4
  164.     [iThick Inset] = 5
  165. End Enum
  166.  
  167. 'events
  168. Event Click()
  169. Event NodeClick(Index As Integer)
  170. Event DblClick(Index As Integer)
  171. Attribute DblClick.VB_Description = "Occurs when user presses and then releases a mouse button and then again over an object\r\n"
  172. Event Collapse(Index As Integer)
  173. Attribute Collapse.VB_Description = "Generated when any node in control is collapsed."
  174. Event Expand(Index As Integer)
  175. Attribute Expand.VB_Description = "Generated when any node in control is expanded; that is, when its child nodes become visible.\r\n"
  176. Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  177. Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  178. Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  179. Event KeyDown(KeyCode As Integer, Shift As Integer)
  180. Event KeyPress(KeyAscii As Integer)
  181. Event KeyUp(KeyCode As Integer, Shift As Integer)
  182.  
  183. Private Sub Picture1_Click()
  184. On Error GoTo 0
  185.  
  186. '-------------------- Code Body Starts --------------------
  187. Dim PrevIdx As Integer
  188. PrevIdx = mOtlSet.SelectIdx
  189. 'these subs change the outline display, depending on the type of click registered in Mousedown
  190. OutlineClick OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  191.   
  192.   'If mOtlSet.ElementClicked > 0 And mOtlSet.CurrentLine <= mOtlSet.DisplayCount Then RaiseEvent Click(mOtlSet.SelectIdx)
  193.   If mOtlSet.CurrentLine <= mOtlSet.DisplayCount Then
  194.     If mOtlSet.LastType = 2 Then RaiseEvent Collapse(mOtlSet.SelectIdx)
  195.     If mOtlSet.LastType = 3 Then RaiseEvent Expand(mOtlSet.SelectIdx)
  196.   
  197.     If mOtlSet.SelectIdx = PrevIdx And mNodes.Count > 0 Then RaiseEvent NodeClick(mOtlSet.SelectIdx)
  198.   Else
  199.     mOtlSet.CurrentLine = mOtlSet.LastLine
  200.   End If
  201.   RaiseEvent Click
  202. '--------------------- Code Body Ends ---------------------
  203.     
  204.     Exit Sub
  205.     
  206. Picture1_Click_ErrorHandler:
  207.  
  208.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Picture1_Click", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  209.         Case vbAbort
  210.             Resume Exit_Picture1_Click
  211.         Case vbRetry
  212.             Resume
  213.         Case vbIgnore
  214.             Resume Next
  215.     End Select
  216.  
  217. Exit_Picture1_Click:
  218. End Sub
  219.  
  220. Private Sub Picture1_DblClick()
  221. On Error GoTo 0
  222.  
  223. '-------------------- Code Body Starts --------------------
  224.   If mOtlSet.ElementClicked > 0 And mOtlSet.CurrentLine <= mOtlSet.DisplayCount Then
  225.     RaiseEvent DblClick(mOtlSet.SelectIdx)
  226.   End If
  227. '--------------------- Code Body Ends ---------------------
  228.     
  229.     Exit Sub
  230.     
  231. Picture1_DblClick_ErrorHandler:
  232.  
  233.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Picture1_DblClick", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  234.         Case vbAbort
  235.             Resume Exit_Picture1_DblClick
  236.         Case vbRetry
  237.             Resume
  238.         Case vbIgnore
  239.             Resume Next
  240.     End Select
  241.  
  242. Exit_Picture1_DblClick:
  243. End Sub
  244.  
  245. Private Sub Picture1_KeyDown(KeyCode As Integer, Shift As Integer)
  246. On Error GoTo 0
  247.  
  248. '-------------------- Code Body Starts --------------------
  249. 'this routine handles cursor keys, page up, page down, +, -, etc.
  250. OutlineKeyPress KeyCode:=KeyCode, OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  251. 'Select Case KeyCode
  252. 'Case vbKeyUp, vbKeyDown, vbKeyPageUp, vbKeyPageDown, vbKeyHome, vbKeyEnd
  253.   'RaiseEvent Click()
  254. 'End Select
  255.   If mOtlSet.LastType = 2 Then RaiseEvent Collapse(mOtlSet.SelectIdx)
  256.   If mOtlSet.LastType = 3 Then RaiseEvent Expand(mOtlSet.SelectIdx)
  257.   RaiseEvent KeyDown(KeyCode, Shift)
  258. '--------------------- Code Body Ends ---------------------
  259.     
  260.     Exit Sub
  261.     
  262. Picture1_KeyDown_ErrorHandler:
  263.  
  264.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Picture1_KeyDown", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  265.         Case vbAbort
  266.             Resume Exit_Picture1_KeyDown
  267.         Case vbRetry
  268.             Resume
  269.         Case vbIgnore
  270.             Resume Next
  271.     End Select
  272.  
  273. Exit_Picture1_KeyDown:
  274. End Sub
  275.  
  276. Private Sub Picture1_KeyPress(KeyAscii As Integer)
  277. On Error GoTo 0
  278.  
  279. '-------------------- Code Body Starts --------------------
  280.   RaiseEvent KeyPress(KeyAscii)
  281. '--------------------- Code Body Ends ---------------------
  282.     
  283.     Exit Sub
  284.     
  285. Picture1_KeyPress_ErrorHandler:
  286.  
  287.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Picture1_KeyPress", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  288.         Case vbAbort
  289.             Resume Exit_Picture1_KeyPress
  290.         Case vbRetry
  291.             Resume
  292.         Case vbIgnore
  293.             Resume Next
  294.     End Select
  295.  
  296. Exit_Picture1_KeyPress:
  297. End Sub
  298.  
  299. Private Sub Picture1_KeyUp(KeyCode As Integer, Shift As Integer)
  300. On Error GoTo 0
  301.  
  302. '-------------------- Code Body Starts --------------------
  303.   RaiseEvent KeyUp(KeyCode, Shift)
  304. '--------------------- Code Body Ends ---------------------
  305.     
  306.     Exit Sub
  307.     
  308. Picture1_KeyUp_ErrorHandler:
  309.  
  310.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Picture1_KeyUp", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  311.         Case vbAbort
  312.             Resume Exit_Picture1_KeyUp
  313.         Case vbRetry
  314.             Resume
  315.         Case vbIgnore
  316.             Resume Next
  317.     End Select
  318.  
  319. Exit_Picture1_KeyUp:
  320. End Sub
  321.  
  322. Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  323. On Error GoTo 0
  324.  
  325. '-------------------- Code Body Starts --------------------
  326. 'this call deduces the line being clicked from Mousedown's x and y coordinates
  327. OutlineMouseDown2Line OtlSet:=mOtlSet, Otldat:=mNodes, y:=y, x:=x
  328. RaiseEvent MouseDown(Button, Shift, x, y)
  329. '--------------------- Code Body Ends ---------------------
  330.     
  331.     Exit Sub
  332.     
  333. Picture1_MouseDown_ErrorHandler:
  334.  
  335.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Picture1_MouseDown", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  336.         Case vbAbort
  337.             Resume Exit_Picture1_MouseDown
  338.         Case vbRetry
  339.             Resume
  340.         Case vbIgnore
  341.             Resume Next
  342.     End Select
  343.  
  344. Exit_Picture1_MouseDown:
  345. End Sub
  346.  
  347. Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  348. On Error GoTo 0
  349.  
  350. '-------------------- Code Body Starts --------------------
  351. RaiseEvent MouseMove(Button, Shift, x, y)
  352. '--------------------- Code Body Ends ---------------------
  353.     
  354.     Exit Sub
  355.     
  356. Picture1_MouseMove_ErrorHandler:
  357.  
  358.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Picture1_MouseMove", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  359.         Case vbAbort
  360.             Resume Exit_Picture1_MouseMove
  361.         Case vbRetry
  362.             Resume
  363.         Case vbIgnore
  364.             Resume Next
  365.     End Select
  366.  
  367. Exit_Picture1_MouseMove:
  368. End Sub
  369.  
  370. Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  371. On Error GoTo 0
  372.  
  373. '-------------------- Code Body Starts --------------------
  374. RaiseEvent MouseUp(Button, Shift, x, y)
  375. '--------------------- Code Body Ends ---------------------
  376.     
  377.     Exit Sub
  378.     
  379. Picture1_MouseUp_ErrorHandler:
  380.  
  381.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Picture1_MouseUp", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  382.         Case vbAbort
  383.             Resume Exit_Picture1_MouseUp
  384.         Case vbRetry
  385.             Resume
  386.         Case vbIgnore
  387.             Resume Next
  388.     End Select
  389.  
  390. Exit_Picture1_MouseUp:
  391. End Sub
  392.  
  393. Private Sub UserControl_Initialize()
  394. On Error GoTo 0
  395.  
  396. '-------------------- Code Body Starts --------------------
  397.   UserControl.Width = 2655: UserControl.Height = 3180
  398. '--------------------- Code Body Ends ---------------------
  399.     
  400.     Exit Sub
  401.     
  402. UserControl_Initialize_ErrorHandler:
  403.  
  404.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": UserControl_Initialize", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  405.         Case vbAbort
  406.             Resume Exit_UserControl_Initialize
  407.         Case vbRetry
  408.             Resume
  409.         Case vbIgnore
  410.             Resume Next
  411.     End Select
  412.  
  413. Exit_UserControl_Initialize:
  414. End Sub
  415.  
  416. Private Sub UserControl_InitProperties()
  417. On Error GoTo 0
  418.  
  419. '-------------------- Code Body Starts --------------------
  420.     m_BorderStyle = m_def_BorderStyle
  421.     m_BorderStyleInner = m_def_BorderStyleInner
  422.     
  423.     m_Plus = m_def_PlusSigns
  424.     m_Lines = m_def_Lines
  425.     m_CheckMarks = m_def_CheckMarks
  426.     m_AutoCheckParents = m_def_AutoCheckParents
  427.     m_Bitmaps = m_def_Bitmaps
  428.     m_AutoRefresh = True
  429.     m_NewIndex = m_def_NewIndex
  430.     m_SelectColor = m_def_SelectColor
  431.     m_SelectTextColor = m_def_SelectTextColor
  432.  
  433.    OrderByFields = ""
  434.    'specify bitmap logicals -- this should be done only once in a project
  435.    OutlineBmpSetup Image1(3), m_PictureOpen, Image1(0), m_PictureClosed, Image1(6), m_PictureItemNotSelected, Image1(8), m_PictureItemNotSelected
  436.  
  437.    'Checkmarks are used with multi-select
  438.    'OutlineBmpCheckedSetup BranchOpenAll:=Image1(4), BranchOpenSome:=Image1(5), BranchClosedAll:=Image1(1), BranchClosedSome:=Image1(2), LeafChecked:=Image1(7)
  439.    OutlineBmpCheckedSetup Image1(4), m_PictureOpenAll, Image1(1), m_PictureClosedAll, Image1(5), m_PictureOpenSome, Image1(2), m_PictureClosedSome, Image1(7), m_PictureItemSelected
  440.  
  441. mOtlSet.Levels = 2
  442.  
  443. 'test Nodes collection
  444. AddNode "Level1", 0, True
  445. AddNode "SubLevel1", 1, False
  446. AddNode "SubLevel2", 1, False
  447. AddNode "Level2", 0, False
  448.    
  449. '--------------------- Code Body Ends ---------------------
  450.     
  451.     Exit Sub
  452.     
  453. UserControl_InitProperties_ErrorHandler:
  454.  
  455.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": UserControl_InitProperties", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  456.         Case vbAbort
  457.             Resume Exit_UserControl_InitProperties
  458.         Case vbRetry
  459.             Resume
  460.         Case vbIgnore
  461.             Resume Next
  462.     End Select
  463.  
  464. Exit_UserControl_InitProperties:
  465. End Sub
  466.  
  467. Private Sub UserControl_Resize()
  468. On Error GoTo 0
  469.  
  470. '-------------------- Code Body Starts --------------------
  471.   '*******************************************************************************************************
  472.   'GMG 980811 :
  473.   '   lets check to see if we have borders. if not, move the picture outward a little.
  474.   '   also, change the width and height adjustments to be a little more safe...
  475.  
  476.     If (m_BorderStyle = AxBorderStyles.[No Border]) And (m_BorderStyleInner = InnerBorderStyles.[iNo Border]) Then
  477.        Picture1.Move 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight
  478.     ElseIf m_BorderStyleInner = axTreeControl.InnerBorderStyles.[iNo Border] Then
  479.         Picture1.Move 30, 30, IIf(UserControl.ScaleWidth - 55 <= 0, 0, UserControl.ScaleWidth - 55), IIf(UserControl.ScaleHeight - 55 <= 0, 0, UserControl.ScaleHeight - 55)
  480.     Else
  481.         Picture1.Move 80, 80, IIf(UserControl.ScaleWidth - 145 <= 0, 0, UserControl.ScaleWidth - 145), IIf(UserControl.ScaleHeight - 145 <= 0, 0, UserControl.ScaleHeight - 145)
  482.     End If
  483.   
  484.   'Picture1.Move 80, 80, IIf(UserControl.ScaleWidth = 0, 0, UserControl.ScaleWidth - 145), IIf(UserControl.ScaleHeight = 0, 0, UserControl.ScaleHeight - 145)
  485.   '*******************************************************************************************************
  486.   
  487.   'VScroll1.Move Picture1.Width - VScroll1.Width, 0, VScroll1.Width, Picture1.Height - 15
  488.   
  489.   UserControl.Cls
  490.   UserControl_Paint
  491.    
  492.   If mNodes.Count > 0 Then
  493.     'Set outline "properties"
  494.     OutlineSetup OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, DataFields:=OrderByFields, Bmps:=m_Bitmaps, Lines:=m_Lines, Plus:=m_Plus, Checkmarks:=m_CheckMarks, SelectColor:=m_SelectColor, SelectTextColor:=m_SelectTextColor, BmpField:="", CheckmarkField:=""
  495.     'display the outline
  496.     OutlineRefresh Picture1, VScroll1, mOtlSet, mNodes
  497.   End If
  498. '--------------------- Code Body Ends ---------------------
  499.     
  500.     Exit Sub
  501.     
  502. UserControl_Resize_ErrorHandler:
  503.  
  504.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": UserControl_Resize", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  505.         Case vbAbort
  506.             Resume Exit_UserControl_Resize
  507.         Case vbRetry
  508.             Resume
  509.         Case vbIgnore
  510.             Resume Next
  511.     End Select
  512.  
  513. Exit_UserControl_Resize:
  514. End Sub
  515.  
  516. 'Load property values from storage
  517. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  518. On Error GoTo 0
  519.  
  520. '-------------------- Code Body Starts --------------------
  521.    Dim mCaption As String, mLevel As Integer, mVisible As Integer, mExpanded As Integer
  522.    Dim mVisibleIdx As Long, mBookmark As Variant, mBitmap As Picture, mSelected As Integer
  523.    Dim mSyncIdx As Integer, mItemData As Long, mIsParent As Boolean
  524.    Dim OldRefresh As Boolean
  525.    
  526.    'GMG 980818 : added this:
  527.    Dim iTotCnt As Long
  528.    Dim Index As Long
  529.    
  530.    OrderByFields = ""
  531.     
  532.     UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
  533.     m_BorderStyle = PropBag.ReadProperty("BorderStyle", m_def_BorderStyle)
  534.     
  535.     m_BorderStyleInner = PropBag.ReadProperty("BorderStyleInner", m_def_BorderStyleInner)
  536.     'Picture1.BorderStyle = m_BorderStyleInner
  537.     
  538.     m_Plus = PropBag.ReadProperty("ShowPlusSigns", m_def_PlusSigns)
  539.     If m_Plus Then mOtlSet.PlusFlag = 1 Else mOtlSet.PlusFlag = 0
  540.     
  541.     m_CheckMarks = PropBag.ReadProperty("CheckMarks", m_def_CheckMarks)
  542.     mOtlSet.CheckmarkFlag = m_CheckMarks
  543.     
  544.     m_AutoCheckParents = PropBag.ReadProperty("AutoCheckParents", m_def_AutoCheckParents)
  545.     mOtlSet.AutoCheckParents = m_AutoCheckParents
  546.     
  547.     m_Lines = PropBag.ReadProperty("ShowLines", m_def_Lines)
  548.     If m_Lines Then mOtlSet.LineFlag = 1 Else mOtlSet.LineFlag = 0
  549.     
  550.     m_Bitmaps = PropBag.ReadProperty("ShowBitmaps", m_def_Bitmaps)
  551.     If m_Bitmaps Then mOtlSet.BmpFlag = 1 Else mOtlSet.BmpFlag = 0
  552.     
  553.     Set Font = PropBag.ReadProperty("Font", Ambient.Font)
  554.     
  555.     m_SelectColor = PropBag.ReadProperty("SelectColor", m_def_SelectColor)
  556.     m_SelectTextColor = PropBag.ReadProperty("SelectTextColor", m_def_SelectTextColor)
  557.  
  558.     Set m_PictureItemNotSelected = PropBag.ReadProperty("PictureItemNotSelected", Nothing)
  559.     Set m_PictureItemSelected = PropBag.ReadProperty("PictureItemSelected", Nothing)
  560.     Set m_PictureOpen = PropBag.ReadProperty("PictureOpen", Nothing)
  561.     Set m_PictureOpenSome = PropBag.ReadProperty("PictureOpenSome", Nothing)
  562.     Set m_PictureOpenAll = PropBag.ReadProperty("PictureOpenAll", Nothing)
  563.     Set m_PictureClosed = PropBag.ReadProperty("PictureClosed", Nothing)
  564.     Set m_PictureClosedSome = PropBag.ReadProperty("PictureClosedSome", Nothing)
  565.     Set m_PictureClosedAll = PropBag.ReadProperty("PictureClosedAll", Nothing)
  566.     m_AutoRefresh = PropBag.ReadProperty("AutoRefresh", True)
  567.     
  568.     OldRefresh = m_AutoRefresh
  569.     m_AutoRefresh = False
  570.     mOtlSet.Levels = 2
  571.     mOtlSet.VisChangeFlag = True
  572.     Clear
  573.     
  574. '*******************************************************************
  575. 'GMG 980811:
  576. '   I don't want this to happen at all if the program is running:
  577.     If Not UserControl.Ambient.UserMode Then
  578.  
  579.         iTotCnt = PropBag.ReadProperty("Count", 0)
  580.         'ReDim mOtlData(totcnt)
  581.         For Index = 1 To iTotCnt
  582.           mBookmark = PropBag.ReadProperty("List_1" & Index)
  583.           mCaption = PropBag.ReadProperty("List_2" & Index)
  584.           mExpanded = PropBag.ReadProperty("List_3" & Index)
  585.           mIsParent = PropBag.ReadProperty("List_4" & Index)
  586.           mItemData = PropBag.ReadProperty("List_5" & Index)
  587.           mLevel = PropBag.ReadProperty("List_6" & Index)
  588.           mSelected = PropBag.ReadProperty("List_7" & Index)
  589.           mSyncIdx = PropBag.ReadProperty("List_8" & Index)
  590.           mVisible = PropBag.ReadProperty("List_9" & Index)
  591.           mVisibleIdx = PropBag.ReadProperty("List_10" & Index)
  592.           AddNode mCaption, mLevel, mIsParent, , , mBookmark, mItemData, , mVisible, mExpanded, mVisibleIdx, mSelected, mSyncIdx
  593.         Next
  594.     
  595.     Else
  596.     
  597.         iTotCnt = 0
  598.         
  599.     End If
  600.     
  601.     m_AutoRefresh = OldRefresh
  602.        
  603.    'specify bitmap logicals -- this should be done only once in a project
  604.    'OutlineBmpSetup BranchOpen:=Image1(3), BoFile:="", BranchClosed:=Image1(0), BcFile:="", Leaf:=Image1(6), LFile:="", CustomPic:=Image1(8)
  605.    OutlineBmpSetup Image1(3), m_PictureOpen, Image1(0), m_PictureClosed, Image1(6), m_PictureItemNotSelected, Image1(8), m_PictureItemNotSelected
  606.  
  607.    'Checkmarks are used with multi-select
  608.    OutlineBmpCheckedSetup Image1(4), m_PictureOpenAll, Image1(1), m_PictureClosedAll, Image1(5), m_PictureOpenSome, Image1(2), m_PictureClosedSome, Image1(7), m_PictureItemSelected
  609.    
  610.    'Set outline "properties"
  611.    OutlineSetup OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, DataFields:=OrderByFields, Bmps:=m_Bitmaps, Lines:=m_Lines, Plus:=m_Plus, Checkmarks:=m_CheckMarks, SelectColor:=m_SelectColor, SelectTextColor:=m_SelectTextColor, BmpField:="", CheckmarkField:=""
  612.    'redisplay the outline
  613.    OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  614.     
  615. 'GMG 980811: (Added this)
  616.    Call UserControl_Resize
  617.     
  618.     
  619. '--------------------- Code Body Ends ---------------------
  620.     
  621.     Exit Sub
  622.     
  623. UserControl_ReadProperties_ErrorHandler:
  624.  
  625.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": UserControl_ReadProperties", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  626.         Case vbAbort
  627.             Resume Exit_UserControl_ReadProperties
  628.         Case vbRetry
  629.             Resume
  630.         Case vbIgnore
  631.             Resume Next
  632.     End Select
  633.  
  634. Exit_UserControl_ReadProperties:
  635. End Sub
  636.  
  637. 'Write property values to storage
  638. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  639. On Error GoTo 0
  640.  
  641. '-------------------- Code Body Starts --------------------
  642.    'GMG 980818 : added this:
  643.    Dim Index As Long
  644.     
  645.     Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
  646.     Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, m_def_BorderStyle)
  647.     Call PropBag.WriteProperty("BorderStyleInner", m_BorderStyleInner, m_def_BorderStyleInner)
  648.     Call PropBag.WriteProperty("ShowPlusSigns", m_Plus, m_def_PlusSigns)
  649.     Call PropBag.WriteProperty("CheckMarks", m_CheckMarks, m_def_CheckMarks)
  650.     Call PropBag.WriteProperty("AutoCheckParents", m_AutoCheckParents, m_def_AutoCheckParents)
  651.     Call PropBag.WriteProperty("ShowLines", m_Lines, m_def_Lines)
  652.     Call PropBag.WriteProperty("ShowBitmaps", m_Bitmaps, m_def_Bitmaps)
  653.     Call PropBag.WriteProperty("Font", Font, Ambient.Font)
  654.     Call PropBag.WriteProperty("SelectColor", m_SelectColor, m_def_SelectColor)
  655.     Call PropBag.WriteProperty("SelectTextColor", m_SelectTextColor, m_def_SelectTextColor)
  656.     
  657.     Call PropBag.WriteProperty("PictureItemNotSelected", m_PictureItemNotSelected, "")
  658.     Call PropBag.WriteProperty("PictureItemSelected", m_PictureItemSelected, "")
  659.     Call PropBag.WriteProperty("PictureOpen", m_PictureOpen, "")
  660.     Call PropBag.WriteProperty("PictureOpenSome", m_PictureOpenSome, "")
  661.     Call PropBag.WriteProperty("PictureOpenAll", m_PictureOpenAll, "")
  662.     Call PropBag.WriteProperty("PictureClosed", m_PictureClosed, "")
  663.     Call PropBag.WriteProperty("PictureClosedSome", m_PictureClosedSome, "")
  664.     Call PropBag.WriteProperty("PictureClosedAll", m_PictureClosedAll, "")
  665.     Call PropBag.WriteProperty("AutoRefresh", m_AutoRefresh, True)
  666.  
  667.     If Not UserControl.Ambient.UserMode Then
  668.     Call PropBag.WriteProperty("Count", mNodes.Count, 0)
  669.     For Index = 1 To mNodes.Count
  670.       Call PropBag.WriteProperty("List_1" & Index, mNodes(Index).Bookmark)
  671.       Call PropBag.WriteProperty("List_2" & Index, mNodes(Index).Caption)
  672.       Call PropBag.WriteProperty("List_3" & Index, mNodes(Index).Expanded)
  673.       Call PropBag.WriteProperty("List_4" & Index, mNodes(Index).IsParent)
  674.       Call PropBag.WriteProperty("List_5" & Index, mNodes(Index).Itemdata)
  675.       Call PropBag.WriteProperty("List_6" & Index, mNodes(Index).Level)
  676.       Call PropBag.WriteProperty("List_7" & Index, mNodes(Index).Selected)
  677.       Call PropBag.WriteProperty("List_8" & Index, mNodes(Index).SyncIdx)
  678.       Call PropBag.WriteProperty("List_9" & Index, mNodes(Index).Visible)
  679.       Call PropBag.WriteProperty("List_10" & Index, mNodes(Index).VisibleIdx)
  680.     Next
  681.     End If
  682.     
  683. '--------------------- Code Body Ends ---------------------
  684.     
  685.     Exit Sub
  686.     
  687. UserControl_WriteProperties_ErrorHandler:
  688.  
  689.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": UserControl_WriteProperties", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  690.         Case vbAbort
  691.             Resume Exit_UserControl_WriteProperties
  692.         Case vbRetry
  693.             Resume
  694.         Case vbIgnore
  695.             Resume Next
  696.     End Select
  697.  
  698. Exit_UserControl_WriteProperties:
  699. End Sub
  700.  
  701. Public Sub ShowAbout()
  702. Attribute ShowAbout.VB_Description = "Show about box for control"
  703. Attribute ShowAbout.VB_UserMemId = -552
  704. On Error GoTo 0
  705.  
  706. '-------------------- Code Body Starts --------------------
  707.   frmAbout.Show vbModal
  708. '--------------------- Code Body Ends ---------------------
  709.     
  710.     Exit Sub
  711.     
  712. ShowAbout_ErrorHandler:
  713.  
  714.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": ShowAbout", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  715.         Case vbAbort
  716.             Resume Exit_ShowAbout
  717.         Case vbRetry
  718.             Resume
  719.         Case vbIgnore
  720.             Resume Next
  721.     End Select
  722.  
  723. Exit_ShowAbout:
  724. End Sub
  725. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  726. 'MappingInfo=UserControl,UserControl,-1,Enabled
  727. Public Property Get Enabled() As Boolean
  728. Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events\r\n"
  729. On Error GoTo 0
  730.  
  731. '-------------------- Code Body Starts --------------------
  732.     Enabled = UserControl.Enabled
  733. '--------------------- Code Body Ends ---------------------
  734.     
  735.     Exit Property
  736.     
  737. Enabled_ErrorHandler:
  738.  
  739.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Enabled", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  740.         Case vbAbort
  741.             Resume Exit_Enabled
  742.         Case vbRetry
  743.             Resume
  744.         Case vbIgnore
  745.             Resume Next
  746.     End Select
  747.  
  748. Exit_Enabled:
  749. End Property
  750.  
  751. Public Property Let Enabled(ByVal New_Enabled As Boolean)
  752. On Error GoTo 0
  753.  
  754. '-------------------- Code Body Starts --------------------
  755.     UserControl.Enabled() = New_Enabled
  756.     PropertyChanged "Enabled"
  757. '--------------------- Code Body Ends ---------------------
  758.     
  759.     Exit Property
  760.     
  761. Enabled_ErrorHandler:
  762.  
  763.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Enabled", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  764.         Case vbAbort
  765.             Resume Exit_Enabled
  766.         Case vbRetry
  767.             Resume
  768.         Case vbIgnore
  769.             Resume Next
  770.     End Select
  771.  
  772. Exit_Enabled:
  773. End Property
  774.  
  775. Public Property Get BorderStyle() As AxBorderStyles
  776. Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object"
  777. On Error GoTo 0
  778.  
  779. '-------------------- Code Body Starts --------------------
  780.     BorderStyle = m_BorderStyle
  781. '--------------------- Code Body Ends ---------------------
  782.     
  783.     Exit Property
  784.     
  785. BorderStyle_ErrorHandler:
  786.  
  787.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": BorderStyle", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  788.         Case vbAbort
  789.             Resume Exit_BorderStyle
  790.         Case vbRetry
  791.             Resume
  792.         Case vbIgnore
  793.             Resume Next
  794.     End Select
  795.  
  796. Exit_BorderStyle:
  797. End Property
  798. Public Property Let BorderStyle(ByVal New_BorderStyle As AxBorderStyles)
  799. On Error GoTo 0
  800.  
  801. '-------------------- Code Body Starts --------------------
  802.     If Not (m_BorderStyle = New_BorderStyle) Then
  803.         m_BorderStyle = New_BorderStyle
  804.       '************************************
  805.       'GMG 980811 :
  806.               Call UserControl_Resize
  807.               
  808.       '        UserControl.Cls
  809.       '        UserControl_Paint
  810.       '************************************
  811.     End If
  812.     PropertyChanged "BorderStyle"
  813. '--------------------- Code Body Ends ---------------------
  814.     
  815.     Exit Property
  816.     
  817. BorderStyle_ErrorHandler:
  818.  
  819.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": BorderStyle", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  820.         Case vbAbort
  821.             Resume Exit_BorderStyle
  822.         Case vbRetry
  823.             Resume
  824.         Case vbIgnore
  825.             Resume Next
  826.     End Select
  827.  
  828. Exit_BorderStyle:
  829. End Property
  830.  
  831. Public Property Get BorderStyleInner() As InnerBorderStyles
  832. Attribute BorderStyleInner.VB_Description = "Returns/set the inner border style for the control"
  833. On Error GoTo 0
  834.  
  835. '-------------------- Code Body Starts --------------------
  836.     BorderStyleInner = m_BorderStyleInner
  837. '--------------------- Code Body Ends ---------------------
  838.     
  839.     Exit Property
  840.     
  841. BorderStyleInner_ErrorHandler:
  842.  
  843.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": BorderStyleInner", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  844.         Case vbAbort
  845.             Resume Exit_BorderStyleInner
  846.         Case vbRetry
  847.             Resume
  848.         Case vbIgnore
  849.             Resume Next
  850.     End Select
  851.  
  852. Exit_BorderStyleInner:
  853. End Property
  854.  
  855. Public Property Let BorderStyleInner(ByVal New_InnerBorder As InnerBorderStyles)
  856. On Error GoTo 0
  857.  
  858. '-------------------- Code Body Starts --------------------
  859.     'm_BorderStyleInner = New_InnerBorder
  860.     'Picture1.BorderStyle = New_InnerBorder
  861.     If Not (m_BorderStyleInner = New_InnerBorder) Then
  862.         m_BorderStyleInner = New_InnerBorder
  863.       '************************************
  864.       'GMG 980811 :
  865.               Call UserControl_Resize
  866.               
  867.       '        UserControl.Cls
  868.       '        UserControl_Paint
  869.       '************************************
  870.     End If
  871.     PropertyChanged "BorderStyleInner"
  872. '--------------------- Code Body Ends ---------------------
  873.     
  874.     Exit Property
  875.     
  876. BorderStyleInner_ErrorHandler:
  877.  
  878.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": BorderStyleInner", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  879.         Case vbAbort
  880.             Resume Exit_BorderStyleInner
  881.         Case vbRetry
  882.             Resume
  883.         Case vbIgnore
  884.             Resume Next
  885.     End Select
  886.  
  887. Exit_BorderStyleInner:
  888. End Property
  889.  
  890. Public Property Get ShowPlusSigns() As Boolean
  891. Attribute ShowPlusSigns.VB_Description = "Returns/sets a value to determine whether the parent indicators (plus signs) are displayed on control.\r\n"
  892. On Error GoTo 0
  893.  
  894. '-------------------- Code Body Starts --------------------
  895.     ShowPlusSigns = m_Plus
  896. '--------------------- Code Body Ends ---------------------
  897.     
  898.     Exit Property
  899.     
  900. ShowPlusSigns_ErrorHandler:
  901.  
  902.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": ShowPlusSigns", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  903.         Case vbAbort
  904.             Resume Exit_ShowPlusSigns
  905.         Case vbRetry
  906.             Resume
  907.         Case vbIgnore
  908.             Resume Next
  909.     End Select
  910.  
  911. Exit_ShowPlusSigns:
  912. End Property
  913. Public Property Let ShowPlusSigns(ByVal New_ShowPlusSigns As Boolean)
  914. On Error GoTo 0
  915.  
  916. '-------------------- Code Body Starts --------------------
  917.     If Not (m_Plus = New_ShowPlusSigns) Then
  918.         m_Plus = New_ShowPlusSigns
  919.         
  920.         If m_Plus Then mOtlSet.PlusFlag = 1 Else mOtlSet.PlusFlag = 0
  921.         mOtlSet.VisChangeFlag = True
  922.         OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  923.     End If
  924.     PropertyChanged "ShowPlusSigns"
  925. '--------------------- Code Body Ends ---------------------
  926.     
  927.     Exit Property
  928.     
  929. ShowPlusSigns_ErrorHandler:
  930.  
  931.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": ShowPlusSigns", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  932.         Case vbAbort
  933.             Resume Exit_ShowPlusSigns
  934.         Case vbRetry
  935.             Resume
  936.         Case vbIgnore
  937.             Resume Next
  938.     End Select
  939.  
  940. Exit_ShowPlusSigns:
  941. End Property
  942.  
  943. Public Property Get ShowBitmaps() As Boolean
  944. On Error GoTo 0
  945.  
  946. '-------------------- Code Body Starts --------------------
  947.     ShowBitmaps = m_Bitmaps
  948. '--------------------- Code Body Ends ---------------------
  949.     
  950.     Exit Property
  951.     
  952. ShowBitmaps_ErrorHandler:
  953.  
  954.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": ShowBitmaps", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  955.         Case vbAbort
  956.             Resume Exit_ShowBitmaps
  957.         Case vbRetry
  958.             Resume
  959.         Case vbIgnore
  960.             Resume Next
  961.     End Select
  962.  
  963. Exit_ShowBitmaps:
  964. End Property
  965. Public Property Let ShowBitmaps(ByVal New_ShowBitmaps As Boolean)
  966. On Error GoTo 0
  967.  
  968. '-------------------- Code Body Starts --------------------
  969.     If Not (m_Bitmaps = New_ShowBitmaps) Then
  970.         m_Bitmaps = New_ShowBitmaps
  971.         
  972.         If m_Bitmaps Then mOtlSet.BmpFlag = 1 Else mOtlSet.BmpFlag = 0
  973.         mOtlSet.VisChangeFlag = True
  974.         OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  975.     End If
  976.     PropertyChanged "ShowBitmaps"
  977. '--------------------- Code Body Ends ---------------------
  978.     
  979.     Exit Property
  980.     
  981. ShowBitmaps_ErrorHandler:
  982.  
  983.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": ShowBitmaps", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  984.         Case vbAbort
  985.             Resume Exit_ShowBitmaps
  986.         Case vbRetry
  987.             Resume
  988.         Case vbIgnore
  989.             Resume Next
  990.     End Select
  991.  
  992. Exit_ShowBitmaps:
  993. End Property
  994.  
  995. Public Property Get ShowLines() As Boolean
  996. Attribute ShowLines.VB_Description = "Returns/sets a value to determine whether node lines are displayed on control.\r\n"
  997. On Error GoTo 0
  998.  
  999. '-------------------- Code Body Starts --------------------
  1000.     ShowLines = m_Lines
  1001. '--------------------- Code Body Ends ---------------------
  1002.     
  1003.     Exit Property
  1004.     
  1005. ShowLines_ErrorHandler:
  1006.  
  1007.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": ShowLines", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1008.         Case vbAbort
  1009.             Resume Exit_ShowLines
  1010.         Case vbRetry
  1011.             Resume
  1012.         Case vbIgnore
  1013.             Resume Next
  1014.     End Select
  1015.  
  1016. Exit_ShowLines:
  1017. End Property
  1018. Public Property Let ShowLines(ByVal New_ShowLines As Boolean)
  1019. On Error GoTo 0
  1020.  
  1021. '-------------------- Code Body Starts --------------------
  1022.     If Not (m_Lines = New_ShowLines) Then
  1023.         m_Lines = New_ShowLines
  1024.         
  1025.         If m_Lines Then mOtlSet.LineFlag = 1 Else mOtlSet.LineFlag = 0
  1026.         mOtlSet.VisChangeFlag = True
  1027.         OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1028.     End If
  1029.     PropertyChanged "ShowLines"
  1030. '--------------------- Code Body Ends ---------------------
  1031.     
  1032.     Exit Property
  1033.     
  1034. ShowLines_ErrorHandler:
  1035.  
  1036.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": ShowLines", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1037.         Case vbAbort
  1038.             Resume Exit_ShowLines
  1039.         Case vbRetry
  1040.             Resume
  1041.         Case vbIgnore
  1042.             Resume Next
  1043.     End Select
  1044.  
  1045. Exit_ShowLines:
  1046. End Property
  1047.  
  1048. Public Property Get Checkmarks() As Boolean
  1049. Attribute Checkmarks.VB_Description = "Returns/sets a value to determine if user has the ability to mark multiple lines in the hierarchy list\r\n"
  1050. On Error GoTo 0
  1051.  
  1052. '-------------------- Code Body Starts --------------------
  1053.     Checkmarks = m_CheckMarks
  1054. '--------------------- Code Body Ends ---------------------
  1055.     
  1056.     Exit Property
  1057.     
  1058. Checkmarks_ErrorHandler:
  1059.  
  1060.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Checkmarks", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1061.         Case vbAbort
  1062.             Resume Exit_Checkmarks
  1063.         Case vbRetry
  1064.             Resume
  1065.         Case vbIgnore
  1066.             Resume Next
  1067.     End Select
  1068.  
  1069. Exit_Checkmarks:
  1070. End Property
  1071. Public Property Let Checkmarks(ByVal New_CheckMarks As Boolean)
  1072. On Error GoTo 0
  1073.  
  1074. '-------------------- Code Body Starts --------------------
  1075.     If Not (m_CheckMarks = New_CheckMarks) Then
  1076.         m_CheckMarks = New_CheckMarks
  1077.         
  1078.         mOtlSet.CheckmarkFlag = m_CheckMarks
  1079.         OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1080.     End If
  1081.     PropertyChanged "CheckMarks"
  1082. '--------------------- Code Body Ends ---------------------
  1083.     
  1084.     Exit Property
  1085.     
  1086. Checkmarks_ErrorHandler:
  1087.  
  1088.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Checkmarks", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1089.         Case vbAbort
  1090.             Resume Exit_Checkmarks
  1091.         Case vbRetry
  1092.             Resume
  1093.         Case vbIgnore
  1094.             Resume Next
  1095.     End Select
  1096.  
  1097. Exit_Checkmarks:
  1098. End Property
  1099.  
  1100. Public Property Get AutoCheckParents() As Boolean
  1101. Attribute AutoCheckParents.VB_Description = "Used to determine if parents will automatically be selected when a child is selected if control is setup to select multiple nodes"
  1102. On Error GoTo 0
  1103.  
  1104. '-------------------- Code Body Starts --------------------
  1105.     AutoCheckParents = m_AutoCheckParents
  1106. '--------------------- Code Body Ends ---------------------
  1107.     
  1108.     Exit Property
  1109.     
  1110. AutoCheckParents_ErrorHandler:
  1111.  
  1112.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": AutoCheckParents", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1113.         Case vbAbort
  1114.             Resume Exit_AutoCheckParents
  1115.         Case vbRetry
  1116.             Resume
  1117.         Case vbIgnore
  1118.             Resume Next
  1119.     End Select
  1120.  
  1121. Exit_AutoCheckParents:
  1122. End Property
  1123. Public Property Let AutoCheckParents(ByVal New_value As Boolean)
  1124. On Error GoTo 0
  1125.  
  1126. '-------------------- Code Body Starts --------------------
  1127.     m_AutoCheckParents = New_value
  1128.     mOtlSet.AutoCheckParents = m_AutoCheckParents
  1129.     PropertyChanged "AutoCheckParents"
  1130. '--------------------- Code Body Ends ---------------------
  1131.     
  1132.     Exit Property
  1133.     
  1134. AutoCheckParents_ErrorHandler:
  1135.  
  1136.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": AutoCheckParents", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1137.         Case vbAbort
  1138.             Resume Exit_AutoCheckParents
  1139.         Case vbRetry
  1140.             Resume
  1141.         Case vbIgnore
  1142.             Resume Next
  1143.     End Select
  1144.  
  1145. Exit_AutoCheckParents:
  1146. End Property
  1147.  
  1148. Private Sub UserControl_Paint()
  1149. On Error GoTo 0
  1150.  
  1151. '-------------------- Code Body Starts --------------------
  1152.     Dim di As Long
  1153.     Dim rc As RECT
  1154.     Dim xTwips As Integer, yTwips As Integer
  1155.     
  1156.     xTwips = Screen.TwipsPerPixelX
  1157.     yTwips = Screen.TwipsPerPixelY
  1158.     
  1159.     'draw outside border
  1160.         
  1161.     'get dimensions of usercontrol
  1162.     di = GetClientRect(UserControl.hwnd, rc)
  1163.     
  1164.     Select Case m_BorderStyle
  1165.         Case [No Border]
  1166.         
  1167.         Case [Single]
  1168.             di = DrawEdge(UserControl.hDC, rc, BDR_RAISEDOUTER, BF_RECT Or BF_MONO)
  1169.             
  1170.         Case [Thin Raised]
  1171.             di = DrawEdge(UserControl.hDC, rc, BDR_RAISEDINNER, BF_TOPLEFT)
  1172.             di = DrawEdge(UserControl.hDC, rc, BDR_RAISEDOUTER, BF_BOTTOMRIGHT)
  1173.         
  1174.         Case [Thick Raised]
  1175.             di = DrawEdge(UserControl.hDC, rc, EDGE_RAISED, BF_TOPLEFT)
  1176.             di = DrawEdge(UserControl.hDC, rc, EDGE_RAISED, BF_BOTTOMRIGHT)
  1177.     
  1178.         Case [Thin Inset]
  1179.             di = DrawEdge(UserControl.hDC, rc, BDR_SUNKENINNER, BF_TOPLEFT)
  1180.             di = DrawEdge(UserControl.hDC, rc, BDR_SUNKENOUTER, BF_BOTTOMRIGHT)
  1181.         
  1182.         Case [Thick Inset]
  1183.             di = DrawEdge(UserControl.hDC, rc, EDGE_SUNKEN, BF_TOPLEFT)
  1184.             di = DrawEdge(UserControl.hDC, rc, EDGE_SUNKEN, BF_BOTTOMRIGHT)
  1185.         
  1186.         Case [Etched]
  1187.             di = DrawEdge(UserControl.hDC, rc, EDGE_ETCHED, BF_TOPLEFT)
  1188.             di = DrawEdge(UserControl.hDC, rc, EDGE_ETCHED, BF_BOTTOMRIGHT)
  1189.     
  1190.         Case [Bump]
  1191.             di = DrawEdge(UserControl.hDC, rc, EDGE_BUMP, BF_TOPLEFT)
  1192.             di = DrawEdge(UserControl.hDC, rc, EDGE_BUMP, BF_BOTTOMRIGHT)
  1193.             
  1194.     End Select
  1195.         
  1196.     'get dimensions of picture1
  1197.     di = GetClientRect(Picture1.hwnd, rc)
  1198.     rc.Left = 40 / xTwips: rc.Top = 40 / yTwips
  1199.     rc.Right = Picture1.Left / xTwips + Picture1.Width / xTwips + 40 / xTwips
  1200.     rc.Bottom = Picture1.Top / yTwips + Picture1.Height / yTwips + 40 / yTwips
  1201.     
  1202.     Select Case m_BorderStyleInner
  1203.             
  1204.         Case [iNo Border]
  1205.         
  1206.         Case [iSingle]
  1207.             di = DrawEdge(UserControl.hDC, rc, BDR_RAISEDOUTER, BF_RECT Or BF_MONO)
  1208.         
  1209.         Case [iThin Raised]
  1210.             di = DrawEdge(UserControl.hDC, rc, BDR_RAISEDINNER, BF_TOPLEFT)
  1211.             di = DrawEdge(UserControl.hDC, rc, BDR_RAISEDOUTER, BF_BOTTOMRIGHT)
  1212.         
  1213.         Case [iThick Raised]
  1214.             di = DrawEdge(UserControl.hDC, rc, EDGE_RAISED, BF_TOPLEFT)
  1215.             di = DrawEdge(UserControl.hDC, rc, EDGE_RAISED, BF_BOTTOMRIGHT)
  1216.     
  1217.         Case [iThin Inset]
  1218.             di = DrawEdge(UserControl.hDC, rc, BDR_SUNKENINNER, BF_TOPLEFT)
  1219.             di = DrawEdge(UserControl.hDC, rc, BDR_SUNKENOUTER, BF_BOTTOMRIGHT)
  1220.         
  1221.         Case [iThick Inset]
  1222.             di = DrawEdge(UserControl.hDC, rc, EDGE_SUNKEN, BF_TOPLEFT)
  1223.             di = DrawEdge(UserControl.hDC, rc, EDGE_SUNKEN, BF_BOTTOMRIGHT)
  1224.     
  1225.     End Select
  1226.     
  1227. '--------------------- Code Body Ends ---------------------
  1228.     
  1229.     Exit Sub
  1230.     
  1231. UserControl_Paint_ErrorHandler:
  1232.  
  1233.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": UserControl_Paint", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1234.         Case vbAbort
  1235.             Resume Exit_UserControl_Paint
  1236.         Case vbRetry
  1237.             Resume
  1238.         Case vbIgnore
  1239.             Resume Next
  1240.     End Select
  1241.  
  1242. Exit_UserControl_Paint:
  1243. End Sub
  1244.  
  1245.  
  1246. Private Sub VScroll1_Change()
  1247. On Error GoTo 0
  1248.  
  1249. '-------------------- Code Body Starts --------------------
  1250. 'page or scroll the display based on scrollbar clicks
  1251. OutlineScroll ScrollValue:=VScroll1.value, OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1252. If mNodes.Count > 0 Then RaiseEvent NodeClick(mOtlSet.SelectIdx)
  1253. '--------------------- Code Body Ends ---------------------
  1254.     
  1255.     Exit Sub
  1256.     
  1257. VScroll1_Change_ErrorHandler:
  1258.  
  1259.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": VScroll1_Change", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1260.         Case vbAbort
  1261.             Resume Exit_VScroll1_Change
  1262.         Case vbRetry
  1263.             Resume
  1264.         Case vbIgnore
  1265.             Resume Next
  1266.     End Select
  1267.  
  1268. Exit_VScroll1_Change:
  1269. End Sub
  1270.  
  1271. Public Property Get SelectedItem() As Integer
  1272. Attribute SelectedItem.VB_Description = "Returns/sets the currently selected node object\r\n"
  1273. Attribute SelectedItem.VB_MemberFlags = "400"
  1274. On Error GoTo 0
  1275.  
  1276. '-------------------- Code Body Starts --------------------
  1277.     SelectedItem = mOtlSet.SelectIdx
  1278. '--------------------- Code Body Ends ---------------------
  1279.     
  1280.     Exit Property
  1281.     
  1282. SelectedItem_ErrorHandler:
  1283.  
  1284.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": SelectedItem", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1285.         Case vbAbort
  1286.             Resume Exit_SelectedItem
  1287.         Case vbRetry
  1288.             Resume
  1289.         Case vbIgnore
  1290.             Resume Next
  1291.     End Select
  1292.  
  1293. Exit_SelectedItem:
  1294. End Property
  1295. Public Property Let SelectedItem(ByVal New_SelectedItem As Integer)
  1296. On Error GoTo 0
  1297.  
  1298. '-------------------- Code Body Starts --------------------
  1299.         'OtlSet.SelectIdx = New_SelectedItem
  1300.             
  1301.   OutlineGoto New_SelectedItem, Picture1, VScroll1, mOtlSet, mNodes
  1302.     
  1303. '    OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, OtlDat:=mNodes
  1304.     PropertyChanged "SelectedItem"
  1305. '--------------------- Code Body Ends ---------------------
  1306.     
  1307.     Exit Property
  1308.     
  1309. SelectedItem_ErrorHandler:
  1310.  
  1311.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": SelectedItem", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1312.         Case vbAbort
  1313.             Resume Exit_SelectedItem
  1314.         Case vbRetry
  1315.             Resume
  1316.         Case vbIgnore
  1317.             Resume Next
  1318.     End Select
  1319.  
  1320. Exit_SelectedItem:
  1321. End Property
  1322.  
  1323. Public Property Get Count() As Integer
  1324. Attribute Count.VB_Description = "Returns total number of node objects in Nodes collection"
  1325. On Error GoTo 0
  1326.  
  1327. '-------------------- Code Body Starts --------------------
  1328.   Count = mNodes.Count
  1329. '--------------------- Code Body Ends ---------------------
  1330.     
  1331.     Exit Property
  1332.     
  1333. Count_ErrorHandler:
  1334.  
  1335.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Count", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1336.         Case vbAbort
  1337.             Resume Exit_Count
  1338.         Case vbRetry
  1339.             Resume
  1340.         Case vbIgnore
  1341.             Resume Next
  1342.     End Select
  1343.  
  1344. Exit_Count:
  1345. End Property
  1346. Public Sub Clear()
  1347. Attribute Clear.VB_Description = "Clear all node objects from Nodes collection"
  1348. On Error GoTo 0
  1349.  
  1350. '-------------------- Code Body Starts --------------------
  1351.   Do Until mNodes.Count = 0
  1352.     mNodes.Remove 1
  1353.   Loop
  1354.   
  1355.   mOtlSet.Levels = 0
  1356.   m_NewIndex = -1
  1357.    'Set outline "properties"
  1358.    OutlineSetup OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, DataFields:=OrderByFields, Bmps:=m_Bitmaps, Lines:=m_Lines, Plus:=m_Plus, Checkmarks:=m_CheckMarks, SelectColor:=m_SelectColor, SelectTextColor:=m_SelectTextColor, BmpField:="", CheckmarkField:=""
  1359.    'redisplay the outline
  1360.    OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1361. '--------------------- Code Body Ends ---------------------
  1362.     
  1363.     Exit Sub
  1364.     
  1365. Clear_ErrorHandler:
  1366.  
  1367.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Clear", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1368.         Case vbAbort
  1369.             Resume Exit_Clear
  1370.         Case vbRetry
  1371.             Resume
  1372.         Case vbIgnore
  1373.             Resume Next
  1374.     End Select
  1375.  
  1376. Exit_Clear:
  1377. End Sub
  1378.  
  1379. Public Function AddNode(mCaption As String, mLevel As Integer, mIsParent As Boolean, _
  1380.                                 Optional mBefore, Optional mAfter, Optional mBookmark, Optional mItemData, Optional mBitmap, _
  1381.                                 Optional mVisible, Optional mExpanded, Optional mVisibleIdx, Optional mSelected, _
  1382.                                 Optional mSyncIdx)
  1383. Attribute AddNode.VB_Description = "Add a new node to the control"
  1384. On Error GoTo 0
  1385.  
  1386. '-------------------- Code Body Starts --------------------
  1387.    Dim TopNode As Integer
  1388.    Dim newitem As New clsItem, cnt As Integer
  1389.    Dim pTopIdx As Integer, pSelIdx As Integer
  1390.    Dim NextKey As String
  1391.    
  1392.    pTopIdx = mOtlSet.TopIdx
  1393.    pSelIdx = mOtlSet.SelectIdx
  1394.    
  1395.    TopNode = mNodes.Count
  1396.    If mLevel <= 1 And mOtlSet.Levels < 2 Then
  1397.      mOtlSet.Levels = 2
  1398.    ElseIf mOtlSet.Levels < mLevel + 1 Then
  1399.      mOtlSet.Levels = mLevel + 1
  1400.    End If
  1401.   
  1402.   With newitem
  1403.     .Caption = mCaption
  1404.     .Level = mLevel
  1405.     .IsParent = mIsParent
  1406.     .Visible = IIf(IsMissing(mVisible), True, mVisible)
  1407.     .Expanded = IIf(IsMissing(mExpanded), True, mExpanded)
  1408.     .VisibleIdx = IIf(IsMissing(mVisibleIdx), 0, mVisibleIdx)
  1409.     .Bookmark = IIf(IsMissing(mBookmark), "", mBookmark)
  1410.     .Bitmap = IIf(IsMissing(mBitmap), Nothing, mBitmap)
  1411.     .Selected = IIf(IsMissing(mSelected), 0, mSelected)
  1412.     .SyncIdx = IIf(IsMissing(mSyncIdx), 0, mSyncIdx)
  1413.     .Itemdata = IIf(IsMissing(mItemData), 0, mItemData)
  1414.   End With
  1415.    
  1416.   NextKey = Str(Val(mNodes.HighKey) + 1)
  1417.   mNodes.HighKey = NextKey
  1418.   
  1419.   If Not IsMissing(mBefore) Then
  1420. '      If mNodes(mBefore).IsParent Then
  1421. '        For cnt = mBefore - 1 To 1 Step -1
  1422. '          If mNodes(cnt).Level = mNodes(mBefore).Level Then
  1423. '            mBefore = cnt
  1424. '            Exit For
  1425. '          End If
  1426. '        Next
  1427. '        If cnt = 0 Then mBefore = 1
  1428. '      End If
  1429.       mNodes.Add newitem, NextKey, mBefore
  1430.       m_NewIndex = mBefore
  1431.   
  1432.   ElseIf Not IsMissing(mAfter) Then
  1433.       If mNodes(mAfter).IsParent Then
  1434.         For cnt = mAfter + 1 To mNodes.Count
  1435.           If mNodes(cnt).Level = mNodes(mAfter).Level Then
  1436.             mAfter = cnt - 1
  1437.             Exit For
  1438.           End If
  1439.         Next
  1440.         If cnt = mNodes.Count + 1 Then mAfter = mNodes.Count
  1441.       End If
  1442.       mNodes.Add newitem, NextKey, , mAfter
  1443.       m_NewIndex = mAfter + 1
  1444.   
  1445.   Else
  1446.       mNodes.Add newitem, NextKey
  1447.       m_NewIndex = mNodes.Count
  1448.   End If
  1449.   
  1450.   If m_AutoRefresh Then
  1451.      'Set outline "properties"
  1452.      OutlineSetup OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, DataFields:=OrderByFields, Bmps:=m_Bitmaps, Lines:=m_Lines, Plus:=m_Plus, Checkmarks:=m_CheckMarks, SelectColor:=m_SelectColor, SelectTextColor:=m_SelectTextColor, BmpField:="", CheckmarkField:=""
  1453.      
  1454.      mOtlSet.TopIdx = pTopIdx
  1455.      mOtlSet.SelectIdx = pSelIdx
  1456.      'redisplay the outline
  1457.      OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1458.    End If
  1459.   
  1460. '--------------------- Code Body Ends ---------------------
  1461.     
  1462.     Exit Function
  1463.     
  1464. AddNode_ErrorHandler:
  1465.  
  1466.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": AddNode", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1467.         Case vbAbort
  1468.             Resume Exit_AddNode
  1469.         Case vbRetry
  1470.             Resume
  1471.         Case vbIgnore
  1472.             Resume Next
  1473.     End Select
  1474.  
  1475. Exit_AddNode:
  1476. End Function
  1477.  
  1478. Public Sub CollapseAll()
  1479. Attribute CollapseAll.VB_Description = "Collapse all nodes in Nodes collection list so that no child nodes are visible"
  1480. On Error GoTo 0
  1481.  
  1482. '-------------------- Code Body Starts --------------------
  1483.   OutlineCollapseAll Picture1, VScroll1, mOtlSet, mNodes
  1484. '--------------------- Code Body Ends ---------------------
  1485.     
  1486.     Exit Sub
  1487.     
  1488. CollapseAll_ErrorHandler:
  1489.  
  1490.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": CollapseAll", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1491.         Case vbAbort
  1492.             Resume Exit_CollapseAll
  1493.         Case vbRetry
  1494.             Resume
  1495.         Case vbIgnore
  1496.             Resume Next
  1497.     End Select
  1498.  
  1499. Exit_CollapseAll:
  1500. End Sub
  1501.  
  1502. Public Sub ExpandAll()
  1503. Attribute ExpandAll.VB_Description = "Expand all nodes in Nodes collection so that all child nodes are visible"
  1504. On Error GoTo 0
  1505.  
  1506. '-------------------- Code Body Starts --------------------
  1507.   OutlineExpandAll Picture1, VScroll1, mOtlSet, mNodes
  1508. '--------------------- Code Body Ends ---------------------
  1509.     
  1510.     Exit Sub
  1511.     
  1512. ExpandAll_ErrorHandler:
  1513.  
  1514.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": ExpandAll", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1515.         Case vbAbort
  1516.             Resume Exit_ExpandAll
  1517.         Case vbRetry
  1518.             Resume
  1519.         Case vbIgnore
  1520.             Resume Next
  1521.     End Select
  1522.  
  1523. Exit_ExpandAll:
  1524. End Sub
  1525.  
  1526. Public Sub Collapse(Index As Integer)
  1527. On Error GoTo 0
  1528.  
  1529. '-------------------- Code Body Starts --------------------
  1530.   OutlineCollapse Index, Picture1, VScroll1, mOtlSet, mNodes
  1531. '--------------------- Code Body Ends ---------------------
  1532.     
  1533.     Exit Sub
  1534.     
  1535. Collapse_ErrorHandler:
  1536.  
  1537.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Collapse", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1538.         Case vbAbort
  1539.             Resume Exit_Collapse
  1540.         Case vbRetry
  1541.             Resume
  1542.         Case vbIgnore
  1543.             Resume Next
  1544.     End Select
  1545.  
  1546. Exit_Collapse:
  1547. End Sub
  1548. Public Sub Expand(Index As Integer)
  1549. On Error GoTo 0
  1550.  
  1551. '-------------------- Code Body Starts --------------------
  1552.   OutlineExpand Index, Picture1, VScroll1, mOtlSet, mNodes
  1553. '--------------------- Code Body Ends ---------------------
  1554.     
  1555.     Exit Sub
  1556.     
  1557. Expand_ErrorHandler:
  1558.  
  1559.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Expand", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1560.         Case vbAbort
  1561.             Resume Exit_Expand
  1562.         Case vbRetry
  1563.             Resume
  1564.         Case vbIgnore
  1565.             Resume Next
  1566.     End Select
  1567.  
  1568. Exit_Expand:
  1569. End Sub
  1570.  
  1571. Public Sub Find(arg As String, Mode As Integer)
  1572. Attribute Find.VB_Description = "Find a node object by its caption name"
  1573. On Error GoTo 0
  1574.  
  1575. '-------------------- Code Body Starts --------------------
  1576.   OutlineFind arg, Mode, Picture1, VScroll1, mOtlSet, mNodes
  1577. '--------------------- Code Body Ends ---------------------
  1578.     
  1579.     Exit Sub
  1580.     
  1581. Find_ErrorHandler:
  1582.  
  1583.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Find", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1584.         Case vbAbort
  1585.             Resume Exit_Find
  1586.         Case vbRetry
  1587.             Resume
  1588.         Case vbIgnore
  1589.             Resume Next
  1590.     End Select
  1591.  
  1592. Exit_Find:
  1593. End Sub
  1594.  
  1595. Public Sub Refresh()
  1596. Attribute Refresh.VB_Description = "Forces a complete repaint of a form or control"
  1597. On Error GoTo 0
  1598.  
  1599. '-------------------- Code Body Starts --------------------
  1600.   UserControl.Cls
  1601.   UserControl_Paint
  1602.    
  1603.   If mNodes.Count > 0 Then
  1604.     'Set outline "properties"
  1605.     'OutlineSetup OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, DataFields:=OrderByFields, Bmps:=m_Bitmaps, Lines:=m_Lines, Plus:=m_Plus, Checkmarks:=m_CheckMarks, SelectColor:=m_SelectColor, SelectTextColor:=m_SelectTextColor, BmpField:="", CheckmarkField:=""
  1606.     'display the outline
  1607.     mOtlSet.VisChangeFlag = True
  1608.     OutlineRefresh Picture1, VScroll1, mOtlSet, mNodes
  1609.   End If
  1610.  
  1611. '  'Set outline "properties"
  1612. '  OutlineSetup OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, DataFields:=OrderByFields, Bmps:=m_Bitmaps, Lines:=m_Lines, Plus:=m_Plus, Checkmarks:=m_CheckMarks, SelectColor:=m_SelectColor, SelectTextColor:=m_SelectTextColor, BmpField:="", CheckmarkField:=""
  1613. '  'redisplay the outline
  1614. '  OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1615. '  UserControl.Refresh
  1616. '--------------------- Code Body Ends ---------------------
  1617.     
  1618.     Exit Sub
  1619.     
  1620. Refresh_ErrorHandler:
  1621.  
  1622.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Refresh", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1623.         Case vbAbort
  1624.             Resume Exit_Refresh
  1625.         Case vbRetry
  1626.             Resume
  1627.         Case vbIgnore
  1628.             Resume Next
  1629.     End Select
  1630.  
  1631. Exit_Refresh:
  1632. End Sub
  1633.  
  1634. Public Sub RemoveNode(Index As Integer)
  1635. Attribute RemoveNode.VB_Description = "Remove node object from Nodes collection"
  1636. Dim pLevel As Integer, cnt As Integer
  1637. On Error GoTo 0
  1638.  
  1639. '-------------------- Code Body Starts --------------------
  1640.   If mNodes.Count = 0 Then Exit Sub
  1641.   pLevel = mNodes.Item(Index).Level
  1642.   If mNodes.Item(Index).IsParent Then
  1643.     For cnt = Index + 1 To mNodes.Count
  1644.       If mNodes.Item(cnt).Level > pLevel Then
  1645.         mNodes.Remove cnt
  1646.       Else
  1647.         Exit For
  1648.       End If
  1649.     Next
  1650.   End If
  1651.   mNodes.Remove Index
  1652.   
  1653.   m_NewIndex = -1
  1654.   If m_AutoRefresh Then
  1655.     'Set outline "properties"
  1656.     OutlineSetup OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, DataFields:=OrderByFields, Bmps:=m_Bitmaps, Lines:=m_Lines, Plus:=m_Plus, Checkmarks:=m_CheckMarks, SelectColor:=m_SelectColor, SelectTextColor:=m_SelectTextColor, BmpField:="", CheckmarkField:=""
  1657.     'redisplay the outline
  1658.     OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1659.   End If
  1660. '--------------------- Code Body Ends ---------------------
  1661.     
  1662.     Exit Sub
  1663.     
  1664. RemoveNode_ErrorHandler:
  1665.  
  1666.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": RemoveNode", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1667.         Case vbAbort
  1668.             Resume Exit_RemoveNode
  1669.         Case vbRetry
  1670.             Resume
  1671.         Case vbIgnore
  1672.             Resume Next
  1673.     End Select
  1674.  
  1675. Exit_RemoveNode:
  1676. End Sub
  1677.  
  1678. Public Function Item(ByVal Key As Variant) As Object
  1679. Attribute Item.VB_Description = "Returns a node object bu index or by key"
  1680.   On Error GoTo errorexit
  1681.   If VarType(Key) = vbString Then
  1682.     Key = Trim(Key)
  1683.   End If
  1684.   
  1685.   Set Item = mNodes.Item(Key)
  1686.   Exit Function
  1687.   
  1688. errorexit:
  1689.   
  1690. End Function
  1691.  
  1692.  
  1693. Public Property Get PictureItemSelected() As Picture
  1694. Attribute PictureItemSelected.VB_Description = "Bitmap to display for node item selected"
  1695. On Error GoTo 0
  1696.  
  1697. '-------------------- Code Body Starts --------------------
  1698.     Set PictureItemSelected = m_PictureItemSelected
  1699. '--------------------- Code Body Ends ---------------------
  1700.     
  1701.     Exit Property
  1702.     
  1703. PictureItemSelected_ErrorHandler:
  1704.  
  1705.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureItemSelected", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1706.         Case vbAbort
  1707.             Resume Exit_PictureItemSelected
  1708.         Case vbRetry
  1709.             Resume
  1710.         Case vbIgnore
  1711.             Resume Next
  1712.     End Select
  1713.  
  1714. Exit_PictureItemSelected:
  1715. End Property
  1716.  
  1717. Public Property Set PictureItemSelected(ByVal New_PictureItemSelected As Picture)
  1718. On Error GoTo 0
  1719.  
  1720. '-------------------- Code Body Starts --------------------
  1721.     Set m_PictureItemSelected = New_PictureItemSelected
  1722.     mOtlSet.VisChangeFlag = True
  1723.    OutlineBmpCheckedSetup Image1(4), m_PictureOpenAll, Image1(1), m_PictureClosedAll, Image1(5), m_PictureOpenSome, Image1(2), m_PictureClosedSome, Image1(7), m_PictureItemSelected
  1724.     OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1725. '--------------------- Code Body Ends ---------------------
  1726.     
  1727.     Exit Property
  1728.     
  1729. PictureItemSelected_ErrorHandler:
  1730.  
  1731.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureItemSelected", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1732.         Case vbAbort
  1733.             Resume Exit_PictureItemSelected
  1734.         Case vbRetry
  1735.             Resume
  1736.         Case vbIgnore
  1737.             Resume Next
  1738.     End Select
  1739.  
  1740. Exit_PictureItemSelected:
  1741. End Property
  1742.  
  1743. Public Property Get PictureItemNotSelected() As Picture
  1744. Attribute PictureItemNotSelected.VB_Description = "Bitmap to display for node item not selected"
  1745. On Error GoTo 0
  1746.  
  1747. '-------------------- Code Body Starts --------------------
  1748.     Set PictureItemNotSelected = m_PictureItemNotSelected
  1749. '--------------------- Code Body Ends ---------------------
  1750.     
  1751.     Exit Property
  1752.     
  1753. PictureItemNotSelected_ErrorHandler:
  1754.  
  1755.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureItemNotSelected", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1756.         Case vbAbort
  1757.             Resume Exit_PictureItemNotSelected
  1758.         Case vbRetry
  1759.             Resume
  1760.         Case vbIgnore
  1761.             Resume Next
  1762.     End Select
  1763.  
  1764. Exit_PictureItemNotSelected:
  1765. End Property
  1766.  
  1767. Public Property Set PictureItemNotSelected(ByVal New_PictureItemNotSelected As Picture)
  1768. On Error GoTo 0
  1769.  
  1770. '-------------------- Code Body Starts --------------------
  1771.     Set m_PictureItemNotSelected = New_PictureItemNotSelected
  1772.     
  1773.     mOtlSet.VisChangeFlag = True
  1774.     OutlineBmpSetup Image1(3), m_PictureOpen, Image1(0), m_PictureClosed, Image1(6), m_PictureItemNotSelected, Image1(8), m_PictureItemNotSelected
  1775.     OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1776. '--------------------- Code Body Ends ---------------------
  1777.     
  1778.     Exit Property
  1779.     
  1780. PictureItemNotSelected_ErrorHandler:
  1781.  
  1782.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureItemNotSelected", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1783.         Case vbAbort
  1784.             Resume Exit_PictureItemNotSelected
  1785.         Case vbRetry
  1786.             Resume
  1787.         Case vbIgnore
  1788.             Resume Next
  1789.     End Select
  1790.  
  1791. Exit_PictureItemNotSelected:
  1792. End Property
  1793.  
  1794. Public Property Get PictureOpen() As Picture
  1795. Attribute PictureOpen.VB_Description = "Bitmap to display for open node with no subitems selected"
  1796. On Error GoTo 0
  1797.  
  1798. '-------------------- Code Body Starts --------------------
  1799.     Set PictureOpen = m_PictureOpen
  1800. '--------------------- Code Body Ends ---------------------
  1801.     
  1802.     Exit Property
  1803.     
  1804. PictureOpen_ErrorHandler:
  1805.  
  1806.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureOpen", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1807.         Case vbAbort
  1808.             Resume Exit_PictureOpen
  1809.         Case vbRetry
  1810.             Resume
  1811.         Case vbIgnore
  1812.             Resume Next
  1813.     End Select
  1814.  
  1815. Exit_PictureOpen:
  1816. End Property
  1817.  
  1818. Public Property Set PictureOpen(ByVal New_PictureOpen As Picture)
  1819. On Error GoTo 0
  1820.  
  1821. '-------------------- Code Body Starts --------------------
  1822.     Set m_PictureOpen = New_PictureOpen
  1823.     mOtlSet.VisChangeFlag = True
  1824.     OutlineBmpSetup Image1(3), m_PictureOpen, Image1(0), m_PictureClosed, Image1(6), m_PictureItemNotSelected, Image1(8), m_PictureItemNotSelected
  1825.     OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1826. '--------------------- Code Body Ends ---------------------
  1827.     
  1828.     Exit Property
  1829.     
  1830. PictureOpen_ErrorHandler:
  1831.  
  1832.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureOpen", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1833.         Case vbAbort
  1834.             Resume Exit_PictureOpen
  1835.         Case vbRetry
  1836.             Resume
  1837.         Case vbIgnore
  1838.             Resume Next
  1839.     End Select
  1840.  
  1841. Exit_PictureOpen:
  1842. End Property
  1843.  
  1844. Public Property Get PictureOpenSome() As Picture
  1845. Attribute PictureOpenSome.VB_Description = "Bitmap to display for open node with some subitems selected"
  1846. On Error GoTo 0
  1847.  
  1848. '-------------------- Code Body Starts --------------------
  1849.     Set PictureOpenSome = m_PictureOpenSome
  1850. '--------------------- Code Body Ends ---------------------
  1851.     
  1852.     Exit Property
  1853.     
  1854. PictureOpenSome_ErrorHandler:
  1855.  
  1856.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureOpenSome", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1857.         Case vbAbort
  1858.             Resume Exit_PictureOpenSome
  1859.         Case vbRetry
  1860.             Resume
  1861.         Case vbIgnore
  1862.             Resume Next
  1863.     End Select
  1864.  
  1865. Exit_PictureOpenSome:
  1866. End Property
  1867.  
  1868. Public Property Set PictureOpenSome(ByVal New_PictureOpenSome As Picture)
  1869. On Error GoTo 0
  1870.  
  1871. '-------------------- Code Body Starts --------------------
  1872.     Set m_PictureOpenSome = New_PictureOpenSome
  1873.     mOtlSet.VisChangeFlag = True
  1874.    OutlineBmpCheckedSetup Image1(4), m_PictureOpenAll, Image1(1), m_PictureClosedAll, Image1(5), m_PictureOpenSome, Image1(2), m_PictureClosedSome, Image1(7), m_PictureItemSelected
  1875.     OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1876. '--------------------- Code Body Ends ---------------------
  1877.     
  1878.     Exit Property
  1879.     
  1880. PictureOpenSome_ErrorHandler:
  1881.  
  1882.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureOpenSome", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1883.         Case vbAbort
  1884.             Resume Exit_PictureOpenSome
  1885.         Case vbRetry
  1886.             Resume
  1887.         Case vbIgnore
  1888.             Resume Next
  1889.     End Select
  1890.  
  1891. Exit_PictureOpenSome:
  1892. End Property
  1893.  
  1894. Public Property Get PictureOpenAll() As Picture
  1895. Attribute PictureOpenAll.VB_Description = "Bitmap to display for open node with all subitems selected"
  1896. On Error GoTo 0
  1897.  
  1898. '-------------------- Code Body Starts --------------------
  1899.     Set PictureOpenAll = m_PictureOpenAll
  1900. '--------------------- Code Body Ends ---------------------
  1901.     
  1902.     Exit Property
  1903.     
  1904. PictureOpenAll_ErrorHandler:
  1905.  
  1906.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureOpenAll", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1907.         Case vbAbort
  1908.             Resume Exit_PictureOpenAll
  1909.         Case vbRetry
  1910.             Resume
  1911.         Case vbIgnore
  1912.             Resume Next
  1913.     End Select
  1914.  
  1915. Exit_PictureOpenAll:
  1916. End Property
  1917.  
  1918. Public Property Set PictureOpenAll(ByVal New_PictureOpenAll As Picture)
  1919. On Error GoTo 0
  1920.  
  1921. '-------------------- Code Body Starts --------------------
  1922.     Set m_PictureOpenAll = New_PictureOpenAll
  1923.     mOtlSet.VisChangeFlag = True
  1924.    OutlineBmpCheckedSetup Image1(4), m_PictureOpenAll, Image1(1), m_PictureClosedAll, Image1(5), m_PictureOpenSome, Image1(2), m_PictureClosedSome, Image1(7), m_PictureItemSelected
  1925.     OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1926. '--------------------- Code Body Ends ---------------------
  1927.     
  1928.     Exit Property
  1929.     
  1930. PictureOpenAll_ErrorHandler:
  1931.  
  1932.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureOpenAll", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1933.         Case vbAbort
  1934.             Resume Exit_PictureOpenAll
  1935.         Case vbRetry
  1936.             Resume
  1937.         Case vbIgnore
  1938.             Resume Next
  1939.     End Select
  1940.  
  1941. Exit_PictureOpenAll:
  1942. End Property
  1943.  
  1944. Public Property Get PictureClosed() As Picture
  1945. Attribute PictureClosed.VB_Description = "Bitmap to display for closed node with no subitems selected"
  1946. On Error GoTo 0
  1947.  
  1948. '-------------------- Code Body Starts --------------------
  1949.     Set PictureClosed = m_PictureClosed
  1950. '--------------------- Code Body Ends ---------------------
  1951.     
  1952.     Exit Property
  1953.     
  1954. PictureClosed_ErrorHandler:
  1955.  
  1956.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureClosed", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1957.         Case vbAbort
  1958.             Resume Exit_PictureClosed
  1959.         Case vbRetry
  1960.             Resume
  1961.         Case vbIgnore
  1962.             Resume Next
  1963.     End Select
  1964.  
  1965. Exit_PictureClosed:
  1966. End Property
  1967.  
  1968. Public Property Set PictureClosed(ByVal New_PictureClosed As Picture)
  1969. On Error GoTo 0
  1970.  
  1971. '-------------------- Code Body Starts --------------------
  1972.     Set m_PictureClosed = New_PictureClosed
  1973.     mOtlSet.VisChangeFlag = True
  1974.     OutlineBmpSetup Image1(3), m_PictureOpen, Image1(0), m_PictureClosed, Image1(6), m_PictureItemNotSelected, Image1(8), m_PictureItemNotSelected
  1975.     OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  1976. '--------------------- Code Body Ends ---------------------
  1977.     
  1978.     Exit Property
  1979.     
  1980. PictureClosed_ErrorHandler:
  1981.  
  1982.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureClosed", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  1983.         Case vbAbort
  1984.             Resume Exit_PictureClosed
  1985.         Case vbRetry
  1986.             Resume
  1987.         Case vbIgnore
  1988.             Resume Next
  1989.     End Select
  1990.  
  1991. Exit_PictureClosed:
  1992. End Property
  1993.  
  1994. Public Property Get PictureClosedSome() As Picture
  1995. Attribute PictureClosedSome.VB_Description = "Bitmap to display for closed node with some subitems selected"
  1996. On Error GoTo 0
  1997.  
  1998. '-------------------- Code Body Starts --------------------
  1999.     Set PictureClosedSome = m_PictureClosedSome
  2000. '--------------------- Code Body Ends ---------------------
  2001.     
  2002.     Exit Property
  2003.     
  2004. PictureClosedSome_ErrorHandler:
  2005.  
  2006.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureClosedSome", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2007.         Case vbAbort
  2008.             Resume Exit_PictureClosedSome
  2009.         Case vbRetry
  2010.             Resume
  2011.         Case vbIgnore
  2012.             Resume Next
  2013.     End Select
  2014.  
  2015. Exit_PictureClosedSome:
  2016. End Property
  2017.  
  2018. Public Property Set PictureClosedSome(ByVal New_PictureClosedSome As Picture)
  2019. On Error GoTo 0
  2020.  
  2021. '-------------------- Code Body Starts --------------------
  2022.     Set m_PictureClosedSome = New_PictureClosedSome
  2023.     mOtlSet.VisChangeFlag = True
  2024.    OutlineBmpCheckedSetup Image1(4), m_PictureOpenAll, Image1(1), m_PictureClosedAll, Image1(5), m_PictureOpenSome, Image1(2), m_PictureClosedSome, Image1(7), m_PictureItemSelected
  2025.     OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  2026. '--------------------- Code Body Ends ---------------------
  2027.     
  2028.     Exit Property
  2029.     
  2030. PictureClosedSome_ErrorHandler:
  2031.  
  2032.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureClosedSome", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2033.         Case vbAbort
  2034.             Resume Exit_PictureClosedSome
  2035.         Case vbRetry
  2036.             Resume
  2037.         Case vbIgnore
  2038.             Resume Next
  2039.     End Select
  2040.  
  2041. Exit_PictureClosedSome:
  2042. End Property
  2043.  
  2044. Public Property Get PictureClosedAll() As Picture
  2045. Attribute PictureClosedAll.VB_Description = "Bitmap to display for closed node with all subitems selected"
  2046. On Error GoTo 0
  2047.  
  2048. '-------------------- Code Body Starts --------------------
  2049.     Set PictureClosedAll = m_PictureClosedAll
  2050. '--------------------- Code Body Ends ---------------------
  2051.     
  2052.     Exit Property
  2053.     
  2054. PictureClosedAll_ErrorHandler:
  2055.  
  2056.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureClosedAll", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2057.         Case vbAbort
  2058.             Resume Exit_PictureClosedAll
  2059.         Case vbRetry
  2060.             Resume
  2061.         Case vbIgnore
  2062.             Resume Next
  2063.     End Select
  2064.  
  2065. Exit_PictureClosedAll:
  2066. End Property
  2067.  
  2068. Public Property Set PictureClosedAll(ByVal New_PictureClosedAll As Picture)
  2069. On Error GoTo 0
  2070.  
  2071. '-------------------- Code Body Starts --------------------
  2072.     Set m_PictureClosedAll = New_PictureClosedAll
  2073.     mOtlSet.VisChangeFlag = True
  2074.    OutlineBmpCheckedSetup Image1(4), m_PictureOpenAll, Image1(1), m_PictureClosedAll, Image1(5), m_PictureOpenSome, Image1(2), m_PictureClosedSome, Image1(7), m_PictureItemSelected
  2075.     OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  2076. '--------------------- Code Body Ends ---------------------
  2077.     
  2078.     Exit Property
  2079.     
  2080. PictureClosedAll_ErrorHandler:
  2081.  
  2082.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": PictureClosedAll", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2083.         Case vbAbort
  2084.             Resume Exit_PictureClosedAll
  2085.         Case vbRetry
  2086.             Resume
  2087.         Case vbIgnore
  2088.             Resume Next
  2089.     End Select
  2090.  
  2091. Exit_PictureClosedAll:
  2092. End Property
  2093.  
  2094.  
  2095. Private Sub VScroll1_GotFocus()
  2096. On Error GoTo 0
  2097.  
  2098. '-------------------- Code Body Starts --------------------
  2099.   Picture1.SetFocus
  2100. '--------------------- Code Body Ends ---------------------
  2101.     
  2102.     Exit Sub
  2103.     
  2104. VScroll1_GotFocus_ErrorHandler:
  2105.  
  2106.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": VScroll1_GotFocus", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2107.         Case vbAbort
  2108.             Resume Exit_VScroll1_GotFocus
  2109.         Case vbRetry
  2110.             Resume
  2111.         Case vbIgnore
  2112.             Resume Next
  2113.     End Select
  2114.  
  2115. Exit_VScroll1_GotFocus:
  2116. End Sub
  2117.  
  2118. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  2119. 'MappingInfo=picture1,picture1,-1,Font
  2120. Public Property Get Font() As Font
  2121. On Error GoTo 0
  2122.  
  2123. '-------------------- Code Body Starts --------------------
  2124.     Set Font = Picture1.Font
  2125. '--------------------- Code Body Ends ---------------------
  2126.     
  2127.     Exit Property
  2128.     
  2129. Font_ErrorHandler:
  2130.  
  2131.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Font", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2132.         Case vbAbort
  2133.             Resume Exit_Font
  2134.         Case vbRetry
  2135.             Resume
  2136.         Case vbIgnore
  2137.             Resume Next
  2138.     End Select
  2139.  
  2140. Exit_Font:
  2141. End Property
  2142.  
  2143. Public Property Set Font(ByVal New_Font As Font)
  2144. On Error GoTo 0
  2145.  
  2146. '-------------------- Code Body Starts --------------------
  2147.     Set Picture1.Font = New_Font
  2148.   'Set outline "properties"
  2149.   OutlineSetup OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, DataFields:=OrderByFields, Bmps:=m_Bitmaps, Lines:=m_Lines, Plus:=m_Plus, Checkmarks:=m_CheckMarks, SelectColor:=m_SelectColor, SelectTextColor:=m_SelectTextColor, BmpField:="", CheckmarkField:=""
  2150.   'redisplay the outline
  2151.   OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  2152.     PropertyChanged "Font"
  2153. '--------------------- Code Body Ends ---------------------
  2154.     
  2155.     Exit Property
  2156.     
  2157. Font_ErrorHandler:
  2158.  
  2159.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Font", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2160.         Case vbAbort
  2161.             Resume Exit_Font
  2162.         Case vbRetry
  2163.             Resume
  2164.         Case vbIgnore
  2165.             Resume Next
  2166.     End Select
  2167.  
  2168. Exit_Font:
  2169. End Property
  2170.  
  2171. Public Property Get Itemdata(Index As Integer) As Long
  2172. On Error GoTo 0
  2173.  
  2174. '-------------------- Code Body Starts --------------------
  2175.     Itemdata = mNodes(Index).Itemdata
  2176. '--------------------- Code Body Ends ---------------------
  2177.     
  2178.     Exit Property
  2179.     
  2180. Itemdata_ErrorHandler:
  2181.  
  2182.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Itemdata", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2183.         Case vbAbort
  2184.             Resume Exit_Itemdata
  2185.         Case vbRetry
  2186.             Resume
  2187.         Case vbIgnore
  2188.             Resume Next
  2189.     End Select
  2190.  
  2191. Exit_Itemdata:
  2192. End Property
  2193. Public Property Let Itemdata(Index As Integer, ByVal New_ItemData As Long)
  2194. On Error GoTo 0
  2195.  
  2196. '-------------------- Code Body Starts --------------------
  2197.     mNodes(Index).Itemdata = New_ItemData
  2198.     PropertyChanged "ItemData"
  2199. '--------------------- Code Body Ends ---------------------
  2200.     
  2201.     Exit Property
  2202.     
  2203. Itemdata_ErrorHandler:
  2204.  
  2205.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": Itemdata", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2206.         Case vbAbort
  2207.             Resume Exit_Itemdata
  2208.         Case vbRetry
  2209.             Resume
  2210.         Case vbIgnore
  2211.             Resume Next
  2212.     End Select
  2213.  
  2214. Exit_Itemdata:
  2215. End Property
  2216.  
  2217.  
  2218. Public Property Get SelectColor() As OLE_COLOR
  2219. On Error GoTo 0
  2220.  
  2221. '-------------------- Code Body Starts --------------------
  2222.     SelectColor = m_SelectColor
  2223. '--------------------- Code Body Ends ---------------------
  2224.     
  2225.     Exit Property
  2226.     
  2227. SelectColor_ErrorHandler:
  2228.  
  2229.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": SelectColor", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2230.         Case vbAbort
  2231.             Resume Exit_SelectColor
  2232.         Case vbRetry
  2233.             Resume
  2234.         Case vbIgnore
  2235.             Resume Next
  2236.     End Select
  2237.  
  2238. Exit_SelectColor:
  2239. End Property
  2240.  
  2241. Public Property Let SelectColor(ByVal New_SelectColor As OLE_COLOR)
  2242. On Error GoTo 0
  2243.  
  2244. '-------------------- Code Body Starts --------------------
  2245.     m_SelectColor = New_SelectColor
  2246.   'Set outline "properties"
  2247.   OutlineSetup OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, DataFields:=OrderByFields, Bmps:=m_Bitmaps, Lines:=m_Lines, Plus:=m_Plus, Checkmarks:=m_CheckMarks, SelectColor:=m_SelectColor, SelectTextColor:=m_SelectTextColor, BmpField:="", CheckmarkField:=""
  2248.   'redisplay the outline
  2249.   OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  2250.     PropertyChanged "SelectColor"
  2251. '--------------------- Code Body Ends ---------------------
  2252.     
  2253.     Exit Property
  2254.     
  2255. SelectColor_ErrorHandler:
  2256.  
  2257.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": SelectColor", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2258.         Case vbAbort
  2259.             Resume Exit_SelectColor
  2260.         Case vbRetry
  2261.             Resume
  2262.         Case vbIgnore
  2263.             Resume Next
  2264.     End Select
  2265.  
  2266. Exit_SelectColor:
  2267. End Property
  2268.  
  2269. Public Property Get SelectTextColor() As OLE_COLOR
  2270. On Error GoTo 0
  2271.  
  2272. '-------------------- Code Body Starts --------------------
  2273.     SelectTextColor = m_SelectTextColor
  2274. '--------------------- Code Body Ends ---------------------
  2275.     
  2276.     Exit Property
  2277.     
  2278. SelectTextColor_ErrorHandler:
  2279.  
  2280.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": SelectTextColor", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2281.         Case vbAbort
  2282.             Resume Exit_SelectTextColor
  2283.         Case vbRetry
  2284.             Resume
  2285.         Case vbIgnore
  2286.             Resume Next
  2287.     End Select
  2288.  
  2289. Exit_SelectTextColor:
  2290. End Property
  2291.  
  2292. Public Property Let SelectTextColor(ByVal New_SelectTextColor As OLE_COLOR)
  2293. On Error GoTo 0
  2294.  
  2295. '-------------------- Code Body Starts --------------------
  2296.     m_SelectTextColor = New_SelectTextColor
  2297.   'Set outline "properties"
  2298.   OutlineSetup OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, DataFields:=OrderByFields, Bmps:=m_Bitmaps, Lines:=m_Lines, Plus:=m_Plus, Checkmarks:=m_CheckMarks, SelectColor:=m_SelectColor, SelectTextColor:=m_SelectTextColor, BmpField:="", CheckmarkField:=""
  2299.   'redisplay the outline
  2300.   OutlineRefresh OtlPic:=Picture1, OtlScroll:=VScroll1, OtlSet:=mOtlSet, Otldat:=mNodes
  2301.     PropertyChanged "SelectTextColor"
  2302. '--------------------- Code Body Ends ---------------------
  2303.     
  2304.     Exit Property
  2305.     
  2306. SelectTextColor_ErrorHandler:
  2307.  
  2308.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": SelectTextColor", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2309.         Case vbAbort
  2310.             Resume Exit_SelectTextColor
  2311.         Case vbRetry
  2312.             Resume
  2313.         Case vbIgnore
  2314.             Resume Next
  2315.     End Select
  2316.  
  2317. Exit_SelectTextColor:
  2318. End Property
  2319.  
  2320. Public Property Get AutoRefresh() As Boolean
  2321. Attribute AutoRefresh.VB_Description = "Forces a refresh to occur when add or deleting nodes. Can set to False to speed up adding a lot of nodes."
  2322. On Error GoTo 0
  2323.  
  2324. '-------------------- Code Body Starts --------------------
  2325.     AutoRefresh = m_AutoRefresh
  2326. '--------------------- Code Body Ends ---------------------
  2327.     
  2328.     Exit Property
  2329.     
  2330. AutoRefresh_ErrorHandler:
  2331.  
  2332.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": AutoRefresh", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2333.         Case vbAbort
  2334.             Resume Exit_AutoRefresh
  2335.         Case vbRetry
  2336.             Resume
  2337.         Case vbIgnore
  2338.             Resume Next
  2339.     End Select
  2340.  
  2341. Exit_AutoRefresh:
  2342. End Property
  2343.  
  2344. Public Property Let AutoRefresh(ByVal New_value As Boolean)
  2345. On Error GoTo 0
  2346.  
  2347. '-------------------- Code Body Starts --------------------
  2348.     m_AutoRefresh = New_value
  2349.     PropertyChanged "AutoRefresh"
  2350. '--------------------- Code Body Ends ---------------------
  2351.     
  2352.     Exit Property
  2353.     
  2354. AutoRefresh_ErrorHandler:
  2355.  
  2356.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": AutoRefresh", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2357.         Case vbAbort
  2358.             Resume Exit_AutoRefresh
  2359.         Case vbRetry
  2360.             Resume
  2361.         Case vbIgnore
  2362.             Resume Next
  2363.     End Select
  2364.  
  2365. Exit_AutoRefresh:
  2366. End Property
  2367.  
  2368. Public Property Get NewIndex() As Integer
  2369. On Error GoTo 0
  2370.  
  2371. '-------------------- Code Body Starts --------------------
  2372.     NewIndex = m_NewIndex
  2373. '--------------------- Code Body Ends ---------------------
  2374.     
  2375.     Exit Property
  2376.     
  2377. NewIndex_ErrorHandler:
  2378.  
  2379.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": NewIndex", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2380.         Case vbAbort
  2381.             Resume Exit_NewIndex
  2382.         Case vbRetry
  2383.             Resume
  2384.         Case vbIgnore
  2385.             Resume Next
  2386.     End Select
  2387.  
  2388. Exit_NewIndex:
  2389. End Property
  2390.  
  2391. Public Property Get ParentIndex(Index As Integer) As Integer
  2392. On Error GoTo 0
  2393.  
  2394. '-------------------- Code Body Starts --------------------
  2395. 'GMG 980824 : added cnt
  2396. Dim cnt As Long
  2397.     
  2398.     If Index < 1 Or Index >= mNodes.Count Then
  2399.       ParentIndex = 0
  2400.     ElseIf mNodes(Index).Level = 0 Then
  2401.       ParentIndex = 0
  2402.     Else
  2403.       For cnt = Index - 1 To 1 Step -1
  2404.         If mNodes(cnt).IsParent Then
  2405.           ParentIndex = cnt
  2406.           Exit For
  2407.         End If
  2408.       Next
  2409.     End If
  2410. '--------------------- Code Body Ends ---------------------
  2411.     
  2412.     Exit Property
  2413.     
  2414. ParentIndex_ErrorHandler:
  2415.  
  2416.     Select Case MsgBox("Error " & Err.Number & ": " & vbCrLf & Err.Description & vbCrLf & vbTab & vbTab & "occurred at line " & Erl & vbCrLf & "in " & App.Title & ": ParentIndex", vbAbortRetryIgnore + vbExclamation, App.Title & " Error")
  2417.         Case vbAbort
  2418.             Resume Exit_ParentIndex
  2419.         Case vbRetry
  2420.             Resume
  2421.         Case vbIgnore
  2422.             Resume Next
  2423.     End Select
  2424.  
  2425. Exit_ParentIndex:
  2426. End Property
  2427.