Word Replace

				
'**************************************
' Name: Word Replace
' Description:replaces whole words in a string matching existing case
' By: Je.
'
'This code is copyrighted and has' limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=74573&lngWId=1'for details.'**************************************

'replaces whole words in a string matching existing case
'in a form
Option Explicit
Private Declare Function IsCharAlphaNumericW Lib "user32" (ByVal cChar As Integer) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Sub Form_Load()
Dim text1 As String, text2 As String, text3 As String, res As Long, orlen As Long
Me.AutoRedraw = True
text1 = "Fish bats a A Fish-Fish fish. Fishing bat Fishb nfish (fish) FISH fish"
orlen = Len(text1)
text2 = "Fish"
text3 = "hatters"
Me.Print text1
res = WordReplace(text1, text2, text3, 6, Len(text1) - 6, 2)
Me.Print text1
Me.Print "no replacements: " & res
Me.Print "string length change: " & (Len(text1) - orlen)
End Sub
Function WordReplace(Ostring As String, ExistingWord As String, ReplaceWord As String, Optional aStart As Long = -1, Optional bEnd As Long = -1, Optional NoReplacements As Long = &H8000000) As Long
Dim ii() As Integer, resi() As Integer, wdLower() As Integer, wdUpper() As Integer
Dim tmp As String, lenstr As Long, lenRepWd As Long, lenRepWd2 As Long
Dim lenWord As Long, wholeWd As Long, t As Single, n As Long, j As Long
Dim LCaseReplacement As String, UCaseReplacement As String, ProperCaseReplacement As String, i As Long, c As Long
Dim offset As Long, resSt As String
 lenWord = Len(ExistingWord): lenRepWd = Len(ReplaceWord): lenRepWd2 = lenRepWd * 2
If aStart = -1 Then aStart = 1
If bEnd = -1 Then bEnd = Len(Ostring)
lenstr = bEnd - aStart + 1
If lenstr < lenWord Then
Exit Function
ElseIf lenWord = lenstr Then 'deal with lenWord = lenstr
resSt = Mid(Ostring, aStart, bEnd - 1 + 1)
If ExistingWord = resSt Then
WordReplace = 1
If UCase(ExistingWord) = ExistingWord Then
resSt = UCase(ReplaceWord)
ElseIf LCase(ExistingWord) = ExistingWord Then
resSt = LCase(ReplaceWord)
Else
resSt = StrConv(ReplaceWord, vbProperCase)
End If
GoTo addLeftRight
Exit Function
End If
End If
stringToIntegerArray Ostring, ii, aStart, bEnd
tmp = LCase(ExistingWord): stringToIntegerArray tmp, wdLower 'some preparation
tmp = UCase(ExistingWord): stringToIntegerArray tmp, wdUpper
LCaseReplacement = LCase(ReplaceWord): ProperCaseReplacement = StrConv(ReplaceWord, vbProperCase): UCaseReplacement = UCase(ReplaceWord)
If lenRepWd <= lenWord Then 'size buffer for result
ReDim resi(lenstr - 1)
Else
t = lenRepWd * lenstr
t = t / lenWord
ReDim resi(-Int(-(t)))
End If
Do
If i > UBound(ii) - lenWord + 1 Then Exit Do
c = 0
For j = i To i + lenWord - 1 'find match
 If wdLower(c) <> ii(j) And wdUpper(c) <> ii(j) Then resi(n) = ii(i): i = i + 1: n = n + 1: GoTo HR
 c = c + 1
Next
wholeWd = 0
If i = 0 Then 'is it aStart whole word
wholeWd = 1
Else '45 = hyphen '160 = non breaking space
offset = i - 1
If IsCharAlphaNumericW(ii(offset)) = 0 And (ii(offset) <> 45) And (ii(offset) <> 160) Then wholeWd = 1
End If
If i = UBound(ii) - lenWord + 1 Then
wholeWd = wholeWd Or 2
Else
offset = i + lenWord
If IsCharAlphaNumericW(ii(offset)) = 0 And (ii(offset) <> 45) And (ii(offset) <> 160) Then wholeWd = wholeWd Or 2
End If
If wholeWd <> 3 Then resi(n) = ii(i): i = i + 1: n = n + 1: GoTo HR 'not whole word
 WordReplace = WordReplace + 1
If wdUpper(0) = ii(i) And ii(i) <> wdLower(0) Then 'is first letter upper case
If lenWord > 1 Then
If wdUpper(1) = ii(i + 1) And ii(i + 1) <> wdLower(1) Then 'is second letter upper
CopyMemory resi(n), ByVal StrPtr(UCaseReplacement), lenRepWd2 'upper case
Else
CopyMemory resi(n), ByVal StrPtr(ProperCaseReplacement), lenRepWd2 'proper case
End If
Else
CopyMemory resi(n), ByVal StrPtr(UCaseReplacement), lenRepWd2 'lower case
End If
Else
CopyMemory resi(n), ByVal StrPtr(LCaseReplacement), lenRepWd2 'first letter lower - lower case
End If
n = n + lenRepWd: i = i + lenWord
If WordReplace = NoReplacements Then Exit Do
HR: Loop
If i <> UBound(ii) + 1 Then ' do end characters if needed
For j = i To UBound(ii)
 resi(n) = ii(j): n = n + 1
Next
End If
If aStart = 1 And bEnd = Len(Ostring) Then
integerArrayToString resi, Ostring, 0, n - 1
Else
integerArrayToString resi, resSt, 0, n - 1
addLeftRight:
If aStart > 1 Then resSt = Left(Ostring, aStart - 1) & resSt
If bEnd < Len(Ostring) Then resSt = resSt & Right(Ostring, Len(Ostring) - bEnd)
Ostring = resSt
End If
End Function
'helper functions
Sub stringToIntegerArray(st As String, ia() As Integer, Optional a As Long = -1, Optional b As Long)
Dim ls As Long
If a = -1 Or b = -1 Then a = 1: b = Len(st)
ls = b - a + 1
If ls = 0 Then Exit Sub
ReDim ia(ls - 1)
CopyMemory ByVal VarPtr(ia(0)), ByVal StrPtr(st) + ((a - 1) * 2), ls * 2
End Sub
Sub integerArrayToString(ia() As Integer, st As String, Optional a As Long = -1, Optional b As Long)
Dim noi As Long
If a = -1 Then a = 0
If b = -1 Then b = UBound(ia)
noi = b - a + 1
st = String(noi, Chr(0))
CopyMemory ByVal StrPtr(st), ByVal VarPtr(ia(a)), noi * 2
End Sub