VB雜湊表的實現
阿新 • • 發佈:2019-01-10
VERSION 5.00 Begin VB.Form Form1 Caption = "Form1" ClientHeight = 1935 ClientLeft = 60 ClientTop = 345 ClientWidth = 3600 LinkTopic = "Form1" ScaleHeight = 1935 ScaleWidth = 3600 StartUpPosition = 3 '視窗預設 Begin VB.CommandButton Command3 Caption = "與COLLECTION物件執行效率比較" Height = 495 Left = 960 TabIndex = 2 Top = 1320 Width = 1575 End Begin VB.CommandButton Command2 Caption = "雜湊表遍歷測試" Height = 495 Left = 960 TabIndex = 1 Top = 720 Width = 1575 End Begin VB.CommandButton Command1 Caption = "雜湊表" Height = 495 Left = 960 TabIndex = 0 Top = 120 Width = 1575 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Private Sub Command1_Click() ' Dim cHash As clsHashLK Dim i As Long Set cHash = New clsHashLK cHash.AlloMem 7000 For i = 1 To 2500 cHash.Add i, i * 10 + i Next i For i = 1 To 2500 cHash.Add i, -(i * 10 + i) Next i Debug.Print cHash.Item(11) Debug.Print cHash.Item(-27500) Debug.Print cHash.Item(5500) Debug.Print cHash.IsKeyExist(1), cHash.IsKeyExist(2200) Set cHash = Nothing End Sub Private Sub Command2_Click() ' Dim cHash As clsHashLK Dim i As Long Dim datOne As Long, keyOne As Long, blEndTrav As Boolean Dim strOne As String, lngOne As Long Set cHash = New clsHashLK For i = 1 To 15 cHash.Add i, i * 2 Next i blEndTrav = False cHash.startTraversal datOne = cHash.NextItem(lngOne, strOne, keyOne, blEndTrav) i = 0 Do Until blEndTrav Debug.Print keyOne; "->"; datOne, i = i + 1: If i Mod 5 = 0 Then Debug.Print "" datOne = cHash.NextItem(lngOne, strOne, keyOne, blEndTrav) Loop Debug.Print "" Set cHash = Nothing End Sub Private Sub Command3_Click() ' Command3.Enabled = False Dim cHash As clsHashLK Dim col As Collection Dim datOne As Long, blEndTrav As Boolean Dim sngTimer As Single Dim i As Long sngTimer = Timer Set cHash = New clsHashLK cHash.AlloMem 70000 For i = 1 To 50000 cHash.Add i, i * 10 + i Next i Debug.Print "雜湊表插入資料結束,耗時:"; Timer - sngTimer; "秒" sngTimer = Timer Set col = New Collection For i = 1 To 50000 col.Add i, CStr(i * 10 + i) Next i Debug.Print "COLLECTION插入資料結束,耗時:"; Timer - sngTimer; "秒" sngTimer = Timer For i = 1 To 50000 datOne = cHash.Item(i * 10 + i) Next i Debug.Print "雜湊表按鍵訪問資料結束,耗時:"; Timer - sngTimer; "秒" sngTimer = Timer With col For i = 1 To 50000 datOne = .Item(CStr(i * 10 + i)) Next i End With Debug.Print "COLLECTION按鍵訪問資料結束,耗時:"; Timer - sngTimer; "秒" sngTimer = Timer cHash.startTraversal datOne = cHash.NextData(blEndTrav) i = 1 Do Until blEndTrav datOne = cHash.NextData(blEndTrav) i = i + 1 Loop Debug.Print "雜湊表遍歷資料結束,耗時:"; Timer - sngTimer; "秒", i sngTimer = Timer With col For i = 1 To 50000 datOne = .Item(i) Next i End With Debug.Print "COLLECTION遍歷資料結束,耗時:"; Timer - sngTimer; "秒", i Set col = Nothing Set cHash = Nothing Command3.Enabled = True End Sub
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "clsHashLK" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private Type Hs_DataType Key As Long Data As Long DataLong As Long DataString As String Used As Byte End Type Private lMem() As Hs_DataType, lMemCount As Long, lMemUsedCount As Long Private lMem2() As Hs_DataType, lMemCount2 As Long, lMemUsedCount2 As Long Private mTravIdxCurr As Long Private Const mcIniMemSize As Long = 10 Private Const mcMaxItemCount As Long = 214748364 Private Const mcExpandMaxPort As Single = 0.75 Private Const mcExpandCountThres As Long = 10000 Private Const mcExpandCountThresMax As Long = 10000000 Private Const mcExpandBigPer As Long = 1000000 Private Const mcExpandMem2Per As Long = 10 Private Const mcSeqMax As Long = 5 Public Function Add(ByVal Data As Long, ByVal Key As Long, Optional ByVal DataLong As Long, Optional ByVal DataString As String, _ Optional ByVal RaiseErrorIfNotHas As Boolean = True) As Boolean ' Dim lngIdx As Long If lMemUsedCount + lMemUsedCount2 > mcMaxItemCount Then If RaiseErrorIfNotHas Then Err.Raise 7 Add = False Exit Function End If If IsKeyExist(Key) Then If RaiseErrorIfNotHas Then Err.Raise 5 Add = False Exit Function End If lngIdx = AlloMemIndex(Key) If lngIdx > 0 Then With lMem(lngIdx) .Data = Data .DataLong = DataLong .DataString = DataString .Key = Key .Used = 1 End With lMemUsedCount = lMemUsedCount + 1 Else With lMem2(-lngIdx) .Data = Data .DataLong = DataLong .DataString = DataString .Key = Key .Used = 1 End With lMemUsedCount2 = lMemUsedCount2 + 1 End If mTravIdxCurr = 0 Add = True End Function Public Function Item(ByVal Key As Long, Optional ByVal RaiseErrorIfNotHas As Boolean = True) As Long ' Dim lngIdx As Long lngIdx = FindMemIndex(Key) If lngIdx = 0 Then If RaiseErrorIfNotHas Then Err.Raise 5 Item = 0 Exit Function ElseIf lngIdx > 0 Then Item = lMem(lngIdx).Data Else Item = lMem2(-lngIdx).Data End If End Function Public Function DataLong(ByVal Key As Long, Optional ByVal RaiseErrorIfNotHas As Boolean = True) As Long ' Dim lngIdx As Long lngIdx = FindMemIndex(Key) If lngIdx = 0 Then If RaiseErrorIfNotHas Then Err.Raise 5 DataLong = 0 Exit Function ElseIf lngIdx > 0 Then DataLong = lMem(lngIdx).DataLong Else DataLong = lMem2(-lngIdx).DataLong End If End Function Public Function DataString(ByVal Key As Long, Optional ByVal RaiseErrorIfNotHas As Boolean = True) As String ' Dim lngIdx As Long lngIdx = FindMemIndex(Key) If lngIdx = 0 Then If RaiseErrorIfNotHas Then Err.Raise 5 DataString = "" Exit Function ElseIf lngIdx > 0 Then DataString = lMem(lngIdx).DataString Else DataString = lMem2(-lngIdx).DataString End If End Function Public Function Remove(ByVal Key As Long, Optional ByVal RaiseErrorIfNotHas As Boolean = True) As Boolean ' Dim lngIdx As Long lngIdx = FindMemIndex(Key) If lngIdx = 0 Then If RaiseErrorIfNotHas Then Err.Raise 5 Remove = False Exit Function ElseIf lngIdx > 0 Then With lMem(lngIdx) .Used = 0 .Key = 0 End With lMemUsedCount = lMemUsedCount - 1 Else Dim i As Long For i = -lngIdx To lMemUsedCount2 - 1 lMem2(i) = lMem(i + 1) Next i lMemUsedCount2 = lMemUsedCount2 - 1 End If mTravIdxCurr = 0 Remove = True End Function Private Function AlloMemIndex(ByVal Key As Long, Optional ByVal CanExpandMem As Boolean = True) As Long ' Const cMaxNumForSquare As Long = 46340 Dim idxMod As Long, idxSq As Long Dim idxModRev As Long, idxSqRev As Long Dim lngCount As Long Dim keyToCalc As Long keyToCalc = Key If keyToCalc < 0 Then keyToCalc = 0 - keyToCalc lngCount = lMemUsedCount + lMemUsedCount2 ' 1 idxMod = keyToCalc Mod lMemCount + 1 If lMem(idxMod).Used = 0 Then AlloMemIndex = idxMod: Exit Function ' 2 If keyToCalc <= cMaxNumForSquare Then idxSq = (keyToCalc * keyToCalc) Mod lMemCount + 1 Else idxSq = Sqr(keyToCalc) Mod lMemCount + 1 End If If lMem(idxSq).Used = 0 Then AlloMemIndex = idxSq: Exit Function ' 3 idxModRev = lMemCount - idxMod + 1 If lMem(idxModRev).Used = 0 Then AlloMemIndex = idxModRev: Exit Function ' 4 idxSqRev = lMemCount - idxSq + 1 If lMem(idxSqRev).Used = 0 Then AlloMemIndex = idxSqRev: Exit Function ' 5 If CanExpandMem And lngCount > mcExpandMaxPort * lMemCount Then ExpandMem AlloMemIndex = AlloMemIndex(Key, CanExpandMem) Exit Function End If Dim lngRetIdx As Long Dim idxMdSta As Long, idxMdEnd As Long idxMdSta = idxMod - mcSeqMax idxMdEnd = idxMod + mcSeqMax lngRetIdx = AlloSeqIdx(idxMdSta, idxMod - 1) If lngRetIdx > 0 Then AlloMemIndex = lngRetIdx: Exit Function lngRetIdx = AlloSeqIdx(idxMod + 1, idxMdEnd) If lngRetIdx > 0 Then AlloMemIndex = lngRetIdx: Exit Function Dim lngSqSta As Long, lngSqEnd As Long lngSqSta = idxSq - mcSeqMax: lngSqEnd = idxSq + mcSeqMax If lngSqSta < 1 Then lngSqSta = 1 If lngSqEnd > lMemCount Then lngSqEnd = lMemCount If lngSqEnd < idxMdSta Then lngRetIdx = AlloSeqIdx(lngSqSta, lngSqEnd) If lngRetIdx > 0 Then AlloMemIndex = lngRetIdx: Exit Function ElseIf lngSqEnd <= idxMdEnd Then If lngSqSta < idxMdSta Then lngSqEnd = idxMdSta - 1 lngRetIdx = AlloSeqIdx(lngSqSta, lngSqEnd) If lngRetIdx > 0 Then AlloMemIndex = lngRetIdx: Exit Function Else lngSqSta = 0: lngSqEnd = 0 End If Else If lngSqSta > idxMdEnd Then lngRetIdx = AlloSeqIdx(lngSqSta, lngSqEnd) If lngRetIdx > 0 Then AlloMemIndex = lngRetIdx: Exit Function ElseIf lngSqSta >= idxMdSta Then lngSqSta = idxMdEnd + 1 lngRetIdx = AlloSeqIdx(lngSqSta, lngSqEnd) If lngRetIdx > 0 Then AlloMemIndex = lngRetIdx: Exit Function Else lngRetIdx = AlloSeqIdx(lngSqSta, idxMdSta - 1) If lngRetIdx > 0 Then AlloMemIndex = lngRetIdx: Exit Function lngRetIdx = AlloSeqIdx(idxMdEnd + 1, lngSqEnd) If lngRetIdx > 0 Then AlloMemIndex = lngRetIdx: Exit Function End If End If If lMemUsedCount2 + 1 > lMemCount2 Then lMemCount2 = lMemCount2 + mcExpandMem2Per ReDim Preserve lMem2(1 To lMemCount2) End If AlloMemIndex = -(lMemUsedCount2 + 1) End Function Private Function AlloSeqIdx(ByVal fromIndex As Long, ByVal toIndex As Long) As Long ' Dim i As Long, fCt As Long If fromIndex <= 0 Then fromIndex = 1 If toIndex > lMemCount Then toIndex = lMemCount For i = fromIndex To toIndex If lMem(i).Used = 0 Then AlloSeqIdx = i: Exit Function Next i AlloSeqIdx = 0 End Function Private Sub ExpandMem() ' Dim lngCount As Long, lngPreMemCount As Long lngCount = lMemUsedCount + lMemUsedCount2 If lngCount < lMemCount Then lngCount = lMemCount lngPreMemCount = lMemCount If lngCount < mcExpandCountThres Then lngCount = lngCount * 2 ElseIf lngCount < mcExpandCountThresMax Then lngCount = lngCount * 3 / 2 Else lngCount = lngCount + mcExpandBigPer End If lMemCount = lngCount ReDim Preserve lMem(1 To lMemCount) ReLocaMem lngPreMemCount End Sub Private Sub ReLocaMem(ByVal preMemCountTo As Long) ' Dim memUsed() As Hs_DataType, lngUsedCount As Long Dim i As Long ReDim memUsed(1 To preMemCountTo + lMemUsedCount2) lngUsedCount = 0 lMemUsedCount = 0 For i = 1 To preMemCountTo If lMem(i).Used Then lngUsedCount = lngUsedCount + 1 memUsed(lngUsedCount) = lMem(i) End If Next i For i = 1 To lMemUsedCount2 lngUsedCount = lngUsedCount + 1 memUsed(lngUsedCount) = lMem2(i) Next i ReDim lMem(1 To lMemCount) Erase lMem2 lMemCount2 = 0 lMemUsedCount2 = 0 lMemUsedCount = 0 Dim lngIdx As Long For i = 1 To lngUsedCount lngIdx = AlloMemIndex(memUsed(i).Key, False) If lngIdx > 0 Then lMem(lngIdx) = memUsed(i) lMem(lngIdx).Used = 1 lMemUsedCount = lMemUsedCount + 1 Else lMem2(-lngIdx) = memUsed(i) lMem2(-lngIdx).Used = 1 lMemUsedCount2 = lMemUsedCount2 + 1 End If Next i mTravIdxCurr = 0 End Sub Public Function IsKeyExist(ByVal Key As Long) As Boolean ' Dim lngIdx As Long lngIdx = FindMemIndex(Key) IsKeyExist = (lngIdx <> 0) End Function Public Sub startTraversal() ' mTravIdxCurr = 1 End Sub Public Function NextItem(Optional ByRef rDataLong As Long, Optional ByRef rDataString As String, Optional ByRef rKey As Long, _ Optional ByRef bRetNotValid As Boolean = False) As Long ' Dim lngIdx As Long lngIdx = TraversalGetNextIdx If lngIdx > 0 Then With lMem(lngIdx) NextItem = .Data rDataLong = .DataLong rDataString = .DataString rKey = .Key End With ElseIf lngIdx < 0 Then With lMem2(-lngIdx) NextItem = .Data rDataLong = .DataLong rDataString = .DataString rKey = .Key End With Else bRetNotValid = True Exit Function End If End Function Public Function NextData(Optional ByRef bRetNotValid As Boolean = False) As Long ' Dim lngIdx As Long lngIdx = TraversalGetNextIdx If lngIdx > 0 Then NextData = lMem(lngIdx).Data ElseIf lngIdx < 0 Then NextData = lMem2(-lngIdx).Data Else bRetNotValid = True Exit Function End If End Function Public Function NextDataLong(Optional ByRef bRetNotValid As Boolean = False) As Long ' Dim lngIdx As Long lngIdx = TraversalGetNextIdx If lngIdx > 0 Then NextDataLong = lMem(lngIdx).DataLong ElseIf lngIdx < 0 Then NextDataLong = lMem2(-lngIdx).DataLong Else bRetNotValid = True End If End Function Public Function NextDataString(Optional ByRef bRetNotValid As Boolean = False) As String ' Dim lngIdx As Long lngIdx = TraversalGetNextIdx If lngIdx > 0 Then NextDataString = lMem(lngIdx).DataString ElseIf lngIdx < 0 Then NextDataString = lMem2(-lngIdx).DataString Else bRetNotValid = True Exit Function End If End Function Public Function NextKey(Optional ByRef bRetNotValid As Boolean = False) As Long ' Dim lngIdx As Long lngIdx = TraversalGetNextIdx If lngIdx > 0 Then NextKey = lMem(lngIdx).Key ElseIf lngIdx < 0 Then NextKey = lMem2(-lngIdx).Key Else bRetNotValid = True Exit Function End If End Function Public Function GetDataArray(retData() As Long) As Long ' Dim lngCount As Long Dim i As Long, j As Long lngCount = lMemUsedCount + lMemUsedCount2 If lngCount <= 0 Then GetDataArray = 0: Exit Function ReDim retData(1 To lngCount) j = 1 For i = 1 To lMemCount If lMem(i).Used Then retData(j) = lMem(i).Data j = j + 1 End If Next i For i = 1 To lMemUsedCount2 If lMem2(i).Used Then retData(j) = lMem2(i).Data j = j + 1 End If Next i GetDataArray = lngCount End Function Public Function GetDataLongArray(retDataLong() As Long) As Long ' Dim lngCount As Long Dim i As Long, j As Long lngCount = lMemUsedCount + lMemUsedCount2 If lngCount <= 0 Then GetDataLongArray = 0: Exit Function ReDim retDataLong(1 To lngCount) j = 1 For i = 1 To lMemCount If lMem(i).Used Then retDataLong(j) = lMem(i).DataLong j = j + 1 End If Next i For i = 1 To lMemUsedCount2 If lMem2(i).Used Then retDataLong(j) = lMem2(i).DataLong j = j + 1 End If Next i GetDataLongArray = lngCount End Function Public Function GetDataStringArray(retDataString() As String) As Long ' Dim lngCount As Long Dim i As Long, j As Long lngCount = lMemUsedCount + lMemUsedCount2 If lngCount <= 0 Then GetDataStringArray = 0: Exit Function ReDim retDataString(1 To lngCount) j = 1 For i = 1 To lMemCount If lMem(i).Used Then retDataString(j) = lMem(i).DataString j = j + 1 End If Next i For i = 1 To lMemUsedCount2 If lMem2(i).Used Then retDataString(j) = lMem2(i).DataString j = j + 1 End If Next i GetDataStringArray = lngCount End Function Public Function GetKeyArray(retKeys() As Long) As Long ' Dim lngCount As Long Dim i As Long, j As Long lngCount = lMemUsedCount + lMemUsedCount2 If lngCount <= 0 Then GetKeyArray = 0: Exit Function ReDim retKeys(1 To lngCount) j = 1 For i = 1 To lMemCount If lMem(i).Used Then retKeys(j) = lMem(i).Key j = j + 1 End If Next i For i = 1 To lMemUsedCount2 If lMem2(i).Used Then retKeys(j) = lMem2(i).Key j = j + 1 End If Next i GetKeyArray = lngCount End Function Public Sub Clear() ' Erase lMem Erase lMem2 lMemCount = 0: lMemUsedCount = 0 lMemCount2 = 0: lMemUsedCount2 = 0 lMemCount = mcIniMemSize ReDim lMem(1 To lMemCount) lMemUsedCount = 0 lMemCount2 = 0 lMemUsedCount2 = 0 mTravIdxCurr = 0 End Sub Public Sub AlloMem(ByVal memSize As Long) ' If memSize <= lMemUsedCount Or memSize > mcMaxItemCount Then Exit Sub Dim lngPreMemCount As Long lngPreMemCount = lMemCount lMemCount = memSize ReDim Preserve lMem(1 To lMemCount) ReLocaMem lngPreMemCount End Sub Private Function FindMemIndex(ByVal Key As Long) As Long ' Const cMaxNumForSquare As Long = 46340 Dim idxMod As Long, idxSq As Long Dim idxModRev As Long, idxSqRev As Long Dim i As Long Dim keyToCalc As Long keyToCalc = Key If keyToCalc < 0 Then keyToCalc = 0 - keyToCalc ' 1 idxMod = keyToCalc Mod lMemCount + 1 If lMem(idxMod).Used And lMem(idxMod).Key = Key Then FindMemIndex = idxMod Exit Function End If ' 2 If keyToCalc <= cMaxNumForSquare Then idxSq = (keyToCalc * keyToCalc) Mod lMemCount + 1 Else idxSq = Sqr(keyToCalc) Mod lMemCount + 1 End If If lMem(idxSq).Used And lMem(idxSq).Key = Key Then FindMemIndex = idxSq Exit Function End If ' 3 idxModRev = lMemCount - idxMod + 1 If lMem(idxModRev).Used And lMem(idxModRev).Key = Key Then FindMemIndex = idxModRev Exit Function End If ' 4 idxSqRev = lMemCount - idxSq + 1 If lMem(idxSqRev).Used And lMem(idxSqRev).Key = Key Then FindMemIndex = idxSqRev Exit Function End If ' 6 Dim lngRetIdx As Long Dim idxMdSta As Long, idxMdEnd As Long idxMdSta = idxMod - mcSeqMax idxMdEnd = idxMod + mcSeqMax lngRetIdx = FindSeqIdx(Key, idxMdSta, idxMod - 1) If lngRetIdx > 0 Then FindMemIndex = lngRetIdx Exit Function End If lngRetIdx = FindSeqIdx(Key, idxMod + 1, idxMdEnd) If lngRetIdx > 0 Then FindMemIndex = lngRetIdx Exit Function End If ' 7 Dim lngSqSta As Long, lngSqEnd As Long lngSqSta = idxSq - mcSeqMax lngSqEnd = idxSq + mcSeqMax If lngSqSta < 1 Then lngSqSta = 1 If lngSqEnd > lMemCount Then lngSqEnd = lMemCount If lngSqEnd < idxMdSta Then lngRetIdx = FindSeqIdx(Key, lngSqSta, lngSqEnd) If lngRetIdx > 0 Then FindMemIndex = lngRetIdx: Exit Function ElseIf lngSqEnd <= idxMdEnd Then If lngSqSta < idxMdSta Then lngSqEnd = idxMdSta - 1 lngRetIdx = FindSeqIdx(Key, lngSqSta, lngSqEnd) If lngRetIdx > 0 Then FindMemIndex = lngRetIdx: Exit Function Else lngSqSta = 0: lngSqEnd = 0 End If Else If lngSqSta > idxMdEnd Then lngRetIdx = FindSeqIdx(Key, lngSqSta, lngSqEnd) If lngRetIdx > 0 Then FindMemIndex = lngRetIdx: Exit Function ElseIf lngSqSta >= idxMdSta Then lngSqSta = idxMdEnd + 1 lngRetIdx = FindSeqIdx(Key, lngSqSta, lngSqEnd) If lngRetIdx > 0 Then FindMemIndex = lngRetIdx: Exit Function Else lngRetIdx = FindSeqIdx(Key, lngSqSta, idxMdSta - 1) If lngRetIdx > 0 Then FindMemIndex = lngRetIdx: Exit Function lngRetIdx = FindSeqIdx(Key, idxMdEnd + 1, lngSqEnd) If lngRetIdx > 0 Then FindMemIndex = lngRetIdx: Exit Function End If End If For i = 1 To lMemUsedCount2 If lMem2(i).Used And lMem2(i).Key = Key Then FindMemIndex = -i: Exit Function Next i FindMemIndex = 0 End Function Private Function FindSeqIdx(ByVal Key As Long, ByVal fromIndex As Long, ByVal toIndex As Long) As Long ' Dim i As Long, fCt As Long If fromIndex < 1 Then fromIndex = 1 If toIndex > lMemCount Then toIndex = lMemCount For i = fromIndex To toIndex If lMem(i).Used And lMem(i).Key = Key Then FindSeqIdx = 1 Exit Function End If Next i FindSeqIdx = 0 End Function Private Function TraversalGetNextIdx() As Long ' Dim lngRetIdx As Long If mTravIdxCurr > lMemCount Or -mTravIdxCurr > lMemCount2 Or mTravIdxCurr = 0 Then lngRetIdx = 0 Exit Function End If If mTravIdxCurr > 0 Then Do Until lMem(mTravIdxCurr).Used mTravIdxCurr = mTravIdxCurr + 1 If mTravIdxCurr > lMemCount Then Exit Do Loop If mTravIdxCurr > lMemCount Then If lMemCount2 > 0 Then mTravIdxCurr = -1 Else lngRetIdx = 0 TraversalGetNextIdx = lngRetIdx Exit Function End If Else lngRetIdx = mTravIdxCurr mTravIdxCurr = mTravIdxCurr + 1 If mTravIdxCurr > lMemCount Then If lMemCount2 > 0 Then mTravIdxCurr = -1 TraversalGetNextIdx = lngRetIdx Exit Function End If End If If mTravIdxCurr < 0 Then Do Until lMem2(-mTravIdxCurr).Used mTravIdxCurr = mTravIdxCurr - 1 If -mTravIdxCurr > lMemCount2 Then Exit Do Loop If -mTravIdxCurr > lMemCount2 Then lngRetIdx = 0 Else lngRetIdx = mTravIdxCurr mTravIdxCurr = mTravIdxCurr - 1 End If TraversalGetNextIdx = lngRetIdx End If End Function Private Sub Class_Initialize() ' lMemCount = mcIniMemSize ReDim lMem(1 To lMemCount) lMemUsedCount = 0 lMemCount2 = 0 lMemUsedCount2 = 0 End Sub Private Sub Class_Terminate() ' Erase lMem Erase lMem2 lMemCount = 0: lMemUsedCount = 0 lMemCount2 = 0: lMemUsedCount2 = 0 End Sub Public Property Get Count() As Long ' Count = lMemUsedCount + lMemUsedCount2 End Property