使用 Textrange.replace 时未保持区分大小写

Question

我希望一切都好.. 我一直在尝试开发一个小宏，它可以从 PowerPoint 演示文稿中找到某些单词，并使用方法

将它们替换为某些其他单词

TextRange.Replace(FindWhat:=FindString, Replacewhat:=ReplaceString, _
                  WholeWords:=True, MatchCase := False)

要求是ReplaceString要和演示文稿中要替换的词一样区分大小写。但是使用上述方法，ReplaceString 的大小写始终保持不变（如前所述）。我需要根据演示文稿中 FindString 的情况更改它。

比如我的FindString是bridge，ReplaceString是brg，在我的演示中，如果出现Bridge和BRIDGE，就应该分别替换成Brg和BRG（但是上面的方法是替换Bridge和BRIDGE与 brg)

我希望我的查询有些道理..

谁能帮我解决这个问题？

谢谢问候

Answer 1

我认为你可以做到这一点，但不能用 .Replace。有必要将查找和替换的步骤分开，这样您就可以在两者之间检查找到的内容，然后用类似的文本大小写替换（例如 upper、lower 或 'proper'）。

关键是使用InStr函数，因为它可以让你用任何文本大小写进行查找，同时还可以让你设置查找起始索引和return匹配的索引found - 这样您就可以循环遍历每场比赛，一次一场。然后，找到文本大小写，循环遍历匹配的每个字符，计算上下；并相应地替换。

Public Function ReplaceMatchCase(str, find, replace) As String
    Dim lenStr As Long
    Dim lenFind As Long
    Dim i As Long
    Dim j As Long
    Dim countUpper As Long
    Dim countLower As Long
    Dim chr As String
    
    i = 1
    lenStr = Len(str)
    lenFind = Len(find)
    
    If lenFind = 0 Or lenStr = 0 Or lenStr < lenFind Then
        ReplaceMatchCase = str
        Exit Function
    End If
    
    'Loop through each match
    Do
        i = InStr(i, str, find, vbTextCompare)
        
        If i = 0 Then
            Exit Do
        End If
        
        countUpper = 0
        countLower = 0
        
        'Loop through chars in each match
        For j = i To i + lenFind - 1
            chr = Mid(str, j, 1)
            If chr = UCase(chr) Then
                countUpper = countUpper + 1
            Else
                countLower = countLower + 1
            End If
        Next j
        
        'Replace
        If countUpper <> 0 And countLower = 0 Then
            'Uppercase
            str = Mid(str, 1, i - 1) & UCase(replace) & Mid(str, i + lenFind)
        
        ElseIf countUpper = 0 And countLower <> 0 Then
            'Lowercase
            str = Mid(str, 1, i - 1) & LCase(replace) & Mid(str, i + lenFind)
        
        Else
            'Mixed - assume 'proper' case - can change this according to need
            str = Mid(str, 1, i - 1) & UCase(Mid(replace, 1, 1)) & LCase(Mid(replace, 2)) & Mid(str, i + lenFind)
        End If
        
    Loop While i <> 0
    
    ReplaceMatchCase = str
End Function

您可以这样测试函数：

Sub Test()
    Debug.Print ReplaceMatchCase("I walked to the furthest bridge and on the way I passed the first BRIDGE and the second Bridge.", "Bridge", "Brg")
End Sub

'I walked to the furthest brg and on the way I passed the first BRG and the second Brg.

在 PowerPoint 中，您可以像这样使用函数：

TextRange.Text = ReplaceMatchCase(TextRange.Text, FindString, ReplaceString)

Answer 2

这是一个简单的例子。在尝试任何替换之前，它会检查是否在文本范围内找到了这个词：这应该可以解决您的一些性能问题。具有能够使用 WholeWords:=True 的优点，它可以防止替换较长单词的子字符串。

Sub Tester()

    Dim tr As TextRange
    
    Set tr = ActivePresentation.Slides(1).Shapes(1).TextFrame.TextRange
    
    DoReplace tr, "bridge", "brg"
    
End Sub

Sub DoReplace(tr As TextRange, findThis, replaceWith)
    If InStr(1, tr.Text, findThis, vbTextCompare) > 0 Then 'is the word found at all?
        'found at least one case form - just try to replace any case form found...
        tr.Replace findWhat:=LCase(findThis), Replacewhat:=LCase(replaceWith), _
                  WholeWords:=True, MatchCase:=True
        tr.Replace findWhat:=UCase(findThis), Replacewhat:=UCase(replaceWith), _
                  WholeWords:=True, MatchCase:=True
        tr.Replace findWhat:=StrConv(findThis, vbProperCase), _
                   Replacewhat:=StrConv(replaceWith, vbProperCase), _
                  WholeWords:=True, MatchCase:=True
    End If
End Sub

使用 Textrange.replace 时未保持区分大小写

Case sensitivity not maintained while using Textrange.replace

powerpoint

vba

case-sensitive

str-replace