'**************************************
' Name: Patch Collection to support case sensitivity
' Description:Collection is 3-4 and more times faster then Dictionary when adding items, and 2 times slower when retrieving.
' By: Ahmed'yanov Filyus
'
'This code is copyrighted and has' limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=74435&lngWId=1'for details.'**************************************
Private Declare Sub GetMem1 Lib "msvbvm60" (ByVal Address As Long, n As Byte)
Private Declare Sub PutMem1 Lib "msvbvm60" (ByVal Address As Long, ByVal n As Byte)
Private Declare Sub GetMem2 Lib "msvbvm60" (ByVal Address As Long, n As Integer)
Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Address As Long, n As Long)
Private Const PAGE_EXECUTE_READWRITE = &H40&
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Sub Main()
Dim c As New Collection
PatchCollection
c.Add 1, "Test"
c.Add 2, "test"
MsgBox c("Test")
MsgBox c("test")
End Sub
Private Property Get MemByte(ByVal Address As Long) As Byte
GetMem1 Address, MemByte
End Property
Private Property Let MemByte(ByVal Address As Long, ByVal n As Byte)
PutMem1 Address, n
End Property
Private Function MemInt(ByVal Address As Long) As Integer
GetMem2 Address, MemInt
End Function
Private Function Mem(ByVal Address As Long) As Long
GetMem4 Address, Mem
End Function
Public Sub PatchCollection(Optional ByVal IsCaseSensitive As Boolean = True)
Dim Addr As Long
If InIDE = False Then
addr = GetModuleHandle("MSVBVM60.DLL")
Else
Addr = GetModuleHandle("VBA6.DLL")
End If
Addr = SearchPatchBytes(Addr)
PatchByte(Addr) = IsCaseSensitive + 1
Addr = SearchPatchBytes(Addr)
PatchByte(Addr) = IsCaseSensitive + 1
End Sub
Private Function InIDE() As Boolean
On Error Resume Next
Debug.Print 0 / 0
InIDE = Err.Number <> 0
End Function
'Patch calls to the oleaut32_VarBstrCmp function
Private Function SearchPatchBytes(ByVal Addr As Long)
Addr = Addr + 7
Do
Do
While MemByte(Addr) <> &H68 'push
Addr = Addr + 1
Wend
Addr = Addr + 1
Loop While (Mem(Addr) And &HFFFFFFFE) <> &H30000 'NORM_IGNORECASE = 0/1
Addr = Addr + 4
Loop While MemInt(Addr) <> &H16A 'push 1 (Locale identifier)
SearchPatchBytes = Addr - 4
End Function
Private Property Let PatchByte(ByVal Addr As Long, ByVal b As Byte)
Dim OldProtect As Long
VirtualProtect Addr, 1, PAGE_EXECUTE_READWRITE, OldProtect
MemByte(Addr) = b
End Property[/HIGHLIGHT]
or with TLB (see my others posts to download it):
[HIGHLIGHT="VB"]Sub Main()
Dim c As New Collection
PatchCollection
c.Add 1, "Test"
c.Add 2, "test"
MsgBox c("Test")
MsgBox c("test")
End Sub
Public Sub PatchCollection(Optional ByVal IsCaseSensitive As Boolean = True)
Dim addr As Long
If InIDE = False Then
addr = GetModuleHandle("MSVBVM60.DLL")
Else
addr = GetModuleHandle("VBA6.DLL")
End If
addr = SearchPatchBytes(addr)
PatchByte(addr) = IsCaseSensitive + 1
addr = SearchPatchBytes(addr)
PatchByte(addr) = IsCaseSensitive + 1
End Sub
Private Function InIDE() As Boolean
On Error Resume Next
Debug.Print 0 / 0
InIDE = Err.Number <> 0
End Function
'Patch calls to the oleaut32_VarBstrCmp function
Private Function SearchPatchBytes(ByVal addr As Long)
addr = addr + 7
Do
Do
While MemByte(addr) <> &H68 'push
addr = addr + 1
Wend
addr = addr + 1
Loop While (Mem(addr) And &HFFFFFFFE) <> &H30000 'NORM_IGNORECASE = 0/1
addr = addr + 4
Loop While MemInt(addr) <> &H16A 'push 1 (Locale identifier)
SearchPatchBytes = addr - 4
End Function
Private Property Let PatchByte(ByVal addr As Long, ByVal b As Byte)
Dim OldProtect As Long
VirtualProtect addr, 1, PAGE_EXECUTE_READWRITE, OldProtect
MemByte(addr) = b
End Property
|
