' by Olaf Schmidt, os@datenhaus.de, 20010106
' modified by G.Beckmann, G.Beckmann@NikoCity.de, 2001-11-04

Option Explicit

' VB5 -> msvbvm50.dll
Private Declare Function ArrPtr& Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any)
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&)
Private Declare Function CharLowerBuffA& Lib "user32" (lpsz As Any, ByVal cchLength&)
Private Declare Function CharLowerBuffW& Lib "user32" (lpsz As Any, ByVal cchLength&)

Private aSrc%(), saSrc As bstrapi.SAFEARRAY1D
Private aNew%(), saNew As bstrapi.SAFEARRAY1D
Private aOld%(), saOld As bstrapi.SAFEARRAY1D
Private aDst%(), saDst As bstrapi.SAFEARRAY1D
Private aPosFnd&(), ubPosFnd&
Private aLowChars%(&H8000 To &H7FFF)

Friend Function Replace11(Text As String, sOld As String, sNew As String, _
    Optional ByVal Start As Long = 1, _
    Optional ByVal Count As Long = 2147483647, _
    Optional ByVal Compare As VbCompareMethod = vbBinaryCompare _
  ) As String

    Dim c&, i&, j&, cntCpy&, Fnd0%, ubFnd&, fSameLen As Boolean
    Dim cntFnd&, ptrSrc&, ptrDst&
    Dim lenFnd&, lenSrc&, lenNew&, lenNewB&
    Dim posFnd&, posOut&, posIn&
    
    lenSrc = Len(Text)
    lenNew = Len(sNew)
    lenFnd = Len(sOld)
    ubFnd = lenFnd - 1
    ptrSrc = StrPtr(Text)
    
    If lenSrc = 0 Then Exit Function
    If lenFnd = 0 Then Replace11 = bstrapi.SysAllocStringLenPtr(ptrSrc, lenSrc): Exit Function
    If Start > 0 Then i = Start - 1
    
    saSrc.pvData = ptrSrc
    saOld.pvData = StrPtr(sOld)
    saNew.pvData = StrPtr(sNew)
    
    If lenFnd = lenNew Then
        fSameLen = True
        Replace11 = bstrapi.SysAllocStringLenPtr(ptrSrc, lenSrc)

        saDst.pvData = StrPtr(Replace11)
'        ptrDst = StrPtr(Replace11)
'        saDst.pvData = ptrDst
    End If
    
    c = lenSrc - lenFnd
    If Compare = vbBinaryCompare Then
        
        Fnd0 = aOld(0)
    
        For i = i To c
            'Inline-Cascading for first Char
            If aSrc(i) <> Fnd0 Then i = i + 1: _
                If aSrc(i) <> Fnd0 Then i = i + 1: _
                If aSrc(i) <> Fnd0 Then i = i + 1: _
                If aSrc(i) <> Fnd0 Then i = i + 1: _
                If aSrc(i) <> Fnd0 Then i = i + 1: _
                If aSrc(i) <> Fnd0 Then i = i + 1: _
                If aSrc(i) <> Fnd0 Then i = i + 1: _
                If aSrc(i) <> Fnd0 Then GoTo loopNxt

            If i > c Then Exit For

            'Search all others
            j = ubFnd
            Do While j
                If aSrc(i + j) <> aOld(j) Then GoTo loopNxt
                j = j - 1
            Loop

            cntFnd = cntFnd + 1
            'Found at Position i (0 based)
            If fSameLen Then
                j = lenNew: Do: j = j - 1: aDst(i + j) = aNew(j): Loop While j
'                saDst.pvData = ptrDst + i * 2
'                j = lenNew: Do: j = j - 1: aDst(j) = aNew(j): Loop While j
            Else
                If cntFnd > ubPosFnd Then ubPosFnd = ubPosFnd + 512: ReDim Preserve aPosFnd(ubPosFnd)
                aPosFnd(cntFnd) = i * 2
            End If

            If cntFnd = Count Then Exit For
            i = i + ubFnd
loopNxt: Next i


    Else 'vbStringCompare
    
        Fnd0 = aLowChars(aOld(0))
        
        For i = i To c
            If aLowChars(aSrc(i)) <> Fnd0 Then i = i + 1: _
                If aLowChars(aSrc(i)) <> Fnd0 Then i = i + 1: _
                If aLowChars(aSrc(i)) <> Fnd0 Then i = i + 1: _
                If aLowChars(aSrc(i)) <> Fnd0 Then i = i + 1: _
                If aLowChars(aSrc(i)) <> Fnd0 Then i = i + 1: _
                If aLowChars(aSrc(i)) <> Fnd0 Then i = i + 1: _
                If aLowChars(aSrc(i)) <> Fnd0 Then i = i + 1: _
                If aLowChars(aSrc(i)) <> Fnd0 Then GoTo loopNxt2
            
            If i > c Then Exit For
            
            'Search all others
            j = ubFnd
            Do While j
                If aLowChars(aSrc(i + j)) <> aLowChars(aOld(j)) Then GoTo loopNxt2
                j = j - 1
            Loop
            'Found at Position i (0 based)
            cntFnd = cntFnd + 1
            If fSameLen Then
                j = lenNew: Do: j = j - 1: aDst(i + j) = aNew(j): Loop While j
'                saDst.pvData = ptrDst + i * 2
'                j = lenNew: Do: j = j - 1: aDst(j) = aNew(j): Loop While j
            Else
                If cntFnd > ubPosFnd Then ubPosFnd = ubPosFnd + 512: ReDim Preserve aPosFnd(ubPosFnd)
                aPosFnd(cntFnd) = i * 2
            End If
            If cntFnd = Count Then Exit For
            i = i + ubFnd
loopNxt2: Next i
    End If
  
    'Generate Output
    If Not fSameLen Then
        If cntFnd = 0 Then
            Replace11 = bstrapi.SysAllocStringLenPtr(ptrSrc, lenSrc)
        Else
            c = lenSrc + (lenNew - lenFnd) * cntFnd
            Replace11 = bstrapi.SysAllocStringLenPtr(ByVal 0, c)
            ptrDst = StrPtr(Replace11)
            saDst.pvData = ptrDst
            
            lenFnd = lenFnd * 2
            If lenNew Then
                lenNewB = lenNew * 2
                For i = 1 To cntFnd
                    posFnd = aPosFnd(i)
                    cntCpy = posFnd - posIn
                    
                    If cntCpy > 50 Then
                        RtlMoveMemory ByVal saDst.pvData, ByVal saSrc.pvData, cntCpy
                        saDst.pvData = saDst.pvData + cntCpy
                    ElseIf cntCpy > 0 Then
                        j = cntCpy \ 2:  Do: j = j - 1: aDst(j) = aSrc(j): Loop While j
                        saDst.pvData = saDst.pvData + cntCpy
                    End If
                    
                    posIn = posFnd + lenFnd
                    saSrc.pvData = ptrSrc + posIn
                    
                    If lenNew > 50 Then
                        RtlMoveMemory ByVal saDst.pvData, ByVal saNew.pvData, lenNewB
                    Else
                        j = lenNew: Do: j = j - 1: aDst(j) = aNew(j): Loop While j
                    End If
                    saDst.pvData = saDst.pvData + lenNewB
                Next i
            Else
                For i = 1 To cntFnd
                    posFnd = aPosFnd(i)
                    cntCpy = posFnd - posIn
                    
                    If cntCpy > 50 Then
                        RtlMoveMemory ByVal saDst.pvData, ByVal saSrc.pvData, cntCpy
                        saDst.pvData = saDst.pvData + cntCpy
                    ElseIf cntCpy > 0 Then
                        j = cntCpy \ 2:  Do: j = j - 1: aDst(j) = aSrc(j): Loop While j
                        saDst.pvData = saDst.pvData + cntCpy
                    End If
                    
                    posIn = posFnd + lenFnd
                    saSrc.pvData = ptrSrc + posIn
                Next i
            End If
            
            c = lenSrc * 2 - posIn
            If c > 50 Then
                RtlMoveMemory aDst(0), aSrc(0), c
            ElseIf c > 0 Then
                c = c \ 2:  Do: c = c - 1: aDst(c) = aSrc(c): Loop While c
            End If
        End If
    End If
End Function


Private Sub Class_Initialize()
    Dim c&
    
    ubPosFnd = 512: ReDim Preserve aPosFnd(ubPosFnd)
  
    saSrc.cDims = 1
    saSrc.cbElements = 2
    saSrc.cElements1D = &H7FFFFFFF
                   RtlMoveMemory ByVal ArrPtr(aSrc), VarPtr(saSrc), 4
    saNew = saSrc: RtlMoveMemory ByVal ArrPtr(aNew), VarPtr(saNew), 4
    saOld = saSrc: RtlMoveMemory ByVal ArrPtr(aOld), VarPtr(saOld), 4
    saDst = saSrc: RtlMoveMemory ByVal ArrPtr(aDst), VarPtr(saDst), 4
    
    For c = -32768 To 32767: aLowChars(c) = c: Next c
    If CharLowerBuffW(aLowChars(-32768), &H10000) = 0 Then
      CharLowerBuffA aLowChars(65), (223 - 65) * 2
    End If
        
    ' added by donald, 20011210
    ' patch the stooges
    '  138/352    154/353
    '  140/338    156/339
    '  142/381    158/382
    '  159/376    255/255
    aLowChars(352) = 353
    aLowChars(338) = 339
    aLowChars(381) = 382
    aLowChars(376) = 255

End Sub

Private Sub Class_Terminate()
    RtlZeroMemory ByVal ArrPtr(aSrc), 4
    RtlZeroMemory ByVal ArrPtr(aNew), 4
    RtlZeroMemory ByVal ArrPtr(aOld), 4
    RtlZeroMemory ByVal ArrPtr(aDst), 4
End Sub