ppLayoutBlank to ppLayoutTitleOnly

[Mr.Karr]

Hi

When I set pptSlide = ppLayoutTitleOnly, the shape is pasted inside of title box.

Can you please look into this & modify the code a bit to change the pptSlide to pplayoutTitleOnly and also modify the properties of the title to fit with the properties of the shape:

With pptSlide.Shapes(1)
    'pptApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
    .Top = 60
    .Left = 10
    .Height = 540
    .Width = 940
End With

Complete code:

Option Explicit

    'Both subs require a reference to Microsoft PowerPoint xx.x Object Library.
    'where xx.x is your office version (11.0 = 2003, 12.0 = 2007 and 14.0 = 2010).

    'Declaring the necessary Power Point variables, whick are used in both subs.
    Dim pptApp          As PowerPoint.Application
    Dim pptPres        As PowerPoint.Presentation
    Dim pptSlideCount  As Integer

Sub TablesToPowerPoint()

On Error Resume Next
    Dim cl As Range
         
    'Open Power Point and create a new presentation.
    Set pptApp = New PowerPoint.Application
    Set pptPres = pptApp.Presentations.Add
   
    'Show the Power Point application.
    pptApp.Visible = True

    'Loop through tables of ranges
    Application.ScreenUpdating = False
    For Each cl In Worksheets("Home").Range("rngPrintRanges")
        Call ExcelTableToPowerPoint(cl.Value, cl.Offset(0, 1).Value)
    Next cl
    Application.ScreenUpdating = True
   
    'Inform the user that the macro finished.
    MsgBox "The ranges were successfully copied to the new presentation!", vbInformation, "Done"
   
End Sub

Private Sub ExcelTableToPowerPoint(xlSheet As String, xlRange As String)
    Dim pptSlide        As PowerPoint.Slide
   
    'Check if the range is valid.
    With Worksheets(xlSheet)
        If Application.Intersect(.Range(xlRange), .Cells) Is Nothing Then
            MsgBox "Sorry, the range you selected is not valid!", vbCritical, "Invalid range"
            Exit Sub
        End If
       
        'Count the slides and add a new one after the last slide.
        pptSlideCount = pptPres.Slides.Count
        Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
       
        'Copy the range and paste as image
        .Range(xlRange).Copy
        pptSlide.Shapes.PasteSpecial (ppPasteMetafilePicture)
    End With
   
    With pptSlide.Shapes(1)
    'pptApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
    .Top = 60
    .Left = 10
    .Height = 540
    .Width = 940
End With

End Sub

Please feel free to let me know if you require a sample file.

 

[Mr.Karr]

sample file