UNKNOWN '************************************** ' Name: Word Replace ' Description:replaces whole words in a ' string matching existing case ' By: Je. ' ' ' Inputs:None ' ' Returns:None ' 'Assumes:None ' 'Side Effects:None 'This code is copyrighted and has limite ' d warranties. 'Please see http://www.Planet-Source-Cod ' e.com/xq/ASP/txtCodeId.74573/lngWId.1/qx ' /vb/scripts/ShowCode.htm 'for details. '************************************** 'replaces whole words in a string matchi ' ng 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