Create PPT in VBA

Dim sheetcount As Long, rowcount As Long, datarng As Range, i As Integer
Dim chrt As Excel.ChartObject, tempwb As Workbook, temprng As Range, mainrng As Range
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation, fullPath As String
Dim pptsld As PowerPoint.Slide, filename As String
Dim fso As FileSystemObject, fldr As Folder, fl As File
Dim ppLayoutBlank As CustomLayout
Dim oPic As Shape, objSlideShow As Object, temprowcount As Long
Sub copyrange2image()
Application.ScreenUpdating = False
'On Error Resume Next
sheetcount = ThisWorkbook.Sheets.Count
Set fso = New FileSystemObject
Set fldr = fso.GetFolder(ThisWorkbook.Path & "\")
rowcount = ThisWorkbook.Sheets(sheetcount).Range("A6").End(xlDown).Row
ThisWorkbook.Sheets(sheetcount).Range("A6:J" & rowcount).Sort key1:=ThisWorkbook.Sheets(sheetcount).Range("H6"), order1:=xlAscending, Header:=xlYes
i = 6
l = 0
'Delete Existing image
    For Each fl In fldr.Files
        If InStr(fl.Name, "png") > 0 Then
            Kill ThisWorkbook.Path & "\" & fl.Name
        'ElseIf InStr(fl.Name, ".pptx") > 0 Then
          '  Kill ThisWorkbook.Path & "\" & fl.Name
        End If
    Next
   Do
    Set datarng = Nothing
    Set headerrng = Nothing
       If ((i + 11) < rowcount) Then
       l = l + 1
            
             Set rng1 = ThisWorkbook.Sheets(sheetcount).Range("H" & (i + 1) & ":H" & (i + 11))
            
             Set rng2 = ThisWorkbook.Sheets(sheetcount).Range("A" & (i + 1) & ":A" & (i + 11))
             Set rng3 = ThisWorkbook.Sheets(sheetcount).Range("E" & (i + 1) & ":E" & (i + 11))
            
             Set rng5 = ThisWorkbook.Sheets(sheetcount).Range("G" & (i + 1) & ":G" & (i + 11))
             Set rng6 = ThisWorkbook.Sheets(sheetcount).Range("C" & (i + 1) & ":C" & (i + 11))
            
             Set tempwb = Nothing
             Set tempwb = Workbooks.Add
             Set temprng = Nothing
             temprowcount = 0
             'Stunt Name
             ThisWorkbook.Sheets(sheetcount).Range("H6").Copy tempwb.Sheets(1).Range("A1")
             rng1.Copy tempwb.Sheets(1).Range("A2")
             ' Lab no
             ThisWorkbook.Sheets(sheetcount).Range("A6").Copy tempwb.Sheets(1).Range("B1")
             rng2.Copy tempwb.Sheets(1).Range("B2")
             'Start Date
             ThisWorkbook.Sheets(sheetcount).Range("E6").Copy tempwb.Sheets(1).Range("C1")
             rng3.Copy tempwb.Sheets(1).Range("C2")
            
             'Course Name
             ThisWorkbook.Sheets(sheetcount).Range("G6").Copy tempwb.Sheets(1).Range("D1")
             rng5.Copy tempwb.Sheets(1).Range("D2")
             'Trainer Name
             ThisWorkbook.Sheets(sheetcount).Range("C6").Copy tempwb.Sheets(1).Range("E1")
             temprowcount = tempwb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
             rng6.Copy tempwb.Sheets(1).Range("E2")
             tempwb.Sheets(1).Columns(1).ColumnWidth = 108
             tempwb.Sheets(1).Columns(2).ColumnWidth = 12
             tempwb.Sheets(1).Columns(3).ColumnWidth = 15
             tempwb.Sheets(1).Columns(4).ColumnWidth = 90
             tempwb.Sheets(1).Columns(5).ColumnWidth = 15
             Set temprng = tempwb.Sheets(1).Range("A1:E" & temprowcount)
            
             'Application.Wait (Now + TimeValue("0:00:02"))
             temprng.CopyPicture xlScreen, xlPicture
             Set chrt = tempwb.Sheets(1).ChartObjects.Add(0, 0, temprng.Width - 10, temprng.Height - 10)
             chrt.Activate
             chrt.Chart.Paste
             chrt.Chart.Export ThisWorkbook.Path & "\mydata" & l & ".png"
             chrt.Delete
             Application.DisplayAlerts = False
            tempwb.Close
            Set chrt = Nothing
       ElseIf ((i + 11) > rowcount) Then
       l = l + 1
             Set rng1 = ThisWorkbook.Sheets(sheetcount).Range("H" & (i + 1) & ":H" & (i + 11))
            
             Set rng2 = ThisWorkbook.Sheets(sheetcount).Range("A" & (i + 1) & ":A" & (i + 11))
             Set rng3 = ThisWorkbook.Sheets(sheetcount).Range("E" & (i + 1) & ":E" & (i + 11))
            
             Set rng5 = ThisWorkbook.Sheets(sheetcount).Range("G" & (i + 1) & ":G" & (i + 11))
             Set rng6 = ThisWorkbook.Sheets(sheetcount).Range("C" & (i + 1) & ":C" & (i + 11))
            
            
             Set tempwb = Workbooks.Add
             'Stunt Name
             ThisWorkbook.Sheets(sheetcount).Range("H6").Copy tempwb.Sheets(1).Range("A1")
             rng1.Copy tempwb.Sheets(1).Range("A2")
             ' Lab no
             ThisWorkbook.Sheets(sheetcount).Range("A6").Copy tempwb.Sheets(1).Range("B1")
             rng2.Copy tempwb.Sheets(1).Range("B2")
             'Start Date
             ThisWorkbook.Sheets(sheetcount).Range("E6").Copy tempwb.Sheets(1).Range("C1")
             rng3.Copy tempwb.Sheets(1).Range("C2")
            
             'Course Name
             ThisWorkbook.Sheets(sheetcount).Range("G6").Copy tempwb.Sheets(1).Range("D1")
             rng5.Copy tempwb.Sheets(1).Range("D2")
             'Trainer Name
             ThisWorkbook.Sheets(sheetcount).Range("C6").Copy tempwb.Sheets(1).Range("E1")
             temprowcount = tempwb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
             rng6.Copy tempwb.Sheets(1).Range("E2")
             tempwb.Sheets(1).Columns(1).ColumnWidth = 108
             tempwb.Sheets(1).Columns(2).ColumnWidth = 12
             tempwb.Sheets(1).Columns(3).ColumnWidth = 15
             tempwb.Sheets(1).Columns(4).ColumnWidth = 90
             tempwb.Sheets(1).Columns(5).ColumnWidth = 15
             Set temprng = tempwb.Sheets(1).Range("A1:E" & temprowcount)
             'Application.Wait (Now + TimeValue("0:00:02"))
             temprng.CopyPicture xlScreen, xlPicture
             Set chrt = tempwb.Sheets(1).ChartObjects.Add(0, 0, temprng.Width - 10, temprng.Height - 10)
             chrt.Activate
             chrt.Chart.Paste
             chrt.Chart.Export ThisWorkbook.Path & "\mydata" & l & ".png"
             chrt.Delete
            Application.DisplayAlerts = False
            tempwb.Close
            Set chrt = Nothing
       End If
        i = i + 11
       
       
        Loop Until i >= rowcount
    'Counting total images
   
   
   
    'Adding slide & pic to Presentation
        Set pptApp = CreateObject("Powerpoint.Application")
            pptApp.Visible = True
            pptApp.Activate
        Set pptPres = pptApp.Presentations.Add
        k = 0
       
     For Each fl In fldr.Files
        If InStr(fl.Name, "png") > 0 Then
            k = k + 1
            Set pptsld = pptPres.Slides.Add(pptPres.Slides.Count + 1, Layout:=ppLayoutCustom)
            fullPath = ThisWorkbook.Path & "\" & "mydata" & k & ".png"
            pptsld.FollowMasterBackground = msoFalse
            pptsld.Background.Fill.UserPicture ThisWorkbook.Path & "\Picture1.jpg"
            pptsld.Shapes.AddPicture filename:=fullPath, linktofile:=msoTrue, savewithdocument:=msoTrue, Left:=0, Top:=110, Width:=961, Height:=240
            pptsld.SlideShowTransition.EntryEffect = ppEffectBlindsHorizontal
            pptsld.SlideShowTransition.AdvanceOnTime = True
            pptsld.SlideShowTransition.AdvanceTime = 10
   
  
        End If
           
    Next
    For m = 1 To pptPres.Slides.Count
   
    pptPres.Slides(m).HeadersFooters.SlideNumber.Visible = True
    Next
    pptPres.SaveAs ThisWorkbook.Path & "\BatchSchedulePresentation.pptx"
    pptPres.SlideShowSettings.StartingSlide = 1
    pptPres.SlideShowSettings.EndingSlide = pptPres.Slides.Count
    pptPres.SlideShowSettings.LoopUntilStopped = msoTrue
    pptPres.Save
    'pptPres.SlideShowSettings.Run
    pptPres.Close
    pptApp.Quit
  
   
   
    Set pptsld = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
    Call slideShow
End Sub
Public Sub slideShow()
On Error Resume Next


Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Set objPresentation = objPPT.Presentations.Open(ThisWorkbook.Path & "\BatchSchedulePresentation.pptx")
For Each pptsld In objPresentation.Slides
       pptsld.SlideShowTransition.EntryEffect = ppEffectPush
       pptsld.SlideShowTransition.AdvanceOnTime = True
       pptsld.SlideShowTransition.AdvanceTime = 4
Next
objPPT.ActiveWindow.View.GotoSlide 1
 With objPresentation.SlideShowSettings
        .StartingSlide = 1
        .EndingSlide = objPresentation.Slides.Count
        .AdvanceMode = ppSlideShowUseSlideTimings
 
        .LoopUntilStopped = msoTrue
        .Run

        End With

objPresentation.Saved = True


End Sub

DownloadFile



backgroundimage