Quantcast
Channel: VBForums - CodeBank - Visual Basic 6 and earlier
Viewing all articles
Browse latest Browse all 1508

Patch Collection to support case sensitivity

$
0
0
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.

VB Code:
  1. Private Declare Sub GetMem1 Lib "msvbvm60" (ByVal Address As Long, n As Byte)
  2. Private Declare Sub PutMem1 Lib "msvbvm60" (ByVal Address As Long, ByVal n As Byte)
  3. Private Declare Sub GetMem2 Lib "msvbvm60" (ByVal Address As Long, n As Integer)
  4. Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Address As Long, n As Long)
  5.  
  6. Private Const PAGE_EXECUTE_READWRITE = &H40&
  7. Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
  8. Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
  9.  
  10. Sub Main()
  11.   Dim c As New Collection
  12.   PatchCollection
  13.   c.Add 1, "Test"
  14.   c.Add 2, "test"
  15.   MsgBox c("Test")
  16.   MsgBox c("test")
  17. End Sub
  18.  
  19. Private Property Get MemByte(ByVal Address As Long) As Byte
  20.   GetMem1 Address, MemByte
  21. End Property
  22. Private Property Let MemByte(ByVal Address As Long, ByVal n As Byte)
  23.   PutMem1 Address, n
  24. End Property
  25. Private Function MemInt(ByVal Address As Long) As Integer
  26.   GetMem2 Address, MemInt
  27. End Function
  28. Private Function Mem(ByVal Address As Long) As Long
  29.   GetMem4 Address, Mem
  30. End Function
  31. Public Sub PatchCollection(Optional ByVal IsCaseSensitive As Boolean = True)
  32.   Dim Addr As Long
  33.   If InIDE = False Then
  34.     addr = GetModuleHandle("MSVBVM60.DLL")
  35.   Else
  36.     Addr = GetModuleHandle("VBA6.DLL")
  37.   End If
  38.   Addr = SearchPatchBytes(Addr)
  39.   PatchByte(Addr) = IsCaseSensitive + 1
  40.   Addr = SearchPatchBytes(Addr)
  41.   PatchByte(Addr) = IsCaseSensitive + 1
  42. End Sub
  43. Private Function InIDE() As Boolean
  44.   On Error Resume Next
  45.   Debug.Print 0 / 0
  46.   InIDE = Err.Number <> 0
  47. End Function
  48. 'Patch calls to the oleaut32_VarBstrCmp function
  49. Private Function SearchPatchBytes(ByVal Addr As Long)
  50.   Addr = Addr + 7
  51.   Do
  52.     Do
  53.       While MemByte(Addr) <> &H68 'push
  54.         Addr = Addr + 1
  55.       Wend
  56.       Addr = Addr + 1
  57.     Loop While (Mem(Addr) And &HFFFFFFFE) <> &H30000 'NORM_IGNORECASE = 0/1
  58.     Addr = Addr + 4
  59.   Loop While MemInt(Addr) <> &H16A 'push 1 (Locale identifier)
  60.   SearchPatchBytes = Addr - 4
  61. End Function
  62. Private Property Let PatchByte(ByVal Addr As Long, ByVal b As Byte)
  63.   Dim OldProtect As Long
  64.   VirtualProtect Addr, 1, PAGE_EXECUTE_READWRITE, OldProtect
  65.   MemByte(Addr) = b
  66. End Property

or with TLB (see my others posts to download it):
VB Code:
  1. Sub Main()
  2.   Dim c As New Collection
  3.   PatchCollection
  4.   c.Add 1, "Test"
  5.   c.Add 2, "test"
  6.   MsgBox c("Test")
  7.   MsgBox c("test")
  8. End Sub
  9.  
  10. Public Sub PatchCollection(Optional ByVal IsCaseSensitive As Boolean = True)
  11.   Dim addr As Long
  12.   If InIDE = False Then
  13.     addr = GetModuleHandle("MSVBVM60.DLL")
  14.   Else
  15.     addr = GetModuleHandle("VBA6.DLL")
  16.   End If
  17.   addr = SearchPatchBytes(addr)
  18.   PatchByte(addr) = IsCaseSensitive + 1
  19.   addr = SearchPatchBytes(addr)
  20.   PatchByte(addr) = IsCaseSensitive + 1
  21. End Sub
  22. Private Function InIDE() As Boolean
  23.   On Error Resume Next
  24.   Debug.Print 0 / 0
  25.   InIDE = Err.Number <> 0
  26. End Function
  27. 'Patch calls to the oleaut32_VarBstrCmp function
  28. Private Function SearchPatchBytes(ByVal addr As Long)
  29.   addr = addr + 7
  30.   Do
  31.     Do
  32.       While MemByte(addr) <> &H68 'push
  33.         addr = addr + 1
  34.       Wend
  35.       addr = addr + 1
  36.     Loop While (Mem(addr) And &HFFFFFFFE) <> &H30000 'NORM_IGNORECASE = 0/1
  37.     addr = addr + 4
  38.   Loop While MemInt(addr) <> &H16A 'push 1 (Locale identifier)
  39.   SearchPatchBytes = addr - 4
  40. End Function
  41. Private Property Let PatchByte(ByVal addr As Long, ByVal b As Byte)
  42.   Dim OldProtect As Long
  43.   VirtualProtect addr, 1, PAGE_EXECUTE_READWRITE, OldProtect
  44.   MemByte(addr) = b
  45. End Property

Viewing all articles
Browse latest Browse all 1508

Trending Articles



<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>