Hash and Stack VBA modules

In order to add some nice error handling and single location easily modified strings in Access (within VBA) I’ve decided to utilise a hash** and a stack.

** – As pointed out by Anon there isn’t really any benefit to rolling your own Hash – use the Scripting.Dictionary instead. Unless you need to avoid including extra libraries (Microsoft Scripting Runtime) or are working with something less than Office 2000 (apparently the runtime is also within windows 2000) in which case my sincere sympathy is with you.

These structures can be created in three classes in any VBA project (only tested in Access and Excel under WinXP).

• StackItem ~ Similar to a node in a linked list just contains the element and a reference to another StackItem (pointer substitute)
• Stack ~ consists of a number of simple functions
• Push ~ add your item to the top
• Pop ~ get and remove item from top
• StackTop ~ returns the topmost StackItem
• StackEmpty ~ true if no items on the stack (a fact shown when top equals nothing)
• Class_Initialize ~ set top (the default node), to nothing
• StackDump ~ a string representation of the entire stack
• HashTable ~ the original strain of this hash table

Now we’ve done the plumbing the next article will describe the niceties.

Code

StackItem

Option Explicit

Public Value As Variant
Public NextItem As StackItem

Stack

Option Explicit

Private Top As StackItem

Public Property Get StackEmpty() As Boolean
  On Error Resume Next

  StackEmpty = (Top Is Nothing)
End Property

Public Property Get StackTop() As Variant
  On Error Resume Next
  
  If StackEmpty Then
    StackTop = Null
  Else
    StackTop = Top.Value
  End If
End Property

Private Sub Class_Initialize()
  On Error Resume Next
  
  Set Top = Nothing
End Sub

Public Sub Push(ByVal var As Variant)
  On Error Resume Next
  
  Dim newTop As New StackItem
  
  newTop.Value = var
  Set newTop.NextItem = Top
  Set Top = newTop

End Sub

Public Function Pop() As Variant
  On Error Resume Next
  
  If Not StackEmpty Then
    Pop = Top.Value
    Set Top = Top.NextItem
  End If
End Function

Public Function StackDump(Optional ByVal delim As String) As String
  On Error Resume Next
  
  Dim dump As String
  Dim item As New StackItem
  
  Set item = Top
  
  dump = delim & item.Value
  
  Do While Not item.NextItem Is Nothing
    Set item = item.NextItem
    dump = dump & delim & item.Value
  Loop
  
  StackDump = Right(dump, Len(dump) - 2)
End Function

HashTable

Option Explicit

Private Const DefaultHashSize = 1024
Private Const DefaultListSize = 2048
Private Const DefaultChunkSize = 1024

Private Const Self = "HashTable"

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, src As Any, ByVal bytes As Long)

Private Type SlotType
  Key As String
  Value As Variant
  NextItem As Long
End Type

Private HashFirstElement() As Long
Private SlotTable() As SlotType

Private SlotFirstFree As Long
Private HashTableSize As Long
Private SlotTableSize As Long
Private LocalChunkSize As Long
Private SlotTableCount As Long

Private CaseInsensitive As Boolean

Public Property Get IgnoreCase() As Boolean
  On Error GoTo ErrorGoTo

  Util.PushStack "Get IgnoreCase (" & Self & ")"
  IgnoreCase = CaseInsensitive
ExitGoTo:
  Util.PopStack
  Exit Property
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Property

'Can be assigned only when the hash table is empty
Public Property Let IgnoreCase(ByVal newValue As Boolean)
  On Error GoTo ErrorGoTo

  Util.PushStack "Let IgnoreCase (" & Self & ")"
  
  If SlotTableCount Then
    Err.Raise 65000, "IgnoreCase", "Error message"
    Util.GetVariable ("HashTableNotEmpty")
  End If
  
  CaseInsensitive = newValue
ExitGoTo:
  Util.PopStack
  Exit Property
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Property

Public Sub SetSize(ByVal HashSize As Long, Optional ByVal ListSize As Long, Optional ByVal ChunkSize As Long)
  On Error GoTo ErrorGoTo
  
  Util.PushStack "SetSize (" & Self & ")"
  'defaults
  If ListSize <= 0 Then
    ListSize = SlotTableSize
  End If
  If ChunkSize <= 0 Then
    ChunkSize = LocalChunkSize
  End If
  
  HashTableSize = HashSize
  SlotTableSize = ListSize
  LocalChunkSize = ChunkSize
  SlotTableCount = 0
  'rebuild tables
  SlotFirstFree = 0
  
  ReDim HashFirstElement(0 To HashSize - 1) As Long
  ReDim SlotTable(0) As SlotType
  
  ExpandSlotTable SlotTableSize
ExitGoTo:
  Util.PopStack
  Exit Sub
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Sub

Public Function Exists(Key As String) As Boolean
  On Error GoTo ErrorGoTo
  
  Util.PushStack "Exists (" & Self & ")"
  Exists = GetSlotIndex(Key) <> 0
ExitGoTo:
  Util.PopStack
  Exit Function
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Function

Public Sub Add(Key As String, Value As Variant)
  On Error GoTo ErrorGoTo
  
  Util.PushStack "Add (" & Self & ")"
  
  Dim ndx As Long, Create As Boolean
  ' get the index to the slot where the value is (allocate a new slot if necessary)
  Create = True
  ndx = GetSlotIndex(Key, Create)
  
  If Create Then
    ' the item was actually added
    If IsObject(Value) Then
      Set SlotTable(ndx).Value = Value
    Else
      SlotTable(ndx).Value = Value
    End If
  Else
    Err.Raise 65000, "Add", "Error message"
    Util.GetVariable ("HashTableKeyAlreadyUsed")
  End If
  
ExitGoTo:
  Util.PopStack
  Exit Sub
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Sub

Public Property Get item(Key As String) As Variant
  On Error GoTo ErrorGoTo
  
  Util.PushStack "Get item (" & Self & ")"
  
  Dim ndx As Long
  ndx = GetSlotIndex(Key)
  
  If ndx = 0 Then
    'return Empty if not found
  ElseIf IsObject(SlotTable(ndx).Value) Then
    Set item = SlotTable(ndx).Value
  Else
    item = SlotTable(ndx).Value
  End If

ExitGoTo:
  Util.PopStack
  Exit Property
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Property

Public Property Let item(Key As String, Value As Variant)
  On Error GoTo ErrorGoTo
  
  Util.PushStack "Let item (" & Self & ")"
  
  Dim ndx As Long
  'get the index to the slot where the value is (allocate a new slot if necessary)
  ndx = GetSlotIndex(Key, True)
  'store the value
  SlotTable(ndx).Value = Value

ExitGoTo:
  Util.PopStack
  Exit Property
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Property

Public Property Set item(Key As String, Value As Object)
  On Error GoTo ErrorGoTo
  
  Util.PushStack "Set item (" & Self & ")"
  
  Dim ndx As Long
  'Get the index to the slot where the value is (allocate a new slot if necessary)
  ndx = GetSlotIndex(Key, True)
  'Store the value
  Set SlotTable(ndx).Value = Value
ExitGoTo:
  Util.PopStack
  Exit Property
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Property

Public Sub Remove(Key As String)
  On Error GoTo ErrorGoTo
  
  Util.PushStack "Remove (" & Self & ")"
  
  Dim ndx As Long, HCode As Long, LastNdx As Long
  ndx = GetSlotIndex(Key, False, HCode, LastNdx)
  
  If ndx = 0 Then
    Err.Raise 65000, "Remove", "Error message"
    Util.GetVariable ("HashTableRemoveNonExistingKey")
  End If
  
  If LastNdx Then
    'this isn't the first item in the SlotTable() array
    SlotTable(LastNdx).NextItem = SlotTable(ndx).NextItem
  ElseIf SlotTable(ndx).NextItem Then
    'this is the first item in the SlotTable() array and is followed by one or more items
    HashFirstElement(HCode) = SlotTable(ndx).NextItem
  Else
    'this is the only item in the SlotTable() array for this hash code
    HashFirstElement(HCode) = 0
  End If
  
  ' put the element back in the free list
  SlotTable(ndx).NextItem = SlotFirstFree
  SlotFirstFree = ndx
  ' we have deleted an item
  SlotTableCount = SlotTableCount - 1
ExitGoTo:
  Util.PopStack
  Exit Sub
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Sub

Public Sub RemoveAll()
  On Error GoTo ErrorGoTo
  
  Util.PushStack "RemoveAll (" & Self & ")"
  
  SetSize HashTableSize, SlotTableSize, LocalChunkSize
ExitGoTo:
  Util.PopStack
  Exit Sub
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Sub

Public Property Get Count() As Long
  On Error GoTo ErrorGoTo
  
  Util.PushStack "Get Count (" & Self & ")"
  
  Count = SlotTableCount
ExitGoTo:
  Util.PopStack
  Exit Property
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Property

Public Property Get Keys() As Variant()
  On Error GoTo ErrorGoTo
  
  Util.PushStack "Get Keys (" & Self & ")"
  
  Dim i As Long, ndx As Long
  Dim n As Long
  ReDim res(0 To SlotTableCount - 1) As Variant
  
  For i = 0 To HashTableSize - 1
    ' take the pointer from the hash table
    ndx = HashFirstElement(i)
    ' walk the SlotTable() array
    Do While ndx
      res(n) = SlotTable(ndx).Key
      n = n + 1
      ndx = SlotTable(ndx).NextItem
    Loop
  Next
  
  Keys = res()
ExitGoTo:
  Util.PopStack
  Exit Property
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Property

Public Property Get Values() As Variant()
  On Error GoTo ErrorGoTo
  
  Util.PushStack "Get Values (" & Self & ")"
  
  Dim i As Long, ndx As Long
  Dim n As Long
  ReDim res(0 To SlotTableCount - 1) As Variant
  
  For i = 0 To HashTableSize - 1
    ' take the pointer from the hash table
    ndx = HashFirstElement(i)
    ' walk the SlotTable() array
    Do While ndx
      res(n) = SlotTable(ndx).Value
      n = n + 1
      ndx = SlotTable(ndx).NextItem
    Loop
  Next
  
  Values = res()
  
ExitGoTo:
  Util.PopStack
  Exit Property
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Property

Private Sub Class_Initialize()
  On Error GoTo ErrorGoTo
  
  Util.PushStack "Class_Initialize (" & Self & ")"
  SetSize DefaultHashSize, DefaultListSize, DefaultChunkSize
  
ExitGoTo:
  Util.PopStack
  Exit Sub
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Sub

Private Sub ExpandSlotTable(ByVal numEls As Long)
  On Error GoTo ErrorGoTo
  
  Util.PushStack "ExpandSlotTable (" & Self & ")"
  
  Dim newSlotFirstFree As Long, i As Long
  newSlotFirstFree = UBound(SlotTable) + 1
  ReDim Preserve SlotTable(0 To UBound(SlotTable) + numEls) As SlotType
  ' create the linked list of free items
  
  For i = newSlotFirstFree To UBound(SlotTable)
    SlotTable(i).NextItem = i + 1
  Next
  
  ' overwrite the last (wrong) value
  SlotTable(UBound(SlotTable)).NextItem = SlotFirstFree
  ' we now know where to pick the first free item
  SlotFirstFree = newSlotFirstFree
  
ExitGoTo:
  Util.PopStack
  Exit Sub
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Sub

Private Function HashCode(Key As String) As Long
  On Error GoTo ErrorGoTo
  
  Util.PushStack "HashCode (" & Self & ")"
  
  Dim lastEl As Long, i As Long
  ' copy ansi codes into an array of long
  lastEl = (Len(Key) - 1) \ 4
  ReDim codes(lastEl) As Long
  ' this also converts from Unicode to ANSI
  CopyMemory codes(0), ByVal Key, Len(Key)
  ' XOR the ANSI codes of all characters
  
  For i = 0 To lastEl
    HashCode = HashCode Xor codes(i)
  Next
  
ExitGoTo:
  Util.PopStack
  Exit Function
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Function

Private Function GetSlotIndex(ByVal Key As String, Optional Create As Boolean, Optional HCode As Long, Optional LastNdx As Long) As Long
  'Get the index where an item is stored or 0 if not found if Create = True the item is created
  'On exit Create=True only if a slot has been actually created
  On Error GoTo ErrorGoTo
  
  Util.PushStack "GetSlotIndex (" & Self & ")"
  
  Dim ndx As Long
  
  If Len(Key) = 0 Then
    Err.Raise 65000, "GetSlotIndex", "Error message"
    Util.GetVariable ("HashTableGetSlotIndexInvalidKey")
  End If
  
  'take case-sensitivity into account
  If CaseInsensitive Then
    Key = UCase$(Key)
  End If
  
  ' get the index in the HashFirstElement() array
  HCode = HashCode(Key) Mod HashTableSize
  ' get the pointer to the SlotTable() array
  ndx = HashFirstElement(HCode)
  
  ' exit if there is no item with that hash code
  Do While ndx
    ' compare key with actual value
    If SlotTable(ndx).Key = Key Then
      Exit Do
    End If
    ' remember last pointer
    LastNdx = ndx
    ' check the next item
    ndx = SlotTable(ndx).NextItem
  Loop
  
  ' create a new item if not there
  If ndx = 0 And Create Then
    ndx = GetFreeSlot()
    PrepareSlot ndx, Key, HCode, LastNdx
  Else
    ' signal that no item has been created
    Create = False
  End If
  
  ' this is the return value
  GetSlotIndex = ndx
  
ExitGoTo:
  Util.PopStack
  Exit Function
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Function

Private Function GetFreeSlot() As Long
  On Error GoTo ErrorGoTo
  
  Util.PushStack "GetFreeSlot (" & Self & ")"
  
  ' allocate new memory if necessary
  If SlotFirstFree = 0 Then
    ExpandSlotTable LocalChunkSize
  End If
  
  ' use the first slot
  GetFreeSlot = SlotFirstFree
  ' update the pointer to the first slot
  SlotFirstFree = SlotTable(GetFreeSlot).NextItem
  ' signal this as the end of the linked list
  SlotTable(GetFreeSlot).NextItem = 0
  ' we have one more item
  SlotTableCount = SlotTableCount + 1
  
ExitGoTo:
  Util.PopStack
  Exit Function
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Function

Private Sub PrepareSlot(ByVal Index As Long, ByVal Key As String, ByVal HCode As Long, ByVal LastNdx As Long)
  On Error GoTo ErrorGoTo
  
  Util.PushStack "PrepareSlot (" & Self & ")"
  
  'assign the key, take case-sensitivity into account
  If CaseInsensitive Then
    Key = UCase$(Key)
  End If
  
  SlotTable(Index).Key = Key
  
  If LastNdx Then
    ' this is the successor of another slot
    SlotTable(LastNdx).NextItem = Index
  Else
    ' this is the first slot for a given hash code
    HashFirstElement(HCode) = Index
  End If
  
ExitGoTo:
  Util.PopStack
  Exit Sub
ErrorGoTo:
  Util.ErrorHandler
  Resume ExitGoTo
End Sub