High performance Replace function as an alternative to the plain VBA.Replace function

[SanbiVN]

Hi @sancarn
In your project use many times call Replace function. The original Replace function, really slow.
I found the code below used by wqweto in some project shared by him, I trusted and tested, and the result is unbelievable that the performance is many times better than the original VBA.Replace function.
The real creator is Jost Schwider based on the comment in the code by Jost Schwider, jost@schwider.de, 20001218
You can test to take advantage of the Replace function in your project

Option Explicit
#If VBA7 = 0 Then
  Private Enum LongPtr
    [_]
  End Enum
#End If
#If VBA7 Then
Private Declare PtrSafe Function SysAllocStringByteLen Lib "OleAut32" (ByVal olestr As LongPtr, ByVal BLen As Long) As LongPtr
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal nBytes As LongPtr)
Private Declare PtrSafe Sub RtlZeroMemory Lib "kernel32" (dst As Any, ByVal nBytes As LongPtr)
#Else
Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal olestr As Long, ByVal BLen As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal nBytes&)
Private Declare Sub RtlZeroMemory Lib "kernel32" (dst As Any, ByVal nBytes&)
#End If

Private Const FADF_AUTO As Long = &H1        '// Array is allocated on the stack.
Private Const FADF_FIXEDSIZE As Long = &H10  '// Array may not be resized or reallocated.
Private Sub Replace08_test()
  Dim s$, t!
  s = String(10000000, "a")
  t = Timer
  Debug.Print Replace08(s, "aaa", "")
  Debug.Print "Replace08: "; Round(Timer - t, 5)
  t = Timer
  Debug.Print Replace$(s, "aaa", "")
  Debug.Print "Replace: "; Round(Timer - t, 5)
End Sub

Public Function Replace08(ByVal Text As String, _
            ByVal sOld As String, ByVal sNew As String, _
            Optional ByVal start As Long = 1, _
            Optional ByVal count As Long = 2147483647, _
            Optional ByVal compare As VbCompareMethod = vbBinaryCompare _
            ) As String
  ' by Jost Schwider, jost@schwider.de, 20001218
  If LenB(sOld) Then
    If compare = vbBinaryCompare Then
      Replace08Bin Replace08, Text, Text, sOld, sNew, start, count
    Else
      Replace08Bin Replace08, Text, LCase$(Text), LCase$(sOld), sNew, start, count
    End If
  Else 'Suchstring ist leer:
    Replace08 = Text
  End If
End Function
Private Static Sub Replace08Bin(ByRef result As String, _
            ByRef Text As String, ByRef Search As String, _
            ByRef sOld As String, ByRef sNew As String, _
            ByVal start As Long, ByVal count As Long)
  ' by Jost Schwider, jost@schwider.de, 20001218
  Dim TextLen As Long, OldLen As Long, NewLen As Long, ReadPos As Long
  Dim WritePos As Long, CopyLen As Long, buffer As String, BufferLen As Long, BufferPosNew As Long, BufferPosNext As Long
  'Ersten Treffer bestimmen:
  If start < 2 Then
    start = InStrB(Search, sOld)
  Else
    start = InStrB(start + start - 1, Search, sOld)
  End If
  If start Then
    OldLen = LenB(sOld)
    NewLen = LenB(sNew)
    Select Case NewLen
    Case OldLen 'einfaches Überschreiben:
      result = Text
      For count = 1 To count
        MidB$(result, start) = sNew
        start = InStrB(start + OldLen, Search, sOld)
        If start = 0 Then Exit Sub
      Next count
    Case 0 'nur Entfernen:
      'Buffer initialisieren:
      TextLen = LenB(Text)
      If TextLen > BufferLen Then
        buffer = Text
        BufferLen = TextLen
      End If
      'Ausschneiden:
      ReadPos = 1
      WritePos = 1
      For count = 1 To count
        CopyLen = start - ReadPos
        If CopyLen Then
          MidB$(buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
          WritePos = WritePos + CopyLen
        End If
        ReadPos = start + OldLen
        start = InStrB(ReadPos, Search, sOld)
        If start = 0 Then Exit For
      Next count
      'Ergebnis zusammenbauen:
      If ReadPos > TextLen Then
        result = LeftB$(buffer, WritePos - 1)
      Else
        MidB$(buffer, WritePos) = MidB$(Text, ReadPos)
        result = LeftB$(buffer, WritePos + TextLen - ReadPos)
      End If
      Exit Sub
    Case Is < OldLen 'Ergebnis wird kürzer:
      'Buffer initialisieren:
      TextLen = LenB(Text)
      If TextLen > BufferLen Then
        buffer = Text
        BufferLen = TextLen
      End If
      'Ersetzen:
      ReadPos = 1
      WritePos = 1
      For count = 1 To count
        CopyLen = start - ReadPos
        If CopyLen Then
          BufferPosNew = WritePos + CopyLen
          MidB$(buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
          MidB$(buffer, BufferPosNew) = sNew
          WritePos = BufferPosNew + NewLen
        Else
          MidB$(buffer, WritePos) = sNew
          WritePos = WritePos + NewLen
        End If
        ReadPos = start + OldLen
        start = InStrB(ReadPos, Search, sOld)
        If start = 0 Then Exit For
      Next count
      'Ergebnis zusammenbauen:
      If ReadPos > TextLen Then
        result = LeftB$(buffer, WritePos - 1)
      Else
        MidB$(buffer, WritePos) = MidB$(Text, ReadPos)
        result = LeftB$(buffer, WritePos + LenB(Text) - ReadPos)
      End If
      Exit Sub
    Case Else 'Ergebnis wird länger:
      'Buffer initialisieren:
      TextLen = LenB(Text)
      BufferPosNew = TextLen + NewLen
      If BufferPosNew > BufferLen Then
        buffer = Space$(BufferPosNew)
        BufferLen = LenB(buffer)
      End If
      'Ersetzung:
      ReadPos = 1
      WritePos = 1
      For count = 1 To count
        CopyLen = start - ReadPos
        If CopyLen Then
          'Positionen berechnen:
          BufferPosNew = WritePos + CopyLen
          BufferPosNext = BufferPosNew + NewLen
          'Ggf. Buffer vergrößern:
          If BufferPosNext > BufferLen Then
            buffer = buffer & Space$(BufferPosNext)
            BufferLen = LenB(buffer)
          End If
          'String "patchen":
          MidB$(buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
          MidB$(buffer, BufferPosNew) = sNew
          WritePos = BufferPosNext
        Else
          'Position bestimmen:
          BufferPosNext = WritePos + NewLen
          'Ggf. Buffer vergrößern:
          If BufferPosNext > BufferLen Then
            buffer = buffer & Space$(BufferPosNext)
            BufferLen = LenB(buffer)
          End If
          'String "patchen":
          MidB$(buffer, WritePos) = sNew
          WritePos = BufferPosNext
        End If
        ReadPos = start + OldLen
        start = InStrB(ReadPos, Search, sOld)
        If start = 0 Then Exit For
      Next count
      'Ergebnis zusammenbauen:
      If ReadPos > TextLen Then
        result = LeftB$(buffer, WritePos - 1)
      Else
        BufferPosNext = WritePos + TextLen - ReadPos
        If BufferPosNext < BufferLen Then
          MidB$(buffer, WritePos) = MidB$(Text, ReadPos)
          result = LeftB$(buffer, BufferPosNext)
        Else
          result = LeftB$(buffer, WritePos - 1) & MidB$(Text, ReadPos)
        End If
      End If
      Exit Sub
    End Select
    Else 'Kein Treffer:
    result = Text
  End If
End Sub

[sancarn]

This is a fair shout, I think it's only really going to affect a few libraries like stdJSON and stdDate (possibly). Not suire of many others where this will make a huge difference though. Have you ran any tests across your own projects by substituting this function?

[SanbiVN]

I usually use the Replace function to process long strings, calling it multiple times in a loop, but I haven't really tested it.
What I found is that the original Replace function is very slow.
I can only give a test procedure so you can see the performance difference.
More testing may be needed for Unicode character processing.

[sancarn]

What would be great is substituting this function in some stdVBA class, and testing the comparative performance. The reason I mention this is I don't think replace is the bottleneck for most stdVBA library functions, and I don't anticipate ultra high performance being a requirement in VBA in general (else you would use twinBasic/C). So there is a tradeoff.

If we were making a stdString class then this would absolutely be a good function to include.