20161226xlVBA Presentation replacement text save PDF

Const Modeltext As String = "Institution name" Const modelname As String = "test file. pptx" Sub nextseven_codeframe () ' Application settings Applicati Mnl ScreenUpdating = False Application.DisplayAlerts = False application.calculation = Xlcalculationmanual ' ERROR handling O n Error GoTo errhandler ' timer Dim StartTime, usedtime as Variant StartTime = VBA. Timer ' variable declaration Dim Wb As Workbook Dim Sht As Worksheet Dim Rng As Range Dim Arr As Variant Dim endrow As Lo Ng Dim Papp As Object Dim pre As Object ' Dim papp As PowerPoint.Application ' Dim pre as Powerpoint.presentatio  N 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) ' Instantiation of object Set Wb = Applic ation.    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 &A mp                "_ To" & Arr (I, 1) & ". pdf" Replaceandpublish Pre, FilePath, FINDSTR, Replacestr Else FINDSTR = Arr (i-1, 1) replacestr = arr (i, 1) FilePath = FolderPath & Filena            Me & "_ To" & Arr (I, 1) & ". pdf" Replaceandpublish Pre, FilePath, FINDSTR, Replacestr End If Next i End with ' run time Usedtime = VBA.    Timer-starttime ' MsgBox "This Run Time:" & Format (Usedtime, "0.0000000 Seconds") Errorexit: ' Error handling ended, start environment cleanup Pre.close SetPre = Nothing Papp.quit Set papp = Nothing Set Wb = Nothing Set Sht = Nothing Set Rng = Nothing applicat Ion. ScreenUpdating = True Application.DisplayAlerts = True application.calculation = xlcalculationautomatic Exit SubE Rrhandler:if err.number <> 0 then MsgBox err.description & "! ", vbcritical," Error prompt! "' Debug.Print err.description err.clear Resume errorexit End ifend SubPrivate Sub replaceandpubli SH (ByVal Pre as Object, ByVal FilePath As String, ByVal FindText as String, ByVal ReplaceText as String) Dim SLD as Pow Erpoint.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 Next Next Pre.saveas FilePath, Ppsaveaspdfend Sub

　　

20161226xlVBA Presentation replacement text save PDF