Dear all,

Thanks for all the help in my previous posts. However, i do have another question.

How do i detect a specific active powerpoint?

Below are the codes. It will open more than 1 & same powerpoint file(with read only), because i can't detect an active ppt.

Please advice. 

Function export2ppt()

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim SlideCount As Long
Dim iCht As Integer

Dim OpenPPT As PowerPoint.Application
Set OpenPPT = New PowerPoint.Application

OpenPPT.Visible = True

'if the file exist, open the dashboard
If Dir(ThisWorkbook.Path + "\dashboard_" & Format(Date, "ddmmyy" & ".ppt")) <> "" Then

    OpenPPT.Presentations.Open filename:=ThisWorkbook.Path + "\dashboard_" & Format(Date, "ddmmyy" & ".ppt")
    
Else
    
    'if file not found, create a new file
    Set NewPwrPt = CreateObject("Powerpoint.Application")
    NewPwrPt.Visible = True
    Set PwrPtPres = NewPwrPt.Presentations.Add
    
    res = ThisWorkbook.Path & "\dashboard_" & Format(Date, "ddmmyy" & ".ppt")
    
    With PwrPtPres
        .SaveAs res
        '.Close
    End With
    
    'NewPwrPt.Quit
    'Set NewPwrPt = Nothing
End If




' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")


' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewNormal

For iCht = 1 To ActiveSheet.ChartObjects.Count
    ' copy chart as a picture
    ActiveSheet.ChartObjects(iCht).Chart.CopyPicture _
        Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture

    ' Add a new slide and paste in the chart
    SlideCount = PPPres.Slides.Count
    Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
    PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
    With PPSlide
        ' paste and select the chart picture
        .Shapes.Paste.Select
        ' align the chart
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    End With
Next
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing

End Function