求助：使用VBA替换PPT中美式英语词汇为英式英语的代码失效

原代码存在几个关键问题导致无法正常运行，同时没实现美式词汇替换为英式的核心需求：

• 固定循环100页，若PPT页数不足会直接报错
• 未判断形状是否包含文本框，遇到图片、图表等无文本的形状时会触发错误
• 仅修改了文本的语言标记，没有实际替换美式英语词汇（比如color→colour）

修复后的完整代码 #

Sub ReplaceAmericanToBritishEnglish()
    Dim sld As Slide
    Dim shp As Shape
    Dim textRng As TextRange
    Dim wordDict As Object
    Dim key As Variant
    
    ' 创建美式-英式词汇对应字典
    Set wordDict = CreateObject("Scripting.Dictionary")
    wordDict.Add "color", "colour"
    wordDict.Add "center", "centre"
    wordDict.Add "favorite", "favourite"
    wordDict.Add "behavior", "behaviour"
    wordDict.Add "organization", "organisation"
    ' 可根据需求添加更多词汇
    
    ' 遍历所有幻灯片
    For Each sld In ActivePresentation.Slides
        ' 遍历幻灯片上的所有形状
        For Each shp In sld.Shapes
            ' 仅处理有文本框且包含文本的形状
            If shp.HasTextFrame And shp.TextFrame.HasText Then
                Set textRng = shp.TextFrame.TextRange
                
                ' 先修改语言ID为英式英语
                If textRng.LanguageID = msoLanguageIDEnglishUS Then
                    textRng.LanguageID = msoLanguageIDEnglishUK
                End If
                
                ' 替换美式词汇为英式
                For Each key In wordDict.Keys
                    textRng.Replace FindWhat:=key, ReplaceWhat:=wordDict(key), _
                        MatchCase:=False, WholeWords:=True
                Next key
            End If
            
            ' 处理分组内的子形状
            If shp.Type = msoGroup Then
                Dim subShp As Shape
                For Each subShp In shp.GroupItems
                    If subShp.HasTextFrame And subShp.TextFrame.HasText Then
                        Set textRng = subShp.TextFrame.TextRange
                        If textRng.LanguageID = msoLanguageIDEnglishUS Then
                            textRng.LanguageID = msoLanguageIDEnglishUK
                        End If
                        For Each key In wordDict.Keys
                            textRng.Replace FindWhat:=key, ReplaceWhat:=wordDict(key), _
                                MatchCase:=False, WholeWords:=True
                        Next key
                    End If
                Next subShp
            End If
        Next shp
    Next sld
End Sub

代码说明 #

• 用Scripting.Dictionary存储美式-英式词汇对，方便扩展更多词汇
• 动态遍历所有幻灯片，避免固定页数导致的报错
• 增加HasTextFrame和HasText判断，跳过无文本的形状，防止运行错误
• 同时完成语言ID修改和实际词汇替换，完全满足需求
• 新增分组形状的处理逻辑，覆盖PPT中分组内的文本内容

内容的提问来源于stack exchange，提问作者NNBLUE