home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Controls / Visual Basic Controls.iso / vbcontrol / axpicker / sortlist.cls < prev    next >
Encoding:
Visual Basic class definition  |  1998-10-21  |  6.4 KB  |  177 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "SortedList"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
  11. Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
  12. '-------------------------------------------------------------------------------
  13. ' Copyright ⌐ 1997 Microsoft Corporation. All rights reserved.
  14. '
  15. ' You have a royalty-free right to use, modify, reproduce and distribute the
  16. ' Sample Application Files (and/or any modified version) in any way you find
  17. ' useful, provided that you agree that Microsoft has no warranty, obligations or
  18. ' liability for any Sample Application Files.
  19. '-------------------------------------------------------------------------------
  20.  
  21. '-------------------------------------------------------------------------------
  22. ' This class stores items using sorted keys, for fast retrieval. The preferred
  23. ' retrieval method is by key, but retrieval by index is allowed; the client
  24. ' should realize that an item's index will probably change.
  25. '-------------------------------------------------------------------------------
  26.  
  27. Option Explicit
  28.  
  29. Private Type Item
  30.     Item As Long
  31.     Key As Long
  32. End Type
  33.  
  34. 'The actual data:
  35. Private mudtItems() As Item
  36. Private mcItems As Long
  37.  
  38. Public Property Get Count() As Long
  39.     Count = mcItems
  40. End Property
  41.  
  42. Public Property Get ItemByIndex(Index As Long) As Long
  43.     'Handle the error ourselves if Index is too big. We handle this ourselves
  44.     '   because when the array shrinks, we will not clean up the newly deleted
  45.     '   items. Therefore, an Index greater than Count might still return an
  46.     '   item, but this item would be invalid.
  47.     If Index > mcItems Then Err.Raise 9
  48.     'Let VB handle the error if Index is too small
  49.     ItemByIndex = mudtItems(Index).Item
  50. End Property
  51.  
  52. Public Property Get ItemByKey(Key As Long) As Long
  53.     Dim nIndex As Long
  54.  
  55.     If FindItem(Key, nIndex) Then
  56.         ItemByKey = mudtItems(nIndex).Item
  57.     Else
  58.         Err.Raise 5, , "There is no item with the key " & Key & "."
  59.     End If
  60. End Property
  61.  
  62. Public Property Get KeyByIndex(Index As Long) As Long
  63.     'Handle the error ourselves if Index is too big. We handle this ourselves
  64.     '   because when the array shrinks, we will not clean up the newly deleted
  65.     '   items. Therefore, and Index greater than Count might still return an
  66.     '   item, but this item would be invalid.
  67.     If Index > mcItems Then Err.Raise 9
  68.     'Let VB handle the error  if Index is too small
  69.     KeyByIndex = mudtItems(Index).Key
  70. End Property
  71.  
  72. Public Sub Add(Item As Long, Key As Long)
  73.     Dim nIndex As Long
  74.  
  75.     If FindItem(Key, nIndex) Then
  76.         Err.Raise 457
  77.     Else
  78.         'Add the item at nIndex
  79.         'Grow the array
  80.         mcItems = mcItems + 1
  81.         ReDim Preserve mudtItems(1 To mcItems)
  82.         'Move the items from this position to the former end
  83.         'Only move if there are items to move
  84.         If nIndex < mcItems Then
  85.             'Each item takes up 8 bytes
  86.             CopyMemory mudtItems(nIndex + 1), mudtItems(nIndex), 8 * (mcItems - nIndex)
  87.         End If
  88.         mudtItems(nIndex).Item = Item
  89.         mudtItems(nIndex).Key = Key
  90.     End If
  91. End Sub
  92.  
  93. Public Function Remove(Key As Long) As Long
  94.     Dim nIndex As Long
  95.  
  96.     If FindItem(Key, nIndex) Then
  97.         'Return the item
  98.         Remove = mudtItems(nIndex).Item
  99.         'Move the items from this position + 1 to the end
  100.         'Only move if there are items to move
  101.         If nIndex < mcItems Then
  102.             'Each item takes up 8 bytes
  103.             CopyMemory mudtItems(nIndex), mudtItems(nIndex + 1), 8 * (mcItems - nIndex)
  104.         End If
  105.         'Shrink the array
  106.         mcItems = mcItems - 1
  107.     Else
  108.         Err.Raise 5, , "There is no item with the key " & Key & "."
  109.     End If
  110. End Function
  111.  
  112. Public Sub Clear()
  113.     mcItems = 0
  114.     Erase mudtItems
  115. End Sub
  116.  
  117. 'Given a key, return an index indicating either:
  118. '   1.  The location where the item was found, or
  119. '   2.  The location where the item should be added.
  120. 'Return True to indicate case 1 and False to indicate case 2.
  121. Public Function FindItem(Key As Long, Optional Index As Long) As Boolean
  122.     Dim fFound As Boolean
  123.     Dim nSearchPos As Long
  124.     Dim nLBound As Long
  125.     Dim nUBound As Long
  126.  
  127.     'Perform a binary search on the items
  128.  
  129.     'Start with a field of search which includes all the items
  130.     nUBound = mcItems
  131.     nLBound = 1
  132.  
  133.     'Continue until the field of search is invalid
  134.     Do Until nLBound > nUBound
  135.         'Look at the item in the middle of the field of search
  136.         nSearchPos = (nLBound + nUBound) / 2
  137.         Select Case mudtItems(nSearchPos).Key
  138.             Case Key
  139.                 'We've found it! Stop the loop and remember nSearchPos.
  140.                 fFound = True
  141.                 Exit Do
  142.             Case Is < Key
  143.                 'Narrow the search to the items above nSearchPos
  144.                 nLBound = nSearchPos + 1
  145.             Case Is > Key
  146.                 'Narrow the search to the items below nSearchPos
  147.                 nUBound = nSearchPos - 1
  148.         End Select
  149.     Loop
  150.     If fFound Then
  151.         Index = nSearchPos
  152.         FindItem = True
  153.     Else
  154.         'There are three cases above which would lead to this code:
  155.         '   1.  The loop never ran because mcItems = 0
  156.         '   2.  The loop stopped because Case Is > Key raised nLBound above
  157.         '       nUBound (and above nSearchPos)
  158.         '   3.  The loop stopped because Case Is < Key lowered nUBound below
  159.         '       nLBound
  160.         'In each case, we can determine where the new item should be added
  161.         '   1.  The new item should be added at position 1
  162.         '   2.  The new item should be added at position nLBound
  163.         '   3.  The new item should be added at position nSearchPos
  164.         If nLBound > nSearchPos Then
  165.             'This means that either case 1 or 2 occurred. Therefore the new item
  166.             '   should be added at position 1 or nLBound. In case 1, nLBound = 1
  167.             '   so we can simply use nLBound
  168.             Index = nLBound
  169.         Else
  170.             'This means that case 3 occurred. Therefore the new item should be
  171.             '   added at position nSearchPos.
  172.             Index = nSearchPos
  173.         End If
  174.         'FindItem = False (implicit)
  175.     End If
  176. End Function
  177.