-4 Removals
+6 Additions
VERSION 1.0 CLASSVERSION 1.0 CLASS
BEGINBEGIN
MultiUse = -1 'True MultiUse = -1 'True
Persistable = 0 'NotPersistable Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject MTSTransactionMode = 0 'NotAnMTSObject
ENDEND
Attribute VB_Name = "clsTrickHashTable"Attribute VB_Name = "clsTrickHashTable"
Attribute VB_GlobalNameSpace = FalseAttribute VB_GlobalNameSpace = False
Attribute VB_Creatable = TrueAttribute VB_Creatable = True
Attribute VB_PredeclaredId = FalseAttribute VB_PredeclaredId = False
Attribute VB_Exposed = FalseAttribute VB_Exposed = False
' clsTrickHashTable.cls - класс хеш-таблицы' clsTrickHashTable.cls - класс хеш-таблицы
' © Кривоус Анатолий Анатольевич (The trick), 2014' © Кривоус Анатолий Анатольевич (The trick), 2014
Option ExplicitOption Explicit
Public Enum CompareMethod ' Метод сравненияPublic Enum CompareMethod ' Метод сравнения
BinaryCompare BinaryCompare
TextCompare TextCompare
End EnumEnd Enum
Public Enum EnumMethod ' Метод перечисления для For eachPublic Enum EnumMethod ' Метод перечисления для For each
ENUM_BY_KEY ENUM_BY_KEY
ENUM_BY_VALUE ENUM_BY_VALUE
End EnumEnd Enum
Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpValue As Long) As LongPrivate Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpValue As Long) As Long
Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpBuffer As Long, ByVal nSize As Long) As LongPrivate Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpBuffer As Long, ByVal nSize As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As LongPrivate Declare Function VirtualAlloc Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As LongPrivate Declare Function VirtualFree Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As LongPrivate Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GetProcessHeap Lib "kernel32" () As LongPrivate Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function GetMem8 Lib "msvbvm60" (Src As Any, Dst As Any) As LongPrivate Declare Function GetMem8 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As LongPrivate Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function GetMem2 Lib "msvbvm60" (Src As Any, Dst As Any) As LongPrivate Declare Function GetMem2 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function GetMem1 Lib "msvbvm60" (Src As Any, Dst As Any) As LongPrivate Declare Function GetMem1 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As LongPrivate Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As LongPrivate Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long) As LongPrivate Declare Function memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long) As Long
Private Declare Function VarCmp Lib "oleaut32" (pvarLeft As Any, pvarRight As Any, ByVal lcid As Long, ByVal dwFlags As Long) As LongPrivate Declare Function VarCmp Lib "oleaut32" (pvarLeft As Any, pvarRight As Any, ByVal lcid As Long, ByVal dwFlags As Long) As Long
Private Declare Function VariantCopy Lib "oleaut32" (pvargDest As Any, pvargSrc As Any) As LongPrivate Declare Function VariantCopy Lib "oleaut32" (pvargDest As Any, pvargSrc As Any) As Long
Private Declare Function VariantCopyInd Lib "oleaut32" (pvarDest As Any, pvargSrc As Any) As LongPrivate Declare Function VariantCopyInd Lib "oleaut32" (pvarDest As Any, pvargSrc As Any) As Long
Private Declare Function LCMapString Lib "kernel32" Alias "LCMapStringW" (ByVal Locale As Long, ByVal dwMapFlags As Long, lpSrcStr As Any, ByVal cchSrc As Long, lpDestStr As Any, ByVal cchDest As Long) As LongPrivate Declare Function LCMapString Lib "kernel32" Alias "LCMapStringW" (ByVal Locale As Long, ByVal dwMapFlags As Long, lpSrcStr As Any, ByVal cchSrc As Long, lpDestStr As Any, ByVal cchDest As Long) As Long
Private Declare Function GetUserDefaultLCID Lib "kernel32" () As LongPrivate Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
Private Declare Function VarR4FromUI1 Lib "oleaut32" (value As Any, R4 As Any) As LongPrivate Declare Function VarR4FromUI1 Lib "oleaut32" (value As Any, R4 As Any) As Long
Private Declare Function VarR4FromI2 Lib "oleaut32" (value As Any, R4 As Any) As LongPrivate Declare Function VarR4FromI2 Lib "oleaut32" (value As Any, R4 As Any) As Long
Private Declare Function VarR4FromI4 Lib "oleaut32" (value As Any, R4 As Any) As LongPrivate Declare Function VarR4FromI4 Lib "oleaut32" (value As Any, R4 As Any) As Long
Private Const LCMAP_LOWERCASE As Long = &H100Private Const LCMAP_LOWERCASE As Long = &H100
Private Const PAGE_EXECUTE_READWRITE As Long = &H40&Private Const PAGE_EXECUTE_READWRITE As Long = &H40&
Private Const MEM_COMMIT As Long = &H1000&Private Const MEM_COMMIT As Long = &H1000&
Private Const MEM_RESERVE As Long = &H2000&Private Const MEM_RESERVE As Long = &H2000&
Private Const MEM_RELEASE As Long = &H8000&Private Const MEM_RELEASE As Long = &H8000&
Private Const HEAP_NO_SERIALIZE As Long = &H1Private Const HEAP_NO_SERIALIZE As Long = &H1
Private Const GRANULARITY As Long = &H20Private Const GRANULARITY As Long = &H20
Private Const HASH_SIZE As Long = 2999Private Const HASH_SIZE As Long = 2999
Private Type tPointer ' Индекс в таблице объектовPrivate Type tPointer ' Индекс в таблице объектов
hash As Integer ' Хэш hash As Integer ' Хэш
Index As Integer ' Индекс Index As Integer ' Индекс
End TypeEnd Type
Private Type tElement ' Колонка хэш таблицыPrivate Type tElement ' Колонка хэш таблицы
Key As Variant ' Ключ Key As Variant ' Ключ
value As Variant ' Значение value As Variant ' Значение
Next As tPointer ' Индекс следующего элемента Next As tPointer ' Индекс следующего элемента
Prev As tPointer ' Индекс предыдущего элемента Prev As tPointer ' Индекс предыдущего элемента
End TypeEnd Type
Private Type tItem ' Строка хэш таблицыPrivate Type tItem ' Строка хэш таблицы
ElementsCount As Long ' Количество коллизий+1 ElementsCount As Long ' Количество коллизий+1
Elements() As tElement ' Элементы Elements() As tElement ' Элементы
End TypeEnd Type
Private Type enumObject ' Объект-перечислительPrivate Type enumObject ' Объект-перечислитель
vTablePtr As Long ' Указатель на интерфейс IEnumVariant vTablePtr As Long ' Указатель на интерфейс IEnumVariant
Counter As Long ' Счетчик ссылок Counter As Long ' Счетчик ссылок
Pointer As tPointer ' Индекс на текущий элемент Pointer As tPointer ' Индекс на текущий элемент
DataPtr As Long ' Указатель на List DataPtr As Long ' Указатель на List
First As tPointer ' Индекс на первый элемент First As tPointer ' Индекс на первый элемент
OffsetVariant As Long ' Смещение перечисляемой переменной (key/value) OffsetVariant As Long ' Смещение перечисляемой переменной (key/value)
End TypeEnd Type
Private List() As tItem ' ТаблицаPrivate List() As tItem ' Таблица
Private mEnumMode As EnumMethod ' Текущий режим перечисленияPrivate mEnumMode As EnumMethod ' Текущий режим перечисления
Private mCount As Long ' Кол-во элементовPrivate mCount As Long ' Кол-во элементов
Private mCompareMode As VbCompareMethod ' Режим сравнения ключейPrivate mCompareMode As VbCompareMethod ' Режим сравнения ключей
Private First As tPointer ' Индекс первого элементаPrivate First As tPointer ' Индекс первого элемента
Private Last As tPointer ' Индекс последнего элементаPrivate Last As tPointer ' Индекс последнего элемента
Private locbuf() As Integer ' Буфер текстовой строкиPrivate locbuf() As Integer ' Буфер текстовой строки
Private lpAsm As LongPrivate lpAsm As Long
Private lcid As LongPrivate lcid As Long
Private decMin As VariantPrivate decMin As Variant
Private decMax As VariantPrivate decMax As Variant
' // Получить перечислитель' // Получить перечислитель
Public Property Get NewEnum() As IUnknownPublic Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"Attribute NewEnum.VB_MemberFlags = "40"
Dim enumObject As Long Dim enumObject As Long
enumObject = CreateEnumObject() enumObject = CreateEnumObject()
If enumObject = 0 Then Exit Function If enumObject = 0 Then Exit Function
GetMem4 enumObject, ByVal NewEnum GetMem4 enumObject, ByVal NewEnum
End PropertyEnd Property
' // Получает/Устанавливает режим перечислителя' // Получает/Устанавливает режим перечислителя
Public Property Get EnumMode() As EnumMethodPublic Property Get EnumMode() As EnumMethod
Attribute EnumMode.VB_Description = "Определяет режим сравнения в циклах For Each."Attribute EnumMode.VB_Description = "Определяет режим сравнения в циклах For Each."
EnumMode = mEnumMode EnumMode = mEnumMode
End PropertyEnd Property
Public Property Let EnumMode(ByVal value As EnumMethod)Public Property Let EnumMode(ByVal value As EnumMethod)
mEnumMode = value mEnumMode = value
End PropertyEnd Property
' // Получает/Устанавливает режим сравнения ключей' // Получает/Устанавливает режим сравнения ключей
Public Property Get CompareMode() As CompareMethodPublic Property Get CompareMode() As CompareMethod
Attribute CompareMode.VB_Description = "Установить или получить метод сравнения строк.\n"Attribute CompareMode.VB_Description = "Установить или получить метод сравнения строк.\n"
CompareMode = mCompareMode CompareMode = mCompareMode
End PropertyEnd Property
Public Property Let CompareMode(ByVal value As CompareMethod)Public Property Let CompareMode(ByVal value As CompareMethod)
If mCount Then Err.Raise 5: Exit Property ' Только когда элементов нет If mCount Then Err.Raise 5: Exit Property ' Только когда элементов нет
mCompareMode = value mCompareMode = value
End PropertyEnd Property
' // Добавить элемент' // Добавить элемент
Public Sub Add(Key As Variant, value As Variant)Public Sub Add(Key As Variant, value As Variant)
Attribute Add.VB_Description = "Добавить в таблицу новый ключ и элемент.\n"Attribute Add.VB_Description = "Добавить в таблицу новый ключ и элемент.\n"
Dim pt As tPointer Dim pt As tPointer
If Not GetFromKey(Key, pt) Then If Not GetFromKey(Key, pt) Then
Err.Raise 5 Err.Raise 5
Exit Sub Exit Sub
End If End If
If pt.Index <> -1 Then If pt.Index <> -1 Then
Err.Raise 457 Err.Raise 457
Exit Sub Exit Sub
End If End If
pt.Index = List(pt.hash).ElementsCount pt.Index = List(pt.hash).ElementsCount
Add_ pt, Key, value Add_ pt, Key, value
End SubEnd Sub
' // Возвратить элемент с заданным ключом' // Возвратить элемент с заданным ключом
Public Property Get Item(Key As Variant) As VariantPublic Property Get Item(Key As Variant) As Variant
Attribute Item.VB_Description = "Задать или извлечь элемент по заданному ключу\n"Attribute Item.VB_Description = "Задать или извлечь элемент по заданному ключу\n"
Attribute Item.VB_UserMemId = 0Attribute Item.VB_UserMemId = 0
Dim pt As tPointer Dim pt As tPointer
If Not GetFromKey(Key, pt) Then If Not GetFromKey(Key, pt) Then
Err.Raise 5 Err.Raise 5
Exit Property Exit Property
End If End If
If pt.Index = -1 Then Err.Raise 5: Exit Property If pt.Index = -1 Then Err.Raise 5: Exit Property
VariantCopy Item, List(pt.hash).Elements(pt.Index).value VariantCopy Item, List(pt.hash).Elements(pt.Index).value
End PropertyEnd Property
' // Присвоить значение элементу с заданным ключом' // Присвоить значение элементу с заданным ключом
Public Property Let Item(Key As Variant, value As Variant)Public Property Let Item(Key As Variant, value As Variant)
Dim pt As tPointer Dim pt As tPointer
If Not GetFromKey(Key, pt) Then If Not GetFromKey(Key, pt) Then
Err.Raise 5 Err.Raise 5
Exit Property Exit Property
End If End If
If pt.Index = -1 Then Err.Raise 5: Exit Property If pt.Index = -1 Then Err.Raise 5: Exit Property
List(pt.hash).Elements(pt.Index).value = value List(pt.hash).Elements(pt.Index).value = value
End PropertyEnd Property
' // Присвоить объектное значение элементу с заданным ключом' // Присвоить объектное значение элементу с заданным ключом
Public Property Set Item(Key As Variant, value As Variant)Public Property Set Item(Key As Variant, value As Variant)
Dim pt As tPointer Dim pt As tPointer
If Not GetFromKey(Key, pt) Then If Not GetFromKey(Key, pt) Then
Err.Raise 5 Err.Raise 5
Exit Property Exit Property
End If End If
If pt.Index = -1 Then Err.Raise 5: Exit Property If pt.Index = -1 Then Err.Raise 5: Exit Property
Set List(pt.hash).Elements(pt.Index).value = value Set List(pt.hash).Elements(pt.Index).value = value
End PropertyEnd Property
' // Задать новый ключ' // Задать новый ключ
Public Property Let Key(Key As Variant, NewKey As Variant)Public Property Let Key(Key As Variant, NewKey As Variant)
Attribute Key.VB_Description = "Сменить ключ на другой ключ.\n"Attribute Key.VB_Description = "Сменить ключ на другой ключ.\n"
Key_ Key, NewKey Key_ Key, NewKey
End PropertyEnd Property
' / Задать новый объектный ключ' / Задать новый объектный ключ
Public Property Set Key(Key As Variant, NewKey As Variant)Public Property Set Key(Key As Variant, NewKey As Variant)
Key_ Key, NewKey Key_ Key, NewKey
End PropertyEnd Property
' // Возвращает количество элементов' // Возвращает количество элементов
Public Property Get Count() As LongPublic Property Get Count() As Long
Attribute Count.VB_Description = "Получить количество элементов в таблице.\n"Attribute Count.VB_Description = "Получить количество элементов в таблице.\n"
Count = mCount Count = mCount
End PropertyEnd Property
' // Существует ли элемент с заданным ключом' // Существует ли элемент с заданным ключом
Public Function Exists(Key As Variant) As BooleanPublic Function Exists(Key As Variant) As Boolean
Attribute Exists.VB_Description = "Определить, имеется ли в таблице заданный ключ.\n"Attribute Exists.VB_Description = "Определить, имеется ли в таблице заданный ключ.\n"
Dim pt As tPointer Dim pt As tPointer
If Not GetFromKey(Key, pt) Then If Not GetFromKey(Key, pt) Then
Err.Raise 5 Err.Raise 5
Exit Function Exit Function
End If End If
Exists = pt.Index <> -1 Exists = pt.Index <> -1
End FunctionEnd Function
' // Удалить элемент по ключу' // Удалить элемент по ключу
Public Sub Remove(Key As Variant)Public Sub Remove(Key As Variant)
Attribute Remove.VB_Description = "Удалить ключ и связанный с ним элемент из теблицы.\n"Attribute Remove.VB_Description = "Удалить ключ и связанный с ним элемент из теблицы.\n"
Dim pt As tPointer Dim pt As tPointer
Dim ln As tPointer Dim ln As tPointer
Dim lp As tPointer Dim lp As tPointer
Dim p As tPointer Dim p As tPointer
Dim l As Long Dim l As Long
If Not GetFromKey(Key, pt) Then If Not GetFromKey(Key, pt) Then
Err.Raise 5 Err.Raise 5
Exit Sub Exit Sub
End If End If
If pt.Index = -1 Then If pt.Index = -1 Then
Err.Raise 5 Err.Raise 5
Exit Sub Exit Sub
End If End If
Remove_ pt Remove_ pt
End SubEnd Sub
' // Удалить все элементы' // Удалить все элементы
Public Sub RemoveAll()Public Sub RemoveAll()
Attribute RemoveAll.VB_Description = "Очистить таблицу."Attribute RemoveAll.VB_Description = "Очистить таблицу."
Call Class_Initialize Call Class_Initialize
End SubEnd Sub
' // Получить список элементов' // Получить список элементов
Public Function Items() As VariantPublic Function Items() As Variant
Attribute Items.VB_Description = "Получить массив всех элементов теблицы.\n"Attribute Items.VB_Description = "Получить массив всех элементов теблицы.\n"
Dim pt As tPointer Dim pt As tPointer
Dim i As Long Dim i As Long
Dim ret() As Variant Dim ret() As Variant
If mCount = 0 Then Exit Function If mCount = 0 Then Exit Function
pt = First pt = First
ReDim ret(mCount - 1) ReDim ret(mCount - 1)
Do Do
VariantCopy ret(i), List(pt.hash).Elements(pt.Index).value VariantCopy ret(i), List(pt.hash).Elements(pt.Index).value
pt = List(pt.hash).Elements(pt.Index).Next pt = List(pt.hash).Elements(pt.Index).Next
i = i + 1 i = i + 1
Loop While i < mCount Loop While i < mCount
Items = ret Items = ret
End FunctionEnd Function
' // Получить список ключей' // Получить список ключей
Public Function Keys() As Variant()Public Function Keys() As Variant
Attribute Keys.VB_Description = "Получить массив всех ключей словаря.\n"Attribute Keys.VB_Description = "Получить массив всех ключей словаря.\n"
Dim pt As tPointer, i As Long, ret() As Variant Dim pt As tPointer, i As Long, ret() As Variant
If mCount = 0 Then Exit Function If mCount = 0 Then Keys = Array(): Exit Function
pt = First pt = First
ReDim ret(mCount - 1) ReDim ret(mCount - 1)
Do Do
VariantCopy ret(i), List(pt.hash).Elements(pt.Index).Key VariantCopy ret(i), List(pt.hash).Elements(pt.Index).Key
pt = List(pt.hash).Elements(pt.Index).Next pt = List(pt.hash).Elements(pt.Index).Next
i = i + 1 i = i + 1
Loop While i < mCount Loop While i < mCount
Keys = ret Keys = ret
End FunctionEnd Function
' // Вычислить хеш' // Вычислить хеш
Public Function HashValue(value As Variant) As LongPublic Function HashValue(value As Variant) As Long
Attribute HashValue.VB_Description = "Получит значение хеш-функции от заданного ключа."Attribute HashValue.VB_Description = "Получит значение хеш-функции от заданного ключа."
Dim hash As Long Dim hash As Long
hash = CalcHash(value) hash = CalcHash(value)
If hash < 0 Then If hash < 0 Then
Err.Raise 5 Err.Raise 5
Exit Function Exit Function
End If End If
HashValue = hash HashValue = hash
End FunctionEnd Function
' //' //
Private Sub Add_(pt As tPointer, Key As Variant, value As Variant)Private Sub Add_(pt As tPointer, Key As Variant, value As Variant)
If pt.Index Then If pt.Index Then
If pt.Index > UBound(List(pt.hash).Elements) Then If pt.Index > UBound(List(pt.hash).Elements) Then
ReDim Preserve List(pt.hash).Elements(UBound(List(pt.hash).Elements) + GRANULARITY) ReDim Preserve List(pt.hash).Elements(UBound(List(pt.hash).Elements) + GRANULARITY)
End If End If
Else Else
ReDim Preserve List(pt.hash).Elements(GRANULARITY - 1) ReDim Preserve List(pt.hash).Elements(GRANULARITY - 1)
End If End If
List(pt.hash).ElementsCount = pt.Index + 1 List(pt.hash).ElementsCount = pt.Index + 1
VariantCopyInd List(pt.hash).Elements(pt.Index).value, value VariantCopyInd List(pt.hash).Elements(pt.Index).value, value
VariantCopyInd List(pt.hash).Elements(pt.Index).Key, Key VariantCopyInd List(pt.hash).Elements(pt.Index).Key, Key
If Last.hash >= 0 Then If Last.hash >= 0 Then
List(Last.hash).Elements(Last.Index).Next = pt List(Last.hash).Elements(Last.Index).Next = pt
List(pt.hash).Elements(pt.Index).Prev = Last List(pt.hash).Elements(pt.Index).Prev = Last
Else Else
List(pt.hash).Elements(pt.Index).Prev.hash = -1 List(pt.hash).Elements(pt.Index).Prev.hash = -1
List(pt.hash).Elements(pt.Index).Prev.Index = -1 List(pt.hash).Elements(pt.Index).Prev.Index = -1
First = pt First = pt
End If End If
List(pt.hash).Elements(pt.Index).Next.hash = -1 List(pt.hash).Elements(pt.Index).Next.hash = -1
List(pt.hash).Elements(pt.Index).Next.Index = -1 List(pt.hash).Elements(pt.Index).Next.Index = -1
Last = pt Last = pt
mCount = mCount + 1 mCount = mCount + 1
End SubEnd Sub
Private Sub Remove_(pt As tPointer)Private Sub Remove_(pt As tPointer)
Dim ln As tPointer Dim ln As tPointer
Dim lp As tPointer Dim lp As tPointer
Dim p As tPointer Dim p As tPointer
Dim l As Long Dim l As Long
lp = List(pt.hash).Elements(pt.Index).Prev lp = List(pt.hash).Elements(pt.Index).Prev
ln = List(pt.hash).Elements(pt.Index).Next ln = List(pt.hash).Elements(pt.Index).Next
For l = pt.Index To List(pt.hash).ElementsCount - 2 For l = pt.Index To List(pt.hash).ElementsCount - 2
List(pt.hash).Elements(l) = List(pt.hash).Elements(l + 1) List(pt.hash).Elements(l) = List(pt.hash).Elements(l + 1)
' Правим ссылки на элемент ' Правим ссылки на элемент
p = List(pt.hash).Elements(l).Prev p = List(pt.hash).Elements(l).Prev
If p.Index >= 0 Then List(p.hash).Elements(p.Index).Next.Index = List(p.hash).Elements(p.Index).Next.Index - 1 If p.Index >= 0 Then List(p.hash).Elements(p.Index).Next.Index = List(p.hash).Elements(p.Index).Next.Index - 1
p = List(pt.hash).Elements(l).Next p = List(pt.hash).Elements(l).Next
If p.Index >= 0 Then List(p.hash).Elements(p.Index).Prev.Index = List(p.hash).Elements(p.Index).Prev.Index - 1 If p.Index >= 0 Then List(p.hash).Elements(p.Index).Prev.Index = List(p.hash).Elements(p.Index).Prev.Index - 1
Next Next
l = List(pt.hash).ElementsCount - 1: List(pt.hash).ElementsCount = l l = List(pt.hash).ElementsCount - 1: List(pt.hash).ElementsCount = l
If l Then If l Then
If (l Mod GRANULARITY) = 0 Then ReDim Preserve List(pt.hash).Elements(l - 1) If (l Mod GRANULARITY) = 0 Then ReDim Preserve List(pt.hash).Elements(l - 1)
Else Else
Erase List(pt.hash).Elements() Erase List(pt.hash).Elements()
End If End If
If lp.Index >= 0 Then List(lp.hash).Elements(lp.Index).Next = ln If lp.Index >= 0 Then List(lp.hash).Elements(lp.Index).Next = ln
If ln.Index >= 0 Then List(ln.hash).Elements(ln.Index).Prev = lp If ln.Index >= 0 Then List(ln.hash).Elements(ln.Index).Prev = lp
If lp.Index = -1 Then First = ln If lp.Index = -1 Then First = ln
If ln.Index = -1 Then Last = lp If ln.Index = -1 Then Last = lp
mCount = mCount - 1 mCount = mCount - 1
End SubEnd Sub
Private Sub Key_(Key As Variant, NewKey As Variant)Private Sub Key_(Key As Variant, NewKey As Variant)
Dim pt1 As tPointer Dim pt1 As tPointer
Dim pt2 As tPointer Dim pt2 As tPointer
Dim value As Variant Dim value As Variant
If Not GetFromKey(Key, pt1) Then If Not GetFromKey(Key, pt1) Then
Err.Raise 5 Err.Raise 5
Exit Sub Exit Sub
End If End If
If pt1.Index = -1 Then Err.Raise 5: Exit Sub If pt1.Index = -1 Then Err.Raise 5: Exit Sub
If Not GetFromKey(NewKey, pt2) Then If Not GetFromKey(NewKey, pt2) Then
Err.Raise 5 Err.Raise 5
Exit Sub Exit Sub
End If End If
If pt2.Index <> -1 Then Err.Raise 457: Exit Sub If pt2.Index <> -1 Then Err.Raise 457: Exit Sub
VariantCopy value, List(pt1.hash).Elements(pt1.Index).value VariantCopy value, List(pt1.hash).Elements(pt1.Index).value
Remove_ pt1 Remove_ pt1
pt2.Index = List(pt2.hash).ElementsCount pt2.Index = List(pt2.hash).ElementsCount
Add_ pt2, NewKey, value Add_ pt2, NewKey, value
End SubEnd Sub
Private Function GetFromKey(Key As Variant, Pointer As tPointer) As BooleanPrivate Function GetFromKey(Key As Variant, Pointer As tPointer) As Boolean
Dim i As Long Dim i As Long
Dim hash As Long Dim hash As Long
Dim typ As Integer Dim typ As Integer
Dim keyi As Variant Dim keyi As Variant
Dim lPtr As Long Dim lPtr As Long
hash = CalcHash(Key) hash = CalcHash(Key)
If hash >= 0 Then If hash >= 0 Then
Pointer.hash = hash Pointer.hash = hash
GetFromKey = True GetFromKey = True
VariantCopyInd keyi, Key VariantCopyInd keyi, Key
lPtr = VarPtr(keyi) lPtr = VarPtr(keyi)
GetMem2 ByVal lPtr, typ GetMem2 ByVal lPtr, typ
Select Case typ Select Case typ
Case vbString Case vbString
For i = 0 To List(hash).ElementsCount - 1 For i = 0 To List(hash).ElementsCount - 1
If VarCmp(List(hash).Elements(i).Key, keyi, lcid, mCompareMode) = 1 Then If VarCmp(List(hash).Elements(i).Key, keyi, lcid, mCompareMode) = 1 Then
Pointer.Index = i Pointer.Index = i
Exit Function Exit Function
End If End If
Next Next
Case vbObject, vbDataObject Case vbObject, vbDataObject
GetMem4 ByVal lPtr + 8, lPtr GetMem4 ByVal lPtr + 8, lPtr
For i = 0 To List(hash).ElementsCount - 1 For i = 0 To List(hash).ElementsCount - 1
GetMem2 List(hash).Elements(i).Key, typ GetMem2 List(hash).Elements(i).Key, typ
If typ = vbObject Or typ = vbDataObject Then If typ = vbObject Or typ = vbDataObject Then
If List(hash).Elements(i).Key Is keyi Then If List(hash).Elements(i).Key Is keyi Then
Pointer.Index = i Pointer.Index = i
Exit Function Exit Function
End If End If
End If End If
Next Next
Case vbNull Case vbNull
For i = 0 To List(hash).ElementsCount - 1 For i = 0 To List(hash).ElementsCount - 1
If IsNull(List(hash).Elements(i).Key) Then If IsNull(List(hash).Elements(i).Key) Then
Pointer.Index = i Pointer.Index = i
Exit Function Exit Function
End If End If
Next Next
Case vbEmpty Case vbEmpty
For i = 0 To List(hash).ElementsCount - 1 For i = 0 To List(hash).ElementsCount - 1
If IsEmpty(List(hash).Elements(i).Key) Then If IsEmpty(List(hash).Elements(i).Key) Then
Pointer.Index = i Pointer.Index = i
Exit Function Exit Function
End If End If
Next Next
Case Else Case Else
For i = 0 To List(hash).ElementsCount - 1 For i = 0 To List(hash).ElementsCount - 1
If List(hash).Elements(i).Key = keyi Then If List(hash).Elements(i).Key = keyi Then
Pointer.Index = i Pointer.Index = i
Exit Function Exit Function
End If End If
Next Next
End Select End Select
End If End If
Pointer.Index = -1 Pointer.Index = -1
End FunctionEnd Function
Private Function CalcHash(value As Variant) As LongPrivate Function CalcHash(value As Variant) As Long
Dim i As Long Dim i As Long
Dim typ As Integer Dim typ As Integer
Dim ptr As Long Dim ptr As Long
Dim length As Long Dim length As Long
Dim dbl As Double Dim dbl As Double
Dim cur As Currency Dim cur As Currency
Dim sgl As Single Dim sgl As Single
ptr = VarPtr(value) ptr = VarPtr(value)
GetMem2 ByVal ptr, typ GetMem2 ByVal ptr, typ
Do While typ = &H400C Do While typ = &H400C
GetMem2 ByVal ptr + 8, ptr GetMem2 ByVal ptr + 8, ptr
GetMem2 ByVal ptr, typ GetMem2 ByVal ptr, typ
Loop Loop
ptr = ptr + 8 ptr = ptr + 8
If typ And &H4000 Then If typ And &H4000 Then
GetMem4 ByVal ptr, ptr GetMem4 ByVal ptr, ptr
typ = typ And &HBFFF& typ = typ And &HBFFF&
End If End If
Select Case typ Select Case typ
Case vbString Case vbString
GetMem4 ByVal ptr, ptr GetMem4 ByVal ptr, ptr
If ptr = 0 Then CalcHash = 0: Exit Function
GetMem4 ByVal ptr - 4, length GetMem4 ByVal ptr - 4, length
length = length \ 2 length = length \ 2
If length >= UBound(locbuf) Then If length >= UBound(locbuf) Then
ReDim locbuf(length + 1) ReDim locbuf(length + 1)
End If End If
If mCompareMode = vbTextCompare Then If mCompareMode = vbTextCompare Then
LCMapString lcid, LCMAP_LOWERCASE, ByVal ptr, length, locbuf(0), length LCMapString lcid, LCMAP_LOWERCASE, ByVal ptr, length, locbuf(0), length
Else Else
memcpy locbuf(0), ByVal ptr, length * 2 memcpy locbuf(0), ByVal ptr, length * 2&
End If End If
For i = 0 To length - 1 For i = 0 To length - 1
CalcHash = (CalcHash * 37 + locbuf(i) And &HFFFF&) CalcHash = (CalcHash * 37& + locbuf(i) And &HFFFF&)
Next Next
Case vbByte Case vbByte
GetMem1 ByVal ptr, CalcHash GetMem1 ByVal ptr, CalcHash
VarR4FromUI1 ByVal CalcHash, CalcHash VarR4FromUI1 ByVal CalcHash, CalcHash
Case vbInteger, vbBoolean Case vbInteger, vbBoolean
GetMem2 ByVal ptr, CalcHash GetMem2 ByVal ptr, CalcHash
VarR4FromI2 ByVal CalcHash, CalcHash VarR4FromI2 ByVal CalcHash, CalcHash
Case vbLong, vbError Case vbLong, vbError
GetMem4 ByVal ptr, i GetMem4 ByVal ptr, i
If i > 9999999 Or i < -9999999 Then If i > 9999999 Or i < -9999999 Then
CalcHash = 0 CalcHash = 0
Else Else
VarR4FromI4 ByVal CalcHash, CalcHash VarR4FromI4 ByVal CalcHash, CalcHash
End If End If
Case vbSingle Case vbSingle
GetMem8 ByVal ptr, sgl GetMem8 ByVal ptr, sgl
If sgl > 9999999 Or sgl < -9999999 Then If sgl > 9999999 Or sgl < -9999999 Then
CalcHash = 0 CalcHash = 0
Else Else
GetMem4 sgl, CalcHash GetMem4 sgl, CalcHash
End If End If
Case vbObject, vbDataObject Case vbObject, vbDataObject
GetMem4 ByVal ptr, CalcHash GetMem4 ByVal ptr, CalcHash
Case vbDouble, vbDate Case vbDouble, vbDate
GetMem8 ByVal ptr, dbl GetMem8 ByVal ptr, dbl
If dbl > 9999999 Or dbl < -9999999 Then If dbl > 9999999 Or dbl < -9999999 Then
CalcHash = 0 CalcHash = 0
Else Else
GetMem4 CSng(dbl), CalcHash GetMem4 CSng(dbl), CalcHash
End If End If
Case vbCurrency Case vbCurrency
GetMem8 ByVal ptr, cur GetMem8 ByVal ptr, cur
If dbl > 9999999@ Or dbl < -9999999@ Then If dbl > 9999999@ Or dbl < -9999999@ Then
CalcHash = 0 CalcHash = 0
Else Else
GetMem4 CSng(cur), CalcHash GetMem4 CSng(cur), CalcHash
End If End If
Case vbDecimal Case vbDecimal
If value > decMax Or value < decMin Then If value > decMax Or value < decMin Then
CalcHash = 0 CalcHash = 0
Else Else
GetMem4 CSng(value), CalcHash GetMem4 CSng(value), CalcHash
End If End If
Case vbNull, vbEmpty Case vbNull, vbEmpty
CalcHash = 0 CalcHash = 0
Case Else Case Else
CalcHash = -1 CalcHash = -1
Exit Function Exit Function
End Select End Select
CalcHash = (CalcHash And &H7FFFFFFF) Mod HASH_SIZE CalcHash = (CalcHash And &H7FFFFFFF) Mod HASH_SIZE
End FunctionEnd Function
Private Function CreateEnumObject() As LongPrivate Function CreateEnumObject() As Long
If lpAsm = 0 Then If lpAsm = 0 Then
lpAsm = GetEnumInterface() lpAsm = GetEnumInterface()
If lpAsm = 0 Then Exit Function If lpAsm = 0 Then Exit Function
End If End If
Dim newObject As enumObject Dim newObject As enumObject
Dim lpObject As Long Dim lpObject As Long
newObject.Counter = 1 newObject.Counter = 1
newObject.DataPtr = VarPtr(List(0)) newObject.DataPtr = VarPtr(List(0))
newObject.vTablePtr = lpAsm + &HEC newObject.vTablePtr = lpAsm + &HEC
newObject.Pointer = First newObject.Pointer = First
newObject.First = First newObject.First = First
newObject.OffsetVariant = IIf(mEnumMode = ENUM_BY_KEY, 0, &H10) newObject.OffsetVariant = IIf(mEnumMode = ENUM_BY_KEY, 0, &H10)
lpObject = HeapAlloc(GetProcessHeap(), HEAP_NO_SERIALIZE, Len(newObject)) lpObject = HeapAlloc(GetProcessHeap(), HEAP_NO_SERIALIZE, Len(newObject))
memcpy ByVal lpObject, newObject, Len(newObject) memcpy ByVal lpObject, newObject, Len(newObject)
CreateEnumObject = lpObject CreateEnumObject = lpObject
End FunctionEnd Function
Private Function GetEnumInterface() As LongPrivate Function GetEnumInterface() As Long
Dim sHex As String Dim sHex As String
sHex = Space(&H8) sHex = Space(&H8)
If GetEnvironmentVariable(StrPtr("TrickHashEnumerationInterface"), StrPtr(sHex), Len(sHex) + 1) = 0 Then If GetEnvironmentVariable(StrPtr("TrickHashEnumerationInterface"), StrPtr(sHex), Len(sHex) + 1) = 0 Then
GetEnumInterface = CreateAsm() GetEnumInterface = CreateAsm()
Else Else
GetEnumInterface = CLng("&H" & sHex) GetEnumInterface = CLng("&H" & sHex)
End If End If
End FunctionEnd Function
Private Function CreateAsm() As LongPrivate Function CreateAsm() As Long
Dim lpAddr As Long Dim lpAddr As Long
Dim dat(58) As Long Dim dat(58) As Long
Dim hLib As Long Dim hLib As Long
Dim lpProc As Long Dim lpProc As Long
dat(0) = &H424448B: dat(1) = &H8B0440FF: dat(2) = &H890C244C: dat(3) = &HC2C03101: dat(4) = &H448B000C: dat(0) = &H424448B: dat(1) = &H8B0440FF: dat(2) = &H890C244C: dat(3) = &HC2C03101: dat(4) = &H448B000C:
dat(5) = &H40FF0424: dat(6) = &H4408B04: dat(7) = &H8B0004C2: dat(8) = &HFF042444: dat(9) = &H6740448: dat(5) = &H40FF0424: dat(6) = &H4408B04: dat(7) = &H8B0004C2: dat(8) = &HFF042444: dat(9) = &H6740448:
dat(10) = &HC204408B: dat(11) = &H6A500004: dat(12) = &H5642E801: dat(13) = &HE8501234: dat(14) = &H1234563C: dat(10) = &HC204408B: dat(11) = &H6A500004: dat(12) = &H5642E801: dat(13) = &HE8501234: dat(14) = &H1234563C:
dat(15) = &H4C2C031: dat(16) = &H56575300: dat(17) = &H1024748B: dat(18) = &H14245C8B: dat(19) = &H18247C8B: dat(15) = &H4C2C031: dat(16) = &H56575300: dat(17) = &H1024748B: dat(18) = &H14245C8B: dat(19) = &H18247C8B:
dat(20) = &H846BF0F: dat(21) = &H482F7440: dat(22) = &H8B0C4E8B: dat(23) = &HF04C14C: dat(24) = &H660A46B7: dat(20) = &H846BF0F: dat(21) = &H482F7440: dat(22) = &H8B0C4E8B: dat(23) = &HF04C14C: dat(24) = &H660A46B7:
dat(25) = &HF28C06B: dat(26) = &H498BC0B7: dat(27) = &H10C8D0C: dat(28) = &H320418B: dat(29) = &H4689144E: dat(25) = &HF28C06B: dat(26) = &H498BC0B7: dat(27) = &H10C8D0C: dat(28) = &H320418B: dat(29) = &H4689144E:
dat(30) = &HE8575108: dat(31) = &H123455F8: dat(32) = &H4B10C783: dat(33) = &HDB85CA75: dat(34) = &HFC2950F: dat(30) = &HE8575108: dat(31) = &H123455F8: dat(32) = &H4B10C783: dat(33) = &HDB85CA75: dat(34) = &HFC2950F:
dat(35) = &H7C8BF2B6: dat(36) = &HFF851C24: dat(37) = &H448B0874: dat(38) = &HD8291424: dat(39) = &HF0890789: dat(35) = &H7C8BF2B6: dat(36) = &HFF851C24: dat(37) = &H448B0874: dat(38) = &HD8291424: dat(39) = &HF0890789:
dat(40) = &HC25B5F5E: dat(41) = &H548B0010: dat(42) = &H428B0424: dat(43) = &HC528B08: dat(44) = &H1F744066: dat(40) = &HC25B5F5E: dat(41) = &H548B0010: dat(42) = &H428B0424: dat(43) = &HC528B08: dat(44) = &H1F744066:
dat(45) = &HB70F4866: dat(46) = &HCA4C8BC8: dat(47) = &H10E8C104: dat(48) = &H28C06B66: dat(49) = &H8B0C498B: dat(45) = &HB70F4866: dat(46) = &HCA4C8BC8: dat(47) = &H10E8C104: dat(48) = &H28C06B66: dat(49) = &H8B0C498B:
dat(50) = &HFF200144: dat(51) = &H7508244C: dat(52) = &H85D231DF: dat(53) = &HC2950FD2: dat(54) = &H8C2D089: dat(50) = &HFF200144: dat(51) = &H7508244C: dat(52) = &H85D231DF: dat(53) = &HC2950FD2: dat(54) = &H8C2D089:
dat(55) = &H24448B00: dat(56) = &H10508B04: dat(57) = &H31085089: dat(58) = &H4C2C0 dat(55) = &H24448B00: dat(56) = &H10508B04: dat(57) = &H31085089: dat(58) = &H4C2C0
lpAddr = VirtualAlloc(ByVal 0&, &H104, MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE) lpAddr = VirtualAlloc(ByVal 0&, &H104, MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE)
If lpAddr = 0 Then Exit Function If lpAddr = 0 Then Exit Function
memcpy ByVal lpAddr, dat(0), &HEC memcpy ByVal lpAddr, dat(0), &HEC
hLib = GetModuleHandle(StrPtr("kernel32")) hLib = GetModuleHandle(StrPtr("kernel32"))
If hLib = 0 Then GoTo Clear If hLib = 0 Then GoTo Clear
lpProc = GetProcAddress(hLib, "GetProcessHeap") lpProc = GetProcAddress(hLib, "GetProcessHeap")
If lpProc = 0 Then GoTo Clear If lpProc = 0 Then GoTo Clear
GetMem4 lpProc - (lpAddr + &H32 + 4), ByVal lpAddr + &H32 GetMem4 lpProc - (lpAddr + &H32 + 4), ByVal lpAddr + &H32
lpProc = GetProcAddress(hLib, "HeapFree") lpProc = GetProcAddress(hLib, "HeapFree")
If lpProc = 0 Then GoTo Clear If lpProc = 0 Then GoTo Clear
GetMem4 lpProc - (lpAddr + &H38 + 4), ByVal lpAddr + &H38 GetMem4 lpProc - (lpAddr + &H38 + 4), ByVal lpAddr + &H38
hLib = GetModuleHandle(StrPtr("oleaut32")) hLib = GetModuleHandle(StrPtr("oleaut32"))
If hLib = 0 Then GoTo Clear If hLib = 0 Then GoTo Clear
lpProc = GetProcAddress(hLib, "VariantCopy") lpProc = GetProcAddress(hLib, "VariantCopy")
If lpProc = 0 Then GoTo Clear If lpProc = 0 Then GoTo Clear
GetMem4 lpProc - (lpAddr + &H7C + 4), ByVal lpAddr + &H7C GetMem4 lpProc - (lpAddr + &H7C + 4), ByVal lpAddr + &H7C
GetMem4 lpAddr, ByVal lpAddr + &HEC ' IUnknown::QueryInterface GetMem4 lpAddr, ByVal lpAddr + &HEC ' IUnknown::QueryInterface
GetMem4 lpAddr + &H12, ByVal lpAddr + &HF0 ' IUnknown::AddRef GetMem4 lpAddr + &H12, ByVal lpAddr + &HF0 ' IUnknown::AddRef
GetMem4 lpAddr + &H1F, ByVal lpAddr + &HF4 ' IUnknown::Release GetMem4 lpAddr + &H1F, ByVal lpAddr + &HF4 ' IUnknown::Release
GetMem4 lpAddr + &H41, ByVal lpAddr + &HF8 ' IEnumVariant::Next GetMem4 lpAddr + &H41, ByVal lpAddr + &HF8 ' IEnumVariant::Next
GetMem4 lpAddr + &HA6, ByVal lpAddr + &HFC ' IEnumVariant::Skip GetMem4 lpAddr + &HA6, ByVal lpAddr + &HFC ' IEnumVariant::Skip
GetMem4 lpAddr + &HDD, ByVal lpAddr + &H100 ' IEnumVariant::Reset GetMem4 lpAddr + &HDD, ByVal lpAddr + &H100 ' IEnumVariant::Reset
If SetEnvironmentVariable(StrPtr("TrickHashEnumerationInterface"), StrPtr(Hex(lpAddr))) = 0 Then GoTo Clear If SetEnvironmentVariable(StrPtr("TrickHashEnumerationInterface"), StrPtr(Hex(lpAddr))) = 0 Then GoTo Clear
CreateAsm = lpAddr CreateAsm = lpAddr
Exit Function Exit Function
Clear:Clear:
VirtualFree ByVal lpAddr, &H104, MEM_RELEASE VirtualFree ByVal lpAddr, &H104, MEM_RELEASE
End FunctionEnd Function
Private Sub Class_Initialize()Private Sub Class_Initialize()
ReDim List(HASH_SIZE - 1) ReDim List(HASH_SIZE - 1)
ReDim locbuf(255) ReDim locbuf(255)
First.hash = -1 First.hash = -1
First.Index = -1 First.Index = -1
Last.hash = -1 Last.hash = -1
Last.Index = -1 Last.Index = -1
mCount = 0 mCount = 0
lcid = GetUserDefaultLCID() lcid = GetUserDefaultLCID()
decMin = CDec(-9999999) decMin = CDec(-9999999)
decMax = CDec(9999999) decMax = CDec(9999999)
End SubEnd Sub
Private Sub Class_Terminate()Private Sub Class_Terminate()
Erase List() Erase List()
End SubEnd Sub
Editor
Original Text
Changed Text
Recommended videos