VBA code that has worked with PPT 2003-2013 causes PPT 2016 to crash

Public pptApp As PowerPoint.Application

Sub Repeat()
  Dim x
  
  Set pptApp = New PowerPoint.Application
  
  For x = 1 To 10
    Debug.Print "Creating " & x
    CreatePowerPointFromVisio
    Debug.Print "Closing " & x
    pptApp.Presentations(1).Close
  Next
End Sub

Select allOpen in new window

' 2017-01-17
' modified code that ran in Visio to run it from Excel in order to determine whether PPT still crashes during slide creation

'
' Adapted from code in the Visio 2007 SDK Code Samples
' by Scott Helmers, Visio MVP, scott@VisioStepByStep.com
'
Option Explicit

' global variables and constants
Dim gaSlideInfo()                           ' array for slide names and numbers
Dim giSlideCount As Integer                 ' total number of slides

Const giLinesPerTOCSlide As Integer = 10    ' max lines per Table of Contents slide
Const giTestCount As Integer = 6            ' number of slides to create
 
Public pptApp As PowerPoint.Application

Sub MultipleTest()
  Dim x
  
  For x = 1 To 10
    'Set pptApp = New PowerPoint.Application
    Debug.Print "Creating PowerPoint object"
    Set pptApp = CreateObject("PowerPoint.Application")
    Do While pptApp Is Nothing
      ' This never seems to run
      Debug.Print "Waiting for " & x
      Application.Wait 1
    Loop

    Debug.Print "Creating " & x
    CreatePowerPointFromVisio
    Debug.Print "Closing " & x
    pptApp.Presentations(1).Close
    Debug.Print "Closed " & x & ", Doing Events"
    DoEvents
    If Not pptApp Is Nothing Then
      Debug.Print "Quitting PowerPoint"
      pptApp.Quit
      Debug.Print "PowerPoint Quit, clearing pptApp reference"
      Set pptApp = Nothing
      Debug.Print "pptApp reference cleared"
    End If
    Debug.Print "Next pres cycle"
  Next
  Debug.Print "Finished"
End Sub

Sub CreatePowerPointFromVisio()
' creates a PowerPoint presentation from a Visio file
' -- title slide: contains the Visio filename and author; also contains PPT creation date
' -- Table of Contents slide (one or more): contains slide names with hyperlinks
' -- slides containing an image from each Visio page
' -- summary slide: blank text box

    '''Dim vsoDoc              As Visio.Document
    Dim pptPres             As PowerPoint.Presentation
    
    Dim i As Integer
    
    ' process the active document
'''    Set vsoDoc = ActiveDocument
    ' resize global array based on page count in Visio document plus 1
    ' for the summary slide
    ReDim gaSlideInfo(giTestCount + 1, 2)
'''    ReDim gaSlideInfo(vsoDoc.Pages.Count + 1, 2)
    
    ' create a new PowerPoint instance
    Debug.Print "Make PPT visible"
    ' Next line error 462, "The remote server machine does not exist or is unavailable"
    ' or "Automation error The remote procedure call failed."
    pptApp.Visible = True
    'pptApp.WindowState = ppWindowMinimized
    
    ' create a new presentation
    Debug.Print "Create new pres"
    ' -2147023170 Automation error The remote procedure call failed.
    Set pptPres = pptApp.Presentations.Add(withwindow:=True)
    
    ' loop through pages in Visio document (but don't include background pages);
    giSlideCount = 0
    For i = 1 To giTestCount
'''    For i = 1 To vsoDoc.Pages.Count
'''        If vsoDoc.Pages(i).Background = False Then
            Debug.Print "MakeSlideFromVisioPage"
            Call MakeSlideFromVisioPage(i, pptPres)
'''            Call MakeSlideFromVisioPage(vsoDoc, i, pptPres)
'''        End If
    Next i
    
    ' create title slide
    Debug.Print "MakeTitleSlide"
    Call MakeTitleSlide(pptPres)
'''    Call MakeTitleSlide(vsoDoc, pptPres)
    
    ' create summary slide
    Debug.Print "MakeSummarySlide"
    Call MakeSummarySlide(pptPres)
    
    ' create table of contents slide(s)
    Debug.Print "MakeTableOfContents"
    Call MakeTableOfContents(pptPres)
    
    ' maximize PPT window, return to title slide, then run slide show
    pptApp.WindowState = ppWindowMaximized
    'pptPres.Slides(1).Select
    Debug.Print "Goto Slide 1"
    pptApp.ActiveWindow.View.GotoSlide 1
    Exit Sub
    With pptPres.SlideShowSettings
        .LoopUntilStopped = False
        .ShowWithNarration = msoTrue
        .ShowWithAnimation = msoTrue
        .RangeType = ppShowAll
        .PointerColor.RGB = RGB(Red:=255, Green:=0, Blue:=0)
        .Run
    End With
    
End Sub
Private Sub MakeSlideFromVisioPage(iPageNbr As Integer, _
                                   pres As PowerPoint.Presentation)
'''Private Sub MakeSlideFromVisioPage(doc As Visio.Document, _
'''                                   iPageNbr As Integer, _
'''                                   pres As PowerPoint.Presentation)
' creates jpg from Visio page, creates new PPT slide, then adds jpg to slide

    Dim sJPGFilename As String
'''    Dim pg As Visio.Page
'''    Dim shp1 As Visio.Shape, shp2 As Visio.Shape
    Dim dPgHeight As Double, dPgWidth As Double
    
    Dim pptSlide As PowerPoint.Slide
    Dim pptShape As PowerPoint.Shape
    
    Dim dJPGWidth As Double, dJPGHeight As Double
    Dim dSlideWidth As Double, dSlideHeight As Double
    Dim dW As Double, dH As Double, dRatio As Double

    ' set path and filename for temporary jpg images (put jpg in user's temp folder)
    sJPGFilename = Environ$("TEMP")
    If Right(sJPGFilename, 1) <> "\" Then sJPGFilename = sJPGFilename & "\"
    sJPGFilename = sJPGFilename & "TEMP image " & iPageNbr & ".jpg"
    '''sJPGFilename = sJPGFilename & Left(doc.Name, (Len(doc.Name) - 4)) & ".jpg"
    
'''    ' export drawing page to jpg file with same name as Visio doc (the file
'''    ' is overwritten for each page)
'''    Set pg = doc.Pages(iPageNbr)
'''
'''    ' NOTE: when Visio creates jpg images, it only creates them using the shapes on
'''    ' the page, i.e., it ignores all blank space outside the rectangle containing the
'''    ' shapes. Consequently, to create a jpg that contains the entire page, it is
'''    ' necessary to ensure that there are shapes at the very edges of each page.
'''    ' To do this we add a very small rectangle in the upper left and lower right
'''    ' corners of the page. then delete them after the export
'''    dPgHeight = pg.PageSheet.Cells("PageHeight").Result(visInches)
'''    dPgWidth = pg.PageSheet.Cells("PageWidth").Result(visInches)
'''    Set shp1 = pg.DrawRectangle(-0.01, dPgHeight + 0.01, -0.011, dPgHeight + 0.011)
'''    Set shp2 = pg.DrawRectangle(dPgWidth + 0.01, -0.01, dPgWidth + 0.011, -0.011)
'''    pg.Export sJPGFilename
''''='=' 2016-08-09
''''='=' Visio 2016 sometimes crashes when code delete a shape if any shapes are selected; deselect all before deleting
'''    doc.Application.Window.DeselectAll
''''='='
'''    shp1.Delete
'''    shp2.Delete
    
    ' add a slide into the Slides collection of the presentation.
    Set pptSlide = pres.Slides.Add(Index:=iPageNbr, Layout:=ppLayoutTitleOnly)
    ' store SlideID generated by PPT and Visio page name
    giSlideCount = giSlideCount + 1
    gaSlideInfo(giSlideCount, 1) = pptSlide.SlideID
    gaSlideInfo(giSlideCount, 2) = "TEMP image " & iPageNbr
'''    gaSlideInfo(giSlideCount, 2) = doc.Pages(iPageNbr).Name
    
    ' Add Visio page name to title text box for this slide
    pptSlide.Select
    pptSlide.Shapes.Title.TextFrame.TextRange = gaSlideInfo(giSlideCount, 2)
'''    pptSlide.Shapes.Title.TextFrame.TextRange = _
'''                fsSafeHLSubAddress(doc.Pages(iPageNbr).Name)
    ' get slide dimensions
    With pres.PageSetup
        dSlideWidth = .SlideWidth
        dSlideHeight = .SlideHeight
    End With
    
    ' add the jpg into the newly created slide
    Set pptShape = pptSlide.Shapes.AddPicture _
                        (Filename:=sJPGFilename, _
                         LinkToFile:=False, SaveWithDocument:=True, _
                         Left:=0, Top:=0)
    ' get jpg dimensions so we can resize image to fit on slide
    With pptShape
        dJPGWidth = .Width
        dJPGHeight = .Height
    End With
    ' calculate width and height ratios
    If dJPGWidth > dSlideWidth Then dW = (dSlideWidth / dJPGWidth) Else dW = 1
    If dJPGHeight > dSlideHeight Then dH = (dSlideHeight / dJPGHeight) Else dH = 1
    ' use minimum ratio to resize the image so it will fit on the slide
    If dW < dH Then dRatio = dW Else dRatio = dH
    ' center image on slide
    pptShape.Select
    With pres.Application.ActiveWindow.Selection.ShapeRange
        .Align msoAlignCenters, True
        .Align msoAlignMiddles, True
        .ScaleWidth dRatio, msoFalse, msoScaleFromMiddle
        .ScaleHeight dRatio, msoFalse, msoScaleFromMiddle
    End With

'='=' 2016-07-27
'='=' hide title text behind jpg to accommodate 16:9 aspect ratio slides
    dJPGWidth = pptShape.Width                      ' get new jpg width
    pptSlide.Shapes.Title.Width = dJPGWidth         ' size title box to same width and then center it
    pptSlide.Shapes.Title.Select
    pres.Application.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
'='='

End Sub
Private Sub MakeTitleSlide(pres As PowerPoint.Presentation)
'''Private Sub MakeTitleSlide(doc As Visio.Document, _
'''                           pres As PowerPoint.Presentation)
' creates title slide and adds Visio document name to title text box

    Dim pptSlide            As PowerPoint.Slide
    Dim pptShape            As PowerPoint.Shape
    Dim pptText             As PowerPoint.TextRange
    
    Dim sText1 As String, sText2 As String, sText3 As String, sText4 As String
    Dim iPos As Integer
    
    ' create slide
    Set pptSlide = pres.Slides.Add(Index:=1, Layout:=ppLayoutTitle)
    pptSlide.Select
    
    ' select title text box then set text and font
    Set pptText = pptSlide.Shapes.Title.TextFrame.TextRange
    pptText.Select
    With pres.Application.ActiveWindow.Selection.ShapeRange
        .IncrementTop -50
    End With
    With pptText
        ' show file name without file extension
        .Text = "TEST from Excel"
'''        .Text = Left(doc.Name, Len(doc.Name) - 4)
        .Font.Size = 36
        .Font.Bold = True
    End With
        
    ' select and resize subtitle text box
    pptSlide.Shapes(2).Select
    With pres.Application.ActiveWindow.Selection.ShapeRange
        .ScaleWidth 1.1, msoFalse, msoScaleFromBottomRight
        .ScaleWidth 1.1, msoFalse, msoScaleFromTopLeft
        .IncrementTop -25
    End With
    
    Set pptText = pptSlide.Shapes(2).TextFrame.TextRange
    
    ' set subtitle set text and font
    sText1 = "Author: Scott" & Chr(13) & Chr(13)
'''    sText1 = "Author: " & doc.Creator & Chr(13) & Chr(13)
    sText2 = "Slides created automatically from" & Chr(13)
    sText3 = "" & Chr(13)
'''    sText3 = doc.FullName & Chr(13)
    sText4 = "on " & Date & " at " & Format(Time, "Short time")
    pptText = sText1 & sText2 & sText3 & sText4
    ' format each text run within the subtitle text block
    With pptText
        With .Characters(Start:=0, Length:=Len(sText1))
            .Font.Size = 20
            .Font.Bold = True
        End With
        With .Characters(Start:=Len(sText1) + 1, Length:=Len(sText2))
            .Font.Size = 16
            .Font.Bold = True
        End With
       
        With .Characters(Start:=Len(sText1 & sText2) + 1, Length:=Len(sText3))
            .Font.Size = 16
            .Font.Bold = False
        End With
        With .Characters(Start:=Len(sText1 & sText2 & sText3) + 1, Length:=Len(sText4))
            .Font.Size = 16
            .Font.Bold = True
        End With
        ' isolate "on" that follows a carriage return and remove bold
        With .Find(Chr(13) & "on ")
            .Font.Bold = False
            iPos = .Start
        End With
        ' isolate "at" after "on" and remove bold
        With .Characters(Start:=iPos, Length:=Len(.Text)).Find("at")
            .Font.Bold = False
        End With
    End With
    
End Sub
Private Sub MakeSummarySlide(pres As PowerPoint.Presentation)
' adds a blank summary slide

    Dim pptSlide As PowerPoint.Slide
    
    Set pptSlide = _
        pres.Slides.Add(Index:=(pres.Slides.Count + 1), Layout:=ppLayoutText)
    pptSlide.Shapes.Title.TextFrame.TextRange = "Summary"
    ' add entry to slide array for Summary slide
    giSlideCount = giSlideCount + 1
    gaSlideInfo(giSlideCount, 1) = pptSlide.SlideID
    gaSlideInfo(giSlideCount, 2) = "Summary"
    
End Sub
Private Sub MakeTableOfContents(pres As PowerPoint.Presentation)
' creates one or more slides for Table of Contents

    Dim pptSlide            As PowerPoint.Slide
    Dim pptShape            As PowerPoint.Shape
    Dim pptText             As PowerPoint.TextRange

    Dim iTOCSlideIdx As Integer ', iTOCSlideCount As Integer
    Dim i As Integer, s As Integer
    
    iTOCSlideIdx = 1                    ' set to 1 to count title slide
    
    For i = 1 To giSlideCount
        ' if this will be the first line on new slide, create the new slide
        If (i Mod giLinesPerTOCSlide) = 1 Then
            ' create new slide
            iTOCSlideIdx = iTOCSlideIdx + 1
            Set pptSlide = pres.Slides.Add(Index:=iTOCSlideIdx, Layout:=ppLayoutText)
            pptSlide.Select
            
            ' Add "TOC" to title text box
            pptSlide.Shapes.Title.TextFrame.TextRange = "Table of Contents"
            ' set reference to main text box
            Set pptText = pptSlide.Shapes(2).TextFrame.TextRange
            ' PPT can't set font in empty text box from code (you can do it in the
            ' UI), so add dummy text, set font, then remove text
            pptText = "temp text"
            pptText.Font.Size = 24
            pptText = ""
        End If
        
        ' add Visio page name text and hyperlinks
        With pptSlide.Shapes(2).TextFrame.TextRange
            ' add CR before new text, except for first line
            If (i Mod giLinesPerTOCSlide) <> 1 Then
                .Characters(Len(.Text) + 1) = Chr(13)
            End If
            .Characters(Len(.Text) + 1) = gaSlideInfo(i, 2)
        End With
        With pptSlide.Shapes(2).TextFrame.TextRange
            s = i Mod giLinesPerTOCSlide
            If s = 0 Then s = giLinesPerTOCSlide    ' last entry on page
            With .Sentences(s).ActionSettings(ppMouseClick).Hyperlink
                .Address = ""
                ' subaddress has three parts: SlideID, Slide index, slide title
                ' PPT2003 can make do with almost any combination; PPT2007/2010 must have all
                ' three, however, the slide index can be a dummy number as below
                .SubAddress = gaSlideInfo(i, 1) & ",999," & fsSafeHLSubAddress(gaSlideInfo(i, 2))
                .ScreenTip = ""
            End With
            
            ' pass ID of slide that needs button and ID of current TOC slide
            Call AddReturnButton(pres.Slides.FindBySlideID(gaSlideInfo(i, 1)), _
                                 pptSlide.SlideID)
        End With
    Next i
        
End Sub
Private Sub AddReturnButton(pptSlide As PowerPoint.Slide, iSlideID As Integer)
' add action button in lower right corner of slide that returns to TOC when clicked

    Dim pptShape As PowerPoint.Shape

    Set pptShape = _
        pptSlide.Shapes.AddShape(msoShapeActionButtonCustom, 680#, 520#, 36#, 18#)
    pptShape.TextFrame.TextRange = "TOC"
    pptShape.TextFrame.AutoSize = ppAutoSizeShapeToFitText
    pptShape.TextFrame.TextRange.Font.Size = 12
 
    
    With pptShape.ActionSettings(ppMouseClick)
        With .Hyperlink
            .Address = ""
            ' subaddress has three parts: SlideID, Slide index, slide title
            ' PPT2003 can make do with almost any combination; PPT2007/2010 must have all
            ' three, however, the slide index can be a dummy number as below
            .SubAddress = iSlideID & ",999,Table of Contents"
        End With
        .SoundEffect.Type = ppSoundNone
        .AnimateAction = msoTrue
    End With
    
End Sub
Function fsSafeHLSubAddress(ByVal sText) As String
' a left parenthesis preceded by a space causes page-to-page hyperlinks to fail
' in PowerPoint; replace parentheses with square brackets
'
' commas also cause links to fail, so replace them with CHR(130), which looks just
' like a comma in most fonts (even if it doesn't, the user will likely never see it)

    fsSafeHLSubAddress = Replace(sText, "(", "[")
    fsSafeHLSubAddress = Replace(fsSafeHLSubAddress, ")", "]")
    
    fsSafeHLSubAddress = Replace(fsSafeHLSubAddress, ",", Chr(130))
        
End Function

Select allOpen in new window

' Adapted from code in the Visio 2007 SDK Code Samples
' by Scott Helmers, Visio MVP, scott@VisioStepByStep.com
'
'='=' 2017-01-18
' PowerPoint 2016 crashed repeatedly using the same code that has been running successfully in
' all previous versions of the Office suite. Jamie Garroch at Experts Exchange made several
' suggestions including the one that appears to have solved the problem: I removed all use of
' the .Select method and added code to manually position objects instead of using selection
' alignment methods.
'='='

Option Explicit

' global variables and constants
Dim gaSlideInfo()                           ' array for slide names and numbers
Dim giSlideCount As Integer                 ' total number of slides

Const giLinesPerTOCSlide As Integer = 10    ' max lines per Table of Contents slide

Sub CreatePowerPointFromVisio()
' creates a PowerPoint presentation from a Visio file
' -- title slide: contains the Visio filename and author; also contains PPT creation date
' -- Table of Contents slide (one or more): contains slide names with hyperlinks
' -- slides containing an image from each Visio page
' -- summary slide: blank text box

    Dim vsoDoc              As Visio.Document
    Dim pptApp              As powerpoint.Application
    Dim pptPres             As powerpoint.Presentation
    
    Dim i As Integer
    
    ' process the active document
    Set vsoDoc = ActiveDocument
    ' resize global array based on page count in Visio document plus 1
    ' for the summary slide
    ReDim gaSlideInfo(vsoDoc.Pages.Count + 1, 2)
    
    ' create a new PowerPoint instance
    Set pptApp = New powerpoint.Application
    pptApp.Visible = True
    'pptApp.WindowState = ppWindowMinimized
    
    ' create a new presentation
    Set pptPres = pptApp.Presentations.Add(withwindow:=True)
    
    ' loop through pages in Visio document (but don't include background pages);
    giSlideCount = 0
    For i = 1 To vsoDoc.Pages.Count
        If vsoDoc.Pages(i).Background = False Then
            Call MakeSlideFromVisioPage(vsoDoc, i, pptPres)
        End If
    Next i
    
    ' create title slide
    Call MakeTitleSlide(vsoDoc, pptPres)
    
    ' create summary slide
    Call MakeSummarySlide(pptPres)
    
    ' create table of contents slide(s)
    Call MakeTableOfContents(pptPres)
    
    ' maximize PPT window, return to title slide, then run slide show
    pptApp.WindowState = ppWindowMaximized
'='=' 2017-01-18 per Jamie Garroch at Experts Exchange
    pptApp.ActiveWindow.View.GotoSlide (1)
    ''''pptPres.Slides(1).Select
'='='
    With pptPres.SlideShowSettings
        .LoopUntilStopped = False
        .ShowWithNarration = msoTrue
        .ShowWithAnimation = msoTrue
        .RangeType = ppShowAll
        .PointerColor.RGB = RGB(Red:=255, Green:=0, Blue:=0)
        .Run
    End With
    
End Sub
Private Sub MakeSlideFromVisioPage(doc As Visio.Document, _
                                   iPageNbr As Integer, _
                                   pres As powerpoint.Presentation)
' creates jpg from Visio page, creates new PPT slide, then adds jpg to slide

    Dim sJPGFilename As String
    Dim pg As Visio.Page
    Dim shp1 As Visio.Shape, shp2 As Visio.Shape
    Dim dPgHeight As Double, dPgWidth As Double
    
    Dim pptSlide As powerpoint.Slide
    Dim pptShape As powerpoint.Shape
    
    Dim dJPGWidth As Double, dJPGHeight As Double
    Dim dSlideWidth As Double, dSlideHeight As Double
    Dim dW As Double, dH As Double, dRatio As Double

    ' set path and filename for temporary jpg images (put jpg in user's temp folder)
    sJPGFilename = Environ$("TEMP")
    If Right(sJPGFilename, 1) <> "\" Then sJPGFilename = sJPGFilename & "\"
    sJPGFilename = sJPGFilename & Left(doc.Name, (Len(doc.Name) - 4)) & ".jpg"
    
    ' export drawing page to jpg file with same name as Visio doc (the file
    ' is overwritten for each page)
    Set pg = doc.Pages(iPageNbr)
    
    ' NOTE: when Visio creates jpg images, it only creates them using the shapes on
    ' the page, i.e., it ignores all blank space outside the rectangle containing the
    ' shapes. Consequently, to create a jpg that contains the entire page, it is
    ' necessary to ensure that there are shapes at the very edges of each page.
    ' To do this we add a very small rectangle in the upper left and lower right
    ' corners of the page. then delete them after the export
    dPgHeight = pg.PageSheet.Cells("PageHeight").Result(visInches)
    dPgWidth = pg.PageSheet.Cells("PageWidth").Result(visInches)
    Set shp1 = pg.DrawRectangle(-0.01, dPgHeight + 0.01, -0.011, dPgHeight + 0.011)
    Set shp2 = pg.DrawRectangle(dPgWidth + 0.01, -0.01, dPgWidth + 0.011, -0.011)
    pg.Export sJPGFilename
'='=' 2016-08-09
'='=' Visio 2016 sometimes crashes when code delete a shape if any shapes are selected; deselect all before deleting
    doc.Application.Window.DeselectAll
'='='
    shp1.Delete
    shp2.Delete
    
    ' add a slide into the Slides collection of the presentation.
    Set pptSlide = pres.Slides.Add(Index:=iPageNbr, Layout:=ppLayoutTitleOnly)
    ' store SlideID generated by PPT and Visio page name
    giSlideCount = giSlideCount + 1
    gaSlideInfo(giSlideCount, 1) = pptSlide.SlideID
    gaSlideInfo(giSlideCount, 2) = doc.Pages(iPageNbr).Name
    
    ' Add Visio page name to title text box for this slide
'='=' 2017-01-18 per Jamie Garroch at Experts Exchange
    ''''pptSlide.Select
'='='
    pptSlide.Shapes.Title.TextFrame.TextRange = fsSafeHLSubAddress(doc.Pages(iPageNbr).Name)
    ' get slide dimensions
    With pres.PageSetup
        dSlideWidth = .SlideWidth
        dSlideHeight = .SlideHeight
    End With
    
    ' add the jpg into the newly created slide
    Set pptShape = pptSlide.Shapes.AddPicture _
                        (FileName:=sJPGFilename, _
                         LinkToFile:=False, SaveWithDocument:=True, _
                         Left:=0, Top:=0)
    ' get jpg dimensions so we can resize image to fit on slide
    With pptShape
        dJPGWidth = .Width
        dJPGHeight = .Height
    End With
    ' calculate width and height ratios
    If dJPGWidth > dSlideWidth Then dW = (dSlideWidth / dJPGWidth) Else dW = 1
    If dJPGHeight > dSlideHeight Then dH = (dSlideHeight / dJPGHeight) Else dH = 1
    ' use minimum ratio to resize the image so it will fit on the slide
    If dW < dH Then dRatio = dW Else dRatio = dH
    ' center image on slide
'='=' 2017-01-18 per Jamie Garroch at Experts Exchange
    With pptShape
        .ScaleWidth dRatio, msoFalse, msoScaleFromMiddle
        .ScaleHeight dRatio, msoFalse, msoScaleFromMiddle
        .Top = 0 - 0.5 * (dSlideHeight - dJPGHeight)
        .Left = 0.5 * (dSlideWidth - dJPGWidth)
    End With
    ''''pptShape.Select
    ''''With pres.Application.ActiveWindow.Selection.ShapeRange
    ''''    .Align msoAlignCenters, True
    ''''    .Align msoAlignMiddles, True
    ''''    .ScaleWidth dRatio, msoFalse, msoScaleFromMiddle
    ''''    .ScaleHeight dRatio, msoFalse, msoScaleFromMiddle
    ''''End With
'='='

'='=' 2016-07-27
'='=' hide title text behind jpg to accommodate 16:9 aspect ratio slides
    dJPGWidth = pptShape.Width                      ' get new jpg width
'='=' 2017-01-18 per Jamie Garroch at Experts Exchange
    With pptSlide.Shapes.Title
        .Width = dJPGWidth
        .Left = 0.5 * (dSlideWidth - .Width)
    End With
    ''''pptSlide.Shapes.Title.Width = dJPGWidth         ' size title box to same width and then center it
    ''''pptSlide.Shapes.Title.Select
    ''''pres.Application.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
'='='
'='='

End Sub
Private Sub MakeTitleSlide(doc As Visio.Document, _
                           pres As powerpoint.Presentation)
' creates title slide and adds Visio document name to title text box

    Dim pptSlide            As powerpoint.Slide
    Dim pptShape            As powerpoint.Shape
    Dim pptText             As powerpoint.TextRange
    
    Dim sText1 As String, sText2 As String, sText3 As String, sText4 As String
    Dim iPos As Integer
    
    ' create slide
    Set pptSlide = pres.Slides.Add(Index:=1, Layout:=ppLayoutTitle)

'='=' 2017-01-18 per Jamie Garroch at Experts Exchange
    ' select title text box then set text and font
    Set pptShape = pptSlide.Shapes.Title
    With pptShape
        .Top = .Top - 50
        With .TextFrame.TextRange
            .Text = fsExtractFilename(doc.Name)             ' show file name without file extension
            .Font.Size = 36
            .Font.Bold = True
        End With
    End With
        
    ' select and resize subtitle text box
    Set pptShape = pptSlide.Shapes(2)
    With pptShape
        .ScaleWidth 1.1, msoFalse, msoScaleFromBottomRight
        .ScaleWidth 1.1, msoFalse, msoScaleFromTopLeft
        .Top = .Top - 25
    End With
    Set pptText = pptShape.TextFrame.TextRange
    ''''' create slide
    ''''Set pptSlide = pres.Slides.Add(Index:=1, Layout:=ppLayoutTitle)
    ''''pptSlide.Select
    ''''' select title text box then set text and font
    ''''Set pptText = pptSlide.Shapes.Title.TextFrame.TextRange
    ''''pptText.Select
    ''''With pres.Application.ActiveWindow.Selection.ShapeRange
    ''''    .IncrementTop -50
    ''''End With
    ''''With pptText
    ''''    ' show file name without file extension
    ''''    .Text = Left(doc.Name, Len(doc.Name) - 4)
    ''''    .Font.Size = 36
    ''''    .Font.Bold = True
    ''''End With
    ''''' select and resize subtitle text box
    ''''pptSlide.Shapes(2).Select
    ''''With pres.Application.ActiveWindow.Selection.ShapeRange
    ''''    .ScaleWidth 1.1, msoFalse, msoScaleFromBottomRight
    ''''    .ScaleWidth 1.1, msoFalse, msoScaleFromTopLeft
    ''''    .IncrementTop -25
    ''''End With
    ''''Set pptText = pptSlide.Shapes(2).TextFrame.TextRange
'='='

    ' set subtitle set text and font
    sText1 = "Author: " & doc.Creator & Chr(13) & Chr(13)
    sText2 = "Slides created automatically from" & Chr(13)
    sText3 = doc.FullName & Chr(13)
    sText4 = "on " & Date & " at " & Format(Time, "Short time")
    pptText = sText1 & sText2 & sText3 & sText4
    ' format each text run within the subtitle text block
    With pptText
        With .Characters(Start:=0, Length:=Len(sText1))
            .Font.Size = 20
            .Font.Bold = True
        End With
        With .Characters(Start:=Len(sText1) + 1, Length:=Len(sText2))
            .Font.Size = 16
            .Font.Bold = True
        End With
       
        With .Characters(Start:=Len(sText1 & sText2) + 1, Length:=Len(sText3))
            .Font.Size = 16
            .Font.Bold = False
        End With
        With .Characters(Start:=Len(sText1 & sText2 & sText3) + 1, Length:=Len(sText4))
            .Font.Size = 16
            .Font.Bold = True
        End With
        ' isolate "on" that follows a carriage return and remove bold
        With .Find(Chr(13) & "on ")
            .Font.Bold = False
            iPos = .Start
        End With
        ' isolate "at" after "on" and remove bold
        With .Characters(Start:=iPos, Length:=Len(.Text)).Find("at")
            .Font.Bold = False
        End With
    End With
    
End Sub
Private Sub MakeSummarySlide(pres As powerpoint.Presentation)
' adds a blank summary slide

    Dim pptSlide As powerpoint.Slide
    
    Set pptSlide = pres.Slides.Add(Index:=(pres.Slides.Count + 1), Layout:=ppLayoutText)
    pptSlide.Shapes.Title.TextFrame.TextRange = "Summary"
    ' add entry to slide array for Summary slide
    giSlideCount = giSlideCount + 1
    gaSlideInfo(giSlideCount, 1) = pptSlide.SlideID
    gaSlideInfo(giSlideCount, 2) = "Summary"
    
End Sub
Private Sub MakeTableOfContents(pres As powerpoint.Presentation)
' creates one or more slides for Table of Contents

    Dim pptSlide            As powerpoint.Slide
    Dim pptShape            As powerpoint.Shape
    Dim pptText             As powerpoint.TextRange

    Dim iTOCSlideIdx As Integer ', iTOCSlideCount As Integer
    Dim i As Integer, s As Integer
    
    iTOCSlideIdx = 1                    ' set to 1 to count title slide
    
    For i = 1 To giSlideCount
        ' if this will be the first line on new slide, create the new slide
        If (i Mod giLinesPerTOCSlide) = 1 Then
            ' create new slide
            iTOCSlideIdx = iTOCSlideIdx + 1
            Set pptSlide = pres.Slides.Add(Index:=iTOCSlideIdx, Layout:=ppLayoutText)

'='=' 2017-01-18 per Jamie Garroch at Experts Exchange
            With pptSlide
                .Shapes.Title.TextFrame.TextRange = "Table of Contents"     ' Add "TOC" to title text box
                Set pptText = .Shapes(2).TextFrame.TextRange                ' set reference to main text box
                ' PPT can't set font size in empty text box from code (you can do it in the
                ' UI), so add dummy text, set font, then remove text
                pptText = "temp text"
                pptText.Font.Size = 24
                pptText = ""
            End With
            ''''pptSlide.Select
            ''''
            ''''' Add "TOC" to title text box
            ''''pptSlide.Shapes.Title.TextFrame.TextRange = "Table of Contents"
            ''''' set reference to main text box
            ''''Set pptText = pptSlide.Shapes(2).TextFrame.TextRange
            ''''' PPT can't set font in empty text box from code (you can do it in the
            ''''' UI), so add dummy text, set font, then remove text
            ''''pptText = "temp text"
            ''''pptText.Font.Size = 24
            ''''pptText = ""
'='='
        End If
        
        ' add Visio page name text and hyperlinks
        With pptSlide.Shapes(2).TextFrame.TextRange
            ' add CR before new text, except for first line
            If (i Mod giLinesPerTOCSlide) <> 1 Then
                .Characters(Len(.Text) + 1) = Chr(13)
            End If
            .Characters(Len(.Text) + 1) = gaSlideInfo(i, 2)
        End With
        With pptSlide.Shapes(2).TextFrame.TextRange
            s = i Mod giLinesPerTOCSlide
            If s = 0 Then s = giLinesPerTOCSlide    ' last entry on page
            With .Sentences(s).ActionSettings(ppMouseClick).Hyperlink
                .Address = ""
                ' subaddress has three parts: SlideID, Slide index, slide title
                ' PPT2003 can make do with almost any combination; PPT2007/2010 must have all
                ' three, however, the slide index can be a dummy number as below
                .SubAddress = gaSlideInfo(i, 1) & ",999," & fsSafeHLSubAddress(gaSlideInfo(i, 2))
                .ScreenTip = ""
            End With
            
            ' pass ID of slide that needs button and ID of current TOC slide
'='=' 2017-01-19 locate TOC button in lower right corner regardless of slide width
            Call AddReturnButton(pres.Slides.FindBySlideID(gaSlideInfo(i, 1)), pptSlide.SlideID, _
                                 pres.PageSetup.SlideWidth, pres.PageSetup.SlideHeight)
            ''''Call AddReturnButton(pres.Slides.FindBySlideID(gaSlideInfo(i, 1)), _
            ''''                     pptSlide.SlideID)
'='='
        End With
    Next i
        
End Sub
'='=' 2017-01-19 locate TOC button in lower right corner regardless of slide width
Private Sub AddReturnButton(pptSlide As powerpoint.Slide, iSlideID As Integer, _
                            SlideWidth As Single, SlideHeight As Single)
''''Private Sub AddReturnButton(pptSlide As powerpoint.Slide, iSlideID As Integer)
' add action button in lower right corner of slide that returns to TOC when clicked

    Dim pptShape    As powerpoint.Shape

'='=' 2017-01-19 locate TOC button in lower right corner regardless of slide width
    Set pptShape = _
        pptSlide.Shapes.AddShape(msoShapeActionButtonCustom, SlideWidth - 40, SlideHeight - 24, 36, 18)
    ''''Set pptShape = _
    ''''    pptSlide.Shapes.AddShape(msoShapeActionButtonCustom, 680#, 520#, 36#, 18#)
'='='
    pptShape.TextFrame.TextRange = "TOC"
    pptShape.TextFrame.AutoSize = ppAutoSizeShapeToFitText
    pptShape.TextFrame.TextRange.Font.Size = 12
 
    
    With pptShape.ActionSettings(ppMouseClick)
        With .Hyperlink
            .Address = ""
            ' subaddress has three parts: SlideID, Slide index, slide title
            ' PPT2003 can make do with almost any combination; PPT2007/2010 must have all
            ' three, however, the slide index can be a dummy number as below
            .SubAddress = iSlideID & ",999,Table of Contents"
        End With
        .SoundEffect.Type = ppSoundNone
        .AnimateAction = msoTrue
    End With
    
End Sub
Function fsSafeHLSubAddress(ByVal sText) As String
' a left parenthesis preceded by a space causes page-to-page hyperlinks to fail
' in PowerPoint; replace parentheses with square brackets
'
' commas also cause links to fail, so replace them with CHR(130), which looks just
' like a comma in most fonts (even if it doesn't, the user will likely never see it)

    fsSafeHLSubAddress = Replace(sText, "(", "[")
    fsSafeHLSubAddress = Replace(fsSafeHLSubAddress, ")", "]")
    
    fsSafeHLSubAddress = Replace(fsSafeHLSubAddress, ",", Chr(130))
        
End Function
Function fsExtractFilename(sName As String) As String
' extract filename independent of file extension length

    Dim iPos            As Integer
    
    iPos = InStrRev(sName, ".")
    If iPos = 0 Then
        fsExtractFilename = sName
    Else
        fsExtractFilename = Left(sName, iPos - 1)
    End If

End Function

Select allOpen in new window