VBA Code Issues

Question

Good day Folks:

Having issues w/ the following VBA code which copies slide content from one presentation to another. Code breaks at bolded line. Seems Powerpoint fails to activate slide before line is executed. Perhaps there is a better method? THANKS for any assist !!

  Declare Function WNetGetUser Lib "mpr.dll" _

      Alias "WNetGetUserA" (ByVal lpName As String, _

      ByVal lpUserName As String, lpnLength As Long) As Long

   Const NoError = 0

   Function GetUserName()

      Const lpnLength As Integer = 255

      Dim status As Integer

      Dim lpName, lpUserName As String

      lpUserName = Space$(lpnLength + 1)

      status = WNetGetUser(lpName, lpUserName, lpnLength)

      If status = NoError Then

         GetUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)

      Else

         MsgBox "Unable to get the name."

    End

      End If

   End Function

Sub CopyContent()

Dim SourcePres As Object

Dim TargetPres As Object

Dim directory As String

For n = 1 To 2

    If n = 1 Then

        MsgBox "Select source presentation"

        directory = "C:"

    End If

    If n = 2 Then

        MsgBox "Select target template"

        directory = "C:\Users" & GetUserName() & "\AppData\Roaming\Microsoft\Templates"

    End If

    Dim fd As FileDialog

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    Dim vrtSelectedItem As Variant

    fd.InitialFileName = directory

    If fd.Show = -1 Then

        For Each vrtSelectedItem In fd.SelectedItems

            Presentations.Open FileName:=vrtSelectedItem

        Next vrtSelectedItem

    Else

    End If

    If n = 1 Then Set SourcePres = Application.ActivePresentation

    If n = 2 Then Set TargetPres = Application.ActivePresentation

    Set fd = Nothing

Next n

    lstSlide = SourcePres.Slides.Count

    For x = 2 To lstSlide

        SourcePres.Windows(1).Activate

        SourcePres.Slides(x).Select

        SourcePres.Slides(x).Shapes.SelectAll

        ActiveWindow.Selection.Copy

        PgNote = SourcePres.Slides(x).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text

        TargetPres.Windows(1).Activate

        n = ActiveWindow.Selection.SlideRange.SlideIndex + 1

        Set Layout = ActivePresentation.SlideMaster.CustomLayouts(8) ' change number

        TargetPres.Slides.AddSlide n, Layout

        Do While ActiveWindow.Selection.SlideRange.SlideIndex <> n

            TargetPres.Slides(n).Select

            DoEvents

        Loop

        'MsgBox ActiveWindow.Selection.SlideRange.SlideIndex

        TargetPres.Slides(n).Select

        TargetPres.Slides(n).Shapes.SelectAll -

        ActiveWindow.Selection.Delete

        TargetPres.Slides(n).Shapes.Paste

        ActivePresentation.Slides(n).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text = PgNote

        Title

    Next x

End Sub

Answer 1

i would replace the 2nd loop with this:

     Dim TargetSlide As Slide

     For x = 2 To lstSlide

         Set Layout = TargetPres.SlideMaster.CustomLayouts(8) ' change number

         Set TargetSlide = TargetPres.Slides.AddSlide(TargetPres.Slides.Count + 1, Layout)

         If TargetSlide.Shapes.Count > 0 Then

            TargetSlide.Shapes.Range.Delete

         End If

         If SourcePres.Slides(x).Shapes.Count > 0 Then

             SourcePres.Slides(x).Shapes.Range.Copy

             TargetSlide.Shapes.Paste

        End If

        PgNote = SourcePres.Slides(x).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text

TargetSlide.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text = PgNote

     Next x

This does not use selection to copy shapes from source to target. Also the notes copy code could fail if those shapes don't exist.

Answer 2

THANK YOU .. worked so much better ..