What is causing my PowerPoint VBA macro to stop working when I add a 'For Each' loop to create a table in Word with slide info?
PowerPoint VBA Macro works for one slide, breaks when For Each loop added
I have a macro that runs in PPT that creates a table in Word with the slide number, a thumbnail image of the slide, and the slide notes in a one row table. I have it working for one slide, but when I added a For Each sdl in ActivePresentation.Slides it stopped working even for one slide.
I get a Compile error: Method or data member not found that points to sld.Copy (I've surrounded it in *** in the block that follows).
This version includes the loop:
Sub CreateScriptTableLoop()
Dim sld As Slides
Set sld = ActivePresentation.Slides
' Set up Word
Dim wdApp As Word.Application, wdDoc As Word.Document
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = New Word.Application
Set wdDoc = wdApp.ActiveDocument
' Start loop
Debug.Print "Start Loop"
For Each sld In ActivePresentation.Slides
' Set up Table
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:=3
Debug.Print "Table created"
' Get Slide Number and put in column 1
Dim oshp As Shape
With ActivePresentation.Slides(1).Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 100, 100, 40, 20)
oshp.TextFrame.TextRange.InsertSlideNumber
oshp.Name = "Slide Num"
End With
ActivePresentation.Slides(1).Shapes("Slide Num").TextFrame.TextRange.Copy
With ActiveDocument.Tables(1).Cell(Row:=1, Column:=1).Range
.Borders.OutsideLineStyle = wdLineStyleSingle
.PasteAndFormat wdFormatPlainText
End With
ActivePresentation.Slides(1).Shapes("Slide Num").Delete
Debug.Print "Slide number inserted"
' Get thumbnail and put in column 2
'*************************************************************
sld.Copy
'*************************************************************
Set mySlideCopy = ActivePresentation.Slides(1).Shapes.Paste
With mySlideCopy
.Name = "Slide Thumbnail"
.Left = 0
.Top = 0
.Height = 400
.Width = 400
End With
ActivePresentation.Slides(1).Shapes("Slide Thumbnail").Copy
Debug.Print "Thumbnail copied"
With ActiveDocument.Tables(1).Cell(Row:=1, Column:=2).Range
.Borders.OutsideLineStyle = wdLineStyleSingle
.PasteAndFormat wdPasteDefault
End With
ActivePresentation.Slides(1).Shapes("Slide Thumbnail").Delete
Debug.Print "Thumbnail pasted"
'Get notes and put in column 3
sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Copy
With ActiveDocument.Tables(1).Cell(Row:=1, Column:=3).Range
.Borders.OutsideLineStyle = wdLineStyleSingle
.PasteAndFormat wdFormatPlainText
End With
Debug.Print "Notes Pasted"
Next sld
Debug.Print "Done"
End Sub
Any pointers greatly appreciated!
UPDATE: The problem above is that it treats Slides as a single slide when in fact it's an array of all slides. To fix it, I created:
Dim sld As Slide
Dim sldS As Slides
Set sldS = ActivePresentation.Slides
And changed the start of the loop to:
For Each sld In sldS
BUT! The approach I used above (using copy and paste to move content between PPT and Word) has proven to be a VERY BAD IDEA.
When testing on moderately sized decks, notes or slide numbers would randomly find their way to the wrong place in the table, or an image would be pasted as text, or text as an image, and it would crash. I'm now rewriting the macro the ground up to save things out to files and then import them into Word. It's much more complicated but, hopefully, will lead to better results.
I have no idea why you add an object and then delete it, in many cases, it is not necessary. I just assume that you are doing the exercise, so I will keep your original code：
Let's try it out, how about ?
Sub CreateScriptTableLoop()
Dim sld As Slide, slideNumberNoteStr As String, oshp As PowerPoint.Shape
Dim sldS As Slides, mySlideCopy As PowerPoint.ShapeRange
Set sldS = ActivePresentation.Slides
' Set up Word
Dim wdApp As Word.Application, wdDoc As Word.Document
Dim tb As Word.Table, ur As Word.UndoRecord, r As Long
On Error GoTo eH:
Set wdApp = GetObject(, "Word.Application")
'If wdApp Is Nothing Then Set wdApp = New Word.Application
If wdApp.Documents.Count = 0 Then wdApp.Documents.Add
Set wdDoc = wdApp.ActiveDocument
Set ur = wdApp.UndoRecord
ur.StartCustomRecord "CreateScriptTableLoop"
' Set up Table
'ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:=3
Set tb = wdDoc.Tables.Add(Range:=wdDoc.ActiveWindow.Selection.Range, NumRows:=1, NumColumns:=3)
With tb.Borders
.OutsideLineStyle = wdLineStyleSingle
.InsideLineStyle = wdLineStyleSingle
End With
' Start loop
Debug.Print "Start Loop"
For Each sld In sldS 'For Each sld In ActivePresentation.Slides
r = r + 1
If r > 1 Then tb.Rows.Add
Debug.Print "Table created"
' Get Slide Number and put in column 1
'With ActivePresentation.Slides(1).Shapes
With sld.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 100, 100, 40, 20)
slideNumberNoteStr = oshp.TextFrame.TextRange.InsertSlideNumber.Text
oshp.Name = "Slide Num"
End With
'ActivePresentation.Slides(1).Shapes("Slide Num").TextFrame.TextRange.Copy
' sld.Shapes("Slide Num").TextFrame.TextRange.Copy
'With ActiveDocument.Tables(1).Cell(Row:=1, Column:=1).Range
With tb.Cell(Row:=r, Column:=1).Range
' .Borders.OutsideLineStyle = wdLineStyleSingle
'.PasteAndFormat wdFormatPlainText
.Text = slideNumberNoteStr
End With
' ActivePresentation.Slides(1).Shapes("Slide Num").Delete
sld.Shapes("Slide Num").Delete
Debug.Print "Slide number inserted"
' Get thumbnail and put in column 2
'*************************************************************
sld.Copy
'*************************************************************
'Set mySlideCopy = ActivePresentation.Slides(1).Shapes.Paste
' Set mySlideCopy = sld.Shapes.Paste
' With mySlideCopy
'
' .Name = "Slide Thumbnail"
' .Left = 0
' .Top = 0
' .Height = 400
' .Width = 400
' End With
'ActivePresentation.Slides(1).Shapes("Slide Thumbnail").Copy
' sld.Shapes("Slide Thumbnail").Copy
Debug.Print "Thumbnail copied"
'With ActiveDocument.Tables(1).Cell(Row:=1, Column:=2).Range
With tb.Cell(Row:=r, Column:=2).Range
' .Borders.OutsideLineStyle = wdLineStyleSingle
.PasteAndFormat wdPasteDefault
End With
'ActivePresentation.Slides(1).Shapes("Slide Thumbnail").Delete
' sld.Shapes("Slide Thumbnail").Delete
Debug.Print "Thumbnail pasted"
'Get notes and put in column 3
'sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Copy
slideNumberNoteStr = sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text
'With ActiveDocument.Tables(1).Cell(Row:=1, Column:=3).Range
With tb.Cell(Row:=r, Column:=3).Range
' .Borders.OutsideLineStyle = wdLineStyleSingle
'.PasteAndFormat wdFormatPlainText
.Text = slideNumberNoteStr
End With
Debug.Print "Notes Pasted"
Next sld
Debug.Print "Done"
exitSub:
Set wdApp = Nothing
ur.EndCustomRecord
Exit Sub
eH:
Select Case Err.Number
Case 429 'ActiveX component cannot generate object
Set wdApp = CreateObject("Word.Application")
'wdApp.UserControl = True
wdApp.Visible = True
wdApp.Activate
Resume Next
Case Else
MsgBox Err.Number + Err.Description
' Resume ' just for test
GoTo exitSub
End Select
End Sub