20161226xlVBA演示文稿替换文字另存pdf

Posted 2020-09-27 Excel VBA 小天地

Const ModelText As String = "机构名称"
Const ModelName As String = "测试文件.pptx"

Sub NextSeven_CodeFrame()
    ‘应用程序设置
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    ‘错误处理
    On Error GoTo ErrHandler
    ‘计时器
    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer

    ‘变量声明
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim Rng As Range
    Dim Arr As Variant
    Dim EndRow As Long

    Dim pApp As Object
    Dim Pre As Object
    ‘Dim pApp As PowerPoint.Application
    ‘Dim pre As PowerPoint.Presentation

    Dim FindStr As String
    Dim ReplaceStr As String
    Dim FilePath As String
    Dim FolderPath As String
    Dim tmp As String

    Dim FileName As String
    FileName = Left(ModelName, InStrRev(ModelName, ".") - 1)
    ‘实例化对象
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets(1)
    FolderPath = Wb.Path & "\"
    ‘Set pApp = New PowerPoint.Application
    Set pApp = CreateObject("PowerPoint.Application")
    Debug.Print FolderPath & ModelName
    Set Pre = pApp.Presentations.Open(FolderPath & ModelName)
    With Sht
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A1:Z" & EndRow)
        Arr = Rng.Value
        For i = LBound(Arr) To UBound(Arr)
            If i = 1 Then
                FindStr = ModelText
                ReplaceStr = Arr(i, 1)
                FilePath = FolderPath & FileName & "_予" & Arr(i, 1) & ".pdf"
                ReplaceAndPublish Pre, FilePath, FindStr, ReplaceStr
            Else
                FindStr = Arr(i - 1, 1)
                ReplaceStr = Arr(i, 1)
                FilePath = FolderPath & FileName & "_予" & Arr(i, 1) & ".pdf"
                ReplaceAndPublish Pre, FilePath, FindStr, ReplaceStr
            End If
        Next i
    End With
    ‘运行耗时
    UsedTime = VBA.Timer - StartTime
    ‘MsgBox "本次运行耗时：" & Format(UsedTime, "0.0000000秒")
ErrorExit:        ‘错误处理结束，开始环境清理
    Pre.Close
    Set Pre = Nothing
    pApp.Quit
    Set pApp = Nothing
    Set Wb = Nothing
    Set Sht = Nothing
    Set Rng = Nothing

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "错误提示！"
        ‘Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub
Private Sub ReplaceAndPublish(ByVal Pre As Object, ByVal FilePath As String, ByVal FindText As String, ByVal ReplaceText As String)
    Dim sld As PowerPoint.Slide
    Dim shp As PowerPoint.Shape
    Dim Txt As String
    For Each sld In Pre.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame = msoTrue Then
                If shp.TextFrame.HasText Then
                    Txt = shp.TextFrame.TextRange.Text
                    If InStr(1, Txt, FindText) > 0 Then
                        shp.TextFrame.TextRange.Text = Replace(Txt, FindText, ReplaceText)
                        Exit For
                    End If
                End If
            End If
        Next
    Next
    Pre.SaveAs FilePath, ppSaveAsPDF
End Sub