I made a presentation (with Powerpoint 2016 in Windows 10) on which there are text attached to the images.
I know VBA (not thoroughly) for Word or Excel but I'm new to PP. But Powerpoint grammar confuses me (it will also be for my age). I want to extract all the title and text of all the slides and about this I create the following program which works fine but doesn't let me know the text on grouped objects. Where am I wrong?
Sub RiepilogaConWord()
Dim applWord As Word.Application
Dim docWord As Word.Document
Dim paraWord As Word.Paragraph
Dim oSh As Shape
Dim oSL As Slide
Set applWord = New Word.Application
applWord.Visible = True
applWord.WindowState = wdWindowStateMaximize
Set docWord = applWord.Documents.Add
docWord.ShowSpellingErrors = False
applWord.Selection.TypeText Text:="RIEPILOGO AL " & Format(Date, "dd/mm/YYYY") & " alle ore " & Format(Time, "hh:mm")
docWord.Paragraphs.Add
Set paraWord = docWord.Paragraphs(docWord.Paragraphs.Count)
paraWord.Range.InsertAfter "Totale diapositive " & Presentations(1).Slides.Count
docWord.Paragraphs.Add
For Each oSL In ActivePresentation.Slides
paraWord.Range.InsertAfter oSL.SlideIndex
docWord.Paragraphs.Add
Dim g As Integer
For Each oSh In oSL.Shapes
Select Case oSh.Type
Case Is = msoGroup
On Error Resume Next
oSh.Ungroup.Group , msoTextBox
For g = 1 To oSh.GroupItems.Count
If oSh.TextFrame.HasText Then
paraWord.Range.InsertAfter oSh.Name & ":= " & oSh.TextFrame.TextRange
End If
Next g
On Error GoTo errorhandler
Case Else
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
paraWord.Range.InsertAfter oSh.Name & ":= " & .TextFrame.TextRange
End If
End If
End With
End Select
Next
Next
docWord.SaveAs FileName:="C:\EPITETI CINQUE\Presentazione\RiepilogoPresentazione"
applWord.Quit
Set docWord = Nothing
Set applWord = Nothing
Set paraWord = Nothing
Exit Sub
errorhandler:
End Sub
Thank you for any help.
Francesco
Couple of things at issue here
On Error Resume Next is hiding the issue from you. Remove it
oSh.Ungroup.Group , msoTextBox makes no sense, I don't know what you are trying to do there
When you find a grouped object, iterate its members
I've refactored your code to demonstrate.
I've removed the Word stuff to make the Q clearer, and just dump the text to the Immediate Window (Ctrl-G to display it in the VBA editor). You can add it back...
added comments on changed code, marked <---
Added indenting to make the code readable
Sub RiepilogaConWord()
Dim oSh As Shape
Dim oSL As Slide
Dim g As Integer '<--- move here, no point in putting it in the loop, that does nothing
'<--- Add here to use a general error.
' Comment it out while debugging to expose any errors
' On Error GoTo errorhandler handler
For Each oSL In ActivePresentation.Slides
For Each oSh In oSL.Shapes
Select Case oSh.Type
Case Is = msoGroup
'On Error Resume Next '<--- Delete this
'oSh.Ungroup.Group , msoTextBox '<--- Delete this
For g = 1 To oSh.GroupItems.Count
With oSh.GroupItems.Item(g) '<--- simplify
'<--- use g to iterate the grouped items
If .HasTextFrame Then '<--- more robust
If .TextFrame.HasText Then
Debug.Print .Name & ":= " & .TextFrame.TextRange
End If
End If
End With
Next g
'On Error GoTo errorhandler '<--- Delete this
Case Else
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
Debug.Print oSh.Name & ":= " & .TextFrame.TextRange
End If
End If
End With
End Select
Next
Next
Exit Sub
errorhandler:
End Sub
I'm trying to write a batch find and replace code for Power Point slides in VBA but I'm getting the following error: Compile Error Method or data member not found.
The debugger is highlighting Shapes in PP.Shapes on line 13.
I do not have much experience with VBA. I gathered ideas from:
* Getting Started with VBA in PowerPoint 2010 (Office Dev Center)
* Power Point VBA-Find & Replace (YouTube)
* "Simple Macro to import slides from a file" # (VBA Express Forum)
Sub BatchFindReplace()
Dim shp As Shape
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
'Directory
strFolderName = "C:\Users\Emma\Desktop\temp1"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'Find and Replace Code
For Each shp In PP.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "W", "kkk")
End If
End If
Next
PP.Close
strFileName = Dir
Loop
End Sub
The property .Shapes is not a member of Presentation but of Slide
'~~> Open the relevant powerpoint file
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'~~> Change this to the relevant slide which has the shape
Set PPSlide = PP.Slides(1)
For Each shp In PPSlide.Shapes
Debug.Print shp.Name
Next shp
If you want to work with all shapes in all slides then you will have to loop through slides.
Dim sld As Slide
'~~> Open the relevant powerpoint file
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
For Each sld In PP.Slides
For Each shp In sld.Shapes
Debug.Print shp.Name
Next shp
Next
I would like to loop through all the ppt from a folder and delete a string if found in any textbox in any slide.
I am new to working with powerpoint slides hence need some tips and advice how to work with it.
Option Compare Text
Option Explicit
Sub Test()
Dim Sld As Slide, Shp As Shape
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
Dim strf As String
'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
'Opens a PowerPoint Document from Excel
Dim objPPT As Object
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
'set default directory here if needed
strFolderName = "C:\Users\Desktop\Files"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
objPPT.Presentations.Open strFolderName & "\" & strFileName
objPPT.Presentations.Activate
For Each Sld In ActivePresentation.Slides 'Error - ActiveX Component can't create object.
For Each Shp In Sld.Shapes
Select Case Shp.Type
Case MsoShapeType.msoTextBox
Debug.Print Sld.Name, Shp.Name, Shp.TextFrame.TextRange.Text
Case Else
Debug.Print Sld.Name, Shp.Name, "This is not a text box"
End Select
Next Shp
Next Sld
objPPT.Presentations.Close
strFileName = Dir
Loop
End Sub
As you are running the macro in Excel, you forgot to say where the ActivePresentation is from. It should work if you have objPPT.ActivePresentation.Slides. Anyway, you can try below revised code:
'Option Compare Text
Option Explicit
Sub Test()
'Dim Sld As Slide, Shp As Shape ' <-- Excel doesn't know Slide if Reference not added
Dim Sld As Object, Shp As Object
Dim strFileName As String
Dim strFolderName As String
'Dim PP As Presentation
Dim PP As Object ' Use this Presentation Object!
Dim strf As String
'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
'Opens a PowerPoint Document from Excel
Dim objPPT As Object
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True ' <-- don't need this, for debug only
'set default directory here if needed
strFolderName = "C:\Users\Desktop\Files"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
'objPPT.Presentations.Open strFolderName & "\" & strFileName
Set PP = objPPT.Presentations.Open(strFolderName & "\" & strFileName)
'objPPT.Presentations.Activate
PP.Activate ' <-- don't need this, for debug only
'For Each Sld In ActivePresentation.Slides 'Error - ActiveX Component can't create object.
' Should work if it's "objPPT.ActivePresentation.Slides"
For Each Sld In PP.Slides
For Each Shp In Sld.Shapes
With Shp
Select Case .Type
Case MsoShapeType.msoTextBox
If InStr(1, .TextFrame.TextRange.Text, strf, vbTextCompare) > 0 Then
Debug.Print Sld.Name, .Name, .TextFrame.TextRange.Text
Else
Debug.Print Sld.Name, .Name, """" & strf & """ not found in text body"
End If
Case Else
Debug.Print Sld.Name, .Name, "This is not a text box"
End Select
End With
Next Shp
Next Sld
'objPPT.Presentations.Close
PP.Close
Set PP = Nothing
strFileName = Dir
Loop
End Sub
UPDATE - To allow processing files already opened and some tweaks:
Option Explicit
Sub Test()
Const strFolderName = "C:\Users\Desktop\Files\"
Dim objPPT As Object, PP As Object, Sld As Object, Shp As Object
Dim strFileName As String
Dim strf As String
'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
If Len(Trim(strf)) = 0 Then Exit Sub ' Exit if blank text returned
'Opens a PowerPoint Document from Excel
Set objPPT = CreateObject("PowerPoint.Application")
'set default directory here if needed
strFileName = Dir(strFolderName & "*.ppt*")
Do While Len(strFileName) > 0
On Error Resume Next
' Try to get existing one with same name
Set PP = objPPT.Presentations(strFileName)
' If not opened, try open it
If PP Is Nothing Then Set PP = objPPT.Presentations.Open(strFolderName & strFileName)
On Error GoTo 0
' Process the Presentation Slides if it's opened
If PP Is Nothing Then
Debug.Print "Cannot open file! """ & strFolderName & strFileName & """"
Else
Application.StatusBar = "Processing PPT file: " & PP.FullName
Debug.Print String(50, "=")
Debug.Print "PPT File: " & PP.FullName
For Each Sld In PP.Slides
For Each Shp In Sld.Shapes
With Shp
If .Type = MsoShapeType.msoTextBox Then
If InStr(1, .TextFrame.TextRange.Text, strf, vbTextCompare) > 0 Then
Debug.Print Sld.Name, .Name, .TextFrame.TextRange.Text
Else
Debug.Print Sld.Name, .Name, """" & strf & """ not found in text body"
End If
End If
End With
Next Shp
Next Sld
PP.Close ' Close the Presentation
Set PP = Nothing
End If
strFileName = Dir
Loop
Application.StatusBar = False
' Quit PowerPoint app
objPPT.Quit
Set objPPT = Nothing
End Sub
I cannot explain the error you are getting. I also would have expected the code to work. Yet, I stumbled upon this problem before and found the following solution which (strangely) works:
Option Compare Text
Option Explicit
Sub Test()
Dim Sld As Long, Shp As Long
Dim strFileName As String
Dim strFolderName As String
Dim PP As PowerPoint.Presentation
Dim strf As String
'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
'Opens a PowerPoint Document from Excel
Dim objPPT As PowerPoint.Application
Set objPPT = New PowerPoint.Application
objPPT.Visible = True
'set default directory here if needed
strFolderName = "C:\Users\Desktop\Files"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
Set PP = objPPT.Presentations.Open(strFolderName & "\" & strFileName)
'objPPT.Presentations.Activate
For Sld = 1 To PP.Slides.Count
For Shp = 1 To PP.Slides.Item(Sld).Shapes.Count
With PP.Slides.Item(Sld).Shapes.Item(Shp)
Select Case .Type
Case MsoShapeType.msoTextBox
Debug.Print .Name, .Name, .TextFrame.TextRange.Text
Case Else
Debug.Print .Name, .Name, "This is not a text box"
End Select
End With
Next Shp
Next Sld
PP.Close
Set PP = Nothing
strFileName = Dir
Loop
objPPT.Quit
Set objPPT = Nothing
End Sub
Note: this solution uses early binding instead of late binding. So, you will need to add a reference to Microsoft PowerPoint xx.x Object Library.
I have some objects named"MYobject" in a PowerPoint presentation. I need a macro to delete those objects named "Myobject". How can I do that?
The code I use to tag objects:
Sub TagObject()
On Error GoTo ErrorHandler
Dim oSh As Shape
For Each oSh In ActiveWindow.Selection.ShapeRange
oSh.Tags.Add "Myobject", "YES"
Next
MsgBox "Done! Object has now been tagged.", vbInformation
Exit Sub
ErrorHandler:
MsgBox "Please select an object before tagging.", vbExclamation
End Sub
This will delete all shapes with a Myobject tag = "YES"
Sub DeleteMyObjects()
Dim oSl As Slide
Dim oSh As Shape
Dim x As Long
' note that this will not delete shapes
' within groups
For Each oSl In ActivePresentation.Slides
For x = oSl.Shapes.Count To 1 Step -1
If UCase(oSl.Shapes(x).Tags("Myobject")) = "YES" Then
oSl.Shapes(x).Delete
End If
Next ' Shape
Next ' Slide
End Sub
references that was selected:
- visual basic for applications
- Microsoft powerpoint 14.0 object library
- ole automation
- Microsoft office 14.0 object library
how to determine the character's code using Dialogs(wdDialogInsertSymbol) and what other reference(s) should be selected?
thanks.
Sub fdjlas()
Dim osh As Shape
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
For Each osh In oSl.Shapes
If osh.HasTextFrame Then
With osh.TextFrame.TextRange
For i = 1 To .Characters.Count
With .Characters(i).Font
MsgBox ("Char number: " & Dialogs(wdDialogInsertSymbol).CharNum)
End With
Next
End With
End If
Next
Next
MsgBox ("done")
End Sub
OUTPUT:
Compile error:
Method or data member not found
MsgBox ("Char number: " & Dialogs(wdDialogInsertSymbol).CharNum)
* the Dialogs gets highlighted
Something like this then?
Dim oSl As Slide
Dim oSh As Shape
Dim i As Long
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.HasTextFrame Then
With oSh.TextFrame.TextRange
For i = 1 To .Characters.Count
'With .Characters(i).Font
' MsgBox ("Char number: " & Dialogs(wdDialogInsertSymbol).CharNum)
'End With
MsgBox .Characters(i) & ": " & Asc(.Characters(i))
Next
End With
End If
Next
Next