VB哈希表的实现

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,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,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,lngSqEnd)
            If lngRetIdx > 0 Then FindMemIndex = lngRetIdx: Exit Function
        Else
            lngSqSta = 0: lngSqEnd = 0
        End If
    Else
        If lngSqSta > idxMdEnd Then
            lngRetIdx = FindSeqIdx(Key,lngSqEnd)
            If lngRetIdx > 0 Then FindMemIndex = lngRetIdx: Exit Function
        ElseIf lngSqSta >= idxMdSta Then
            lngSqSta = idxMdEnd + 1
            lngRetIdx = FindSeqIdx(Key,lngSqEnd)
            If lngRetIdx > 0 Then FindMemIndex = lngRetIdx: Exit Function
        Else
            lngRetIdx = FindSeqIdx(Key,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,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

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!