首页 > 代码库 > 20161226xlVBA演示文稿替换文字另存pdf
20161226xlVBA演示文稿替换文字另存pdf
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
20161226xlVBA演示文稿替换文字另存pdf
声明:以上内容来自用户投稿及互联网公开渠道收集整理发布,本网站不拥有所有权,未作人工编辑处理,也不承担相关法律责任,若内容有误或涉及侵权可进行投诉: 投诉/举报 工作人员会在5个工作日内联系你,一经查实,本站将立刻删除涉嫌侵权内容。