Patch Collection to support case sensitivity

[Filyus]

The Collection is 3-4 and more times faster then the Dictionary when adding items, and 2 times slower when retrieving.

Tested compiled and runned from the IDE in the Windows XP 64 and in the Windows 7 64 with different versions of msvbvm60.dll and vba6.dll.
So it is must be stable.

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

or with TLB (see my others posts to download it):

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

[Filyus]

Added an optional IsCaseSensitive flag to ability for remove the case sensitivity patch.