Replacement for VB6s Replace$ - only faster!

Category:

String Manipulation

Type:

Modules

Difficulty:

Intermediate

Author: Rd

Version Compatibility: Visual Basic 6, Visual Basic 5

More information:

This module blows VB's Replace$ away while staying 100% call and behavior compatible. Even if you use VB6 you should still use this in place of VB's Replace$ - it is 3 - 4 times faster!

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
' (None)

Code:

Public Function Replace(sSrc As String, _
                        sTerm As String, _
                        sNewTerm As String, _
                        Optional lStart As Long = 1, _
                        Optional lHitCnt As Long, _
                        Optional ByVal lCompare As _
                        VbCompareMethod = vbBinaryCompare _
                        ) As String ' Rd

Dim lSize As Long, lHit As Long, lHitPos As Long, lPos As Long
    Dim lLenOrig As Long, lOffset As Long, lOffStart As Long
    Dim lLenOld As Long, lLenNew As Long, lCnt As Long
    Dim s1 As String, s2 As String, al() As Long

'On Error GoTo FreakOut

lLenOrig = Len(sSrc)
    If (lLenOrig = 0) Then Exit Function ' No text

lLenOld = Len(sTerm): lLenNew = Len(sNewTerm)
    Replace = sSrc
    If (lLenOld = 0) Then Exit Function

If lCompare = vbBinaryCompare Then
        s1 = sTerm: s2 = sSrc
    Else
        s1 = LCase$(sTerm): s2 = LCase$(sSrc)
    End If

lOffset = lLenNew - lLenOld
    lCnt = 0: lSize = 8000 ' lSize = Arr chunk size
    ReDim al(0 To lSize) As Long

lHit = InStr(lStart, s2, s1)
    Do While (lHit <> 0) And (lHit <= lLenOrig)
        al(lCnt) = lHit: lCnt = lCnt + 1
        If (lCnt = lHitCnt) Then Exit Do
        If (lCnt = lSize) Then
            lSize = lSize + 8000
            ReDim Preserve al(0 To lSize) As Long
        End If
        lOffStart = lHit + lLenOld ' offset start pos
        lHit = InStr(lOffStart, s2, s1)
    Loop

If (lCnt = 0) Then GoTo FreakOut ' No hits
    lHitCnt = lCnt
    If lCompare = vbBinaryCompare Then
        If StrComp(s1, sNewTerm) = 0 Then Exit Function
    End If

lSize = (lLenOrig + lOffset * lCnt) ' lSize = result str size
    Replace = Space$(lSize)

lCnt = lCnt - 1: lOffStart = 1: lPos = 1
    For lHit = 0 To lCnt
        lHitPos = al(lHit)
        Mid$(Replace, lOffStart) = Mid$(sSrc, lPos, lHitPos - lPos)
        lOffStart = lHitPos + (lOffset * lHit)
        If (lLenNew <> 0) Then
            Mid$(Replace, lOffStart) = sNewTerm
            lOffStart = lOffStart + lLenNew
        End If
        lPos = lHitPos + lLenOld ' No offset orig str
    Next

If lOffStart <= lSize Then
        Mid$(Replace, lOffStart) = Mid$(sSrc, lPos)
    End If
    'lHitCnt = lHit
FreakOut:
End Function    ' Rd - cryptic but crazy :)