请求修改VBA代码：将Word文本替换功能适配至PPT(.pptx)

以下是适配PPTX文件的VBA代码，可实现用Excel数据批量替换PPT模板中的指定文本：

Sub AutoContractPPT()
    Dim cell            As Range
    Dim rng             As Range
    Dim ppApp           As Object ' 后期绑定PowerPoint对象，无需手动引用库
    Dim ppPres          As Object
    Dim FilePath        As String
    Dim FilePath2       As String
    Dim Filename        As String
    Dim StrDoc          As String
    Dim rngPara         As Range
    Dim SaveAsName      As String
    Dim slideObj        As Object
    Dim shapeObj        As Object
    Dim subShapeObj     As Object

    On Error GoTo ErrorHandler

    Set ppApp = CreateObject("PowerPoint.Application")
    FilePath = ThisWorkbook.Path
    FilePath2 = Left(FilePath, InStr(FilePath, "\Calculations") - 1)
    Filename = "Filename.pptx" ' 替换为你的PPT模板文件名
    StrDoc = FilePath2 & "\Inputs\" & Filename
    Set ppPres = ppApp.Presentations.Open(StrDoc)

    ' 定位变量参数区域
    Set rngPara = Range("A1:Z1058").Find("Variable Parameters")
    If rngPara Is Nothing Then
        MsgBox "未找到Variable Parameters列。"
        GoTo ErrorExit
    End If
    Set rng = Range(rngPara, rngPara.End(xlDown))
    ppApp.Visible = True

    ' 遍历每个变量，批量替换PPT中的文本
    For Each cell In rng
        If cell.Value = "" Then Exit For
        ' 遍历所有幻灯片
        For Each slideObj In ppPres.Slides
            ' 遍历当前幻灯片的所有形状
            For Each shapeObj In slideObj.Shapes
                ' 处理普通文本形状
                If shapeObj.HasTextFrame Then
                    If shapeObj.TextFrame.HasText Then
                        With shapeObj.TextFrame.TextRange.Find
                            .ClearFormatting
                            .Replacement.ClearFormatting
                            .MatchWildcards = False
                            .Text = cell.Value
                            .Replacement.Text = cell.Offset(0, 1).Value
                            .Execute Replace:=2 ' 对应ppReplaceAll常量值
                        End With
                    End If
                End If
                ' 处理分组形状内的子形状
                If shapeObj.Type = 6 Then ' msoGroup类型标识
                    For Each subShapeObj In shapeObj.GroupItems
                        If subShapeObj.HasTextFrame Then
                            If subShapeObj.TextFrame.HasText Then
                                With subShapeObj.TextFrame.TextRange.Find
                                    .ClearFormatting
                                    .Replacement.ClearFormatting
                                    .MatchWildcards = False
                                    .Text = cell.Value
                                    .Replacement.Text = cell.Offset(0, 1).Value
                                    .Execute Replace:=2
                                End With
                            End If
                        End If
                    Next subShapeObj
                End If
            Next shapeObj
        Next slideObj
    Next cell

    ' 保存生成的PPT文件
    SaveAsName = Left(FilePath, InStr(FilePath, "\Calculations") - 1) & "\Outputs\" & Range("EmployName").Value & " " & Range("TodayDate").Value & " Contract.pptx"
    ppPres.SaveAs SaveAsName

ErrorExit:
    ' 清理资源，避免后台残留进程
    If Not ppPres Is Nothing Then
        ppPres.Close
    End If
    If Not ppApp Is Nothing Then
        ppApp.Quit
    End If
    Set ppPres = Nothing
    Set ppApp = Nothing
    Exit Sub

ErrorHandler:
    Select Case Err.Number
        Case 5174
            MsgBox "请检查指定的文件名是否正确。"
        Case Else
            MsgBox "错误代码: " & Err.Number & "; 发生未知问题"
    End Select
    Resume ErrorExit
End Sub

• 对象模型切换：移除Word相关对象，改用PowerPoint的应用程序和演示文稿对象，使用后期绑定无需手动添加PowerPoint引用库
• PPT内容遍历逻辑：PPT的文本分散在各幻灯片的形状中，需遍历所有幻灯片、形状，包括分组形状内的子形状，确保所有可编辑文本都被覆盖
• 替换参数适配：PPT的Find.Execute方法中，全替换对应参数值为2（ppReplaceAll常量），避免未引用库时的常量报错
• 资源优化：添加演示文稿关闭和应用退出逻辑，防止PowerPoint进程在后台残留

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