Can anyone help me with the below code? I am trying to use VBA to remove any extra spaces in a PowerPoint presentation.
Sub removeSpaces()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
Do While InStr(shp, " ") > 0
shp.Value = Replace(shp, " ", " ")
shp.Value = Trim(shp.Value)
Next shp
Next sld
End Sub
When I currently run it, it shows an error of "Method or data member not found" and highlights the "shp.Value" part.
a Shape object doesn't have a .Value property. The Instr function may also not evaluate against a Shape object.
https://msdn.microsoft.com/en-us/library/office/ff747227(v=office.14).aspx
Generally, you need to refer to the shape's TextFrame, like:
Dim shpText as String
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
shpText = shp.TextFrame.TextRange.Text 'Get the shape's text
Do While InStr(shpText, " ") > 0
shpText = Trim(Replace(shpText, " ", " "))
Loop
shp.TextFrame.TextRange.Text = shpText 'Put the new text in the shape
Else
shpText = vbNullString
End If
Next shp
Next sld
End Sub
Related
I am trying to copy all true or checked boxes on all slides and paste them onto one slide within my presentation. I can't seem to figure it out. Below is the code that I am using. Any help is appreciated.
`Sub ckbxCopy()
Dim shp As Shape
Dim sld As Slide
Dim i As Integer
On Error Resume Next
For Each sld In ActivePresentation.Slides
For i = 1 To 4
shp = ActivePresentation.Slides("CheckBox" & CStr(i))
If Err.Number = 0 Then ' shape exists
If shp.OLEFormat.Object.Value = True Then
shp.Copy
ActivePresentation.Slides(3).Shapes.Paste
End If
End If
Next i
Next sld
End Sub`
This works for me:
Sub ckbxCopy()
Dim shp As Shape, pres As Presentation
Dim sld As Slide, sldDest As Slide
Dim i As Integer, t As Long
Set pres = ActivePresentation
Set sldDest = pres.Slides(3) 'where shapes are to be pasted
sldDest.Shapes.Range.Delete 'remove existing shapes
t = 20
For Each sld In pres.Slides
If sld.SlideIndex <> sldDest.SlideIndex Then
For i = 1 To 4
Set shp = Nothing
Set shp = SlideShape(sld, "CheckBox" & CStr(i))
If Not shp Is Nothing Then
If shp.OLEFormat.Object.Value = True Then
shp.Copy
pres.Slides(3).Shapes.Paste.Top = t 'paste and position
t = t + 20
End If
End If
Next i
End If
Next sld
End Sub
'Return a named shape from a slide (or Nothing if the shape doesn't exist)
Function SlideShape(sld As Slide, shapeName As String) As Shape
On Error Resume Next
Set SlideShape = sld.Shapes(shapeName)
End Function
I tried creating VBA to delete shapes with specific color from all slides. But after I run those it delete all the shapes on slide. Does someone perhaps have an idea?
For Each sld In ActivePresentation.Slides
TotalShapes = sld.Shapes.Count
For i = TotalShapes to 1 step -1
sld.Shapes(i).Delete
Next
Next
Slides and shapes are held in a collection so you can use For...Each to step through each item in the collection.
You then need to check the colour of each shape before deleting it.
This will delete red shapes:
Sub Test()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
'Debug.Print shp.Name & ": " & shp.Fill.ForeColor.RGB
If shp.Fill.ForeColor.RGB = RGB(255, 0, 0) Then
shp.Delete
End If
Next shp
Next sld
End Sub
Sub RenameShapeNameIfSpecificText()
Dim ppt As Presentation, sld As Slide
Set ppt = ActivePresentation
For Each sld In ppt.Slides
Dim shp As Shape
For Each shp In sld.Shapes
If shp.TextFrame.TextRange = "0x" Then
shp.Name = "Counter"
End If
Next shp
Next sld
End Sub
I have a 20-slide presentation in which 18 slides have a shape with the text 0x. I would like to rename those shapes to "Counter".
The above code causes this error: The Specified Value is out of range
I suppose the error is being caused due to images being present too.
Thank you.
"Use the HasTextFrame property to determine whether a shape contains a text frame before you apply the TextFrame property":
Sub RenameShapeNameIfSpecificText()
Dim ppt As Presentation, sld As Slide, shp As Shape
Set ppt = ActivePresentation
For Each sld In ppt.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "0x" Then
shp.Name = "Counter"
End If
End If
Next shp
Next sld
End Sub
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 have a presentation with many shapes and want to name each of them as "MyPicture#", where # is a number. For example shape 65 would be named MyPicture65. Can VBA do this? How then?
Sub test()
Dim sld As Slide
Dim shp As Shape
Dim lctr As Long
For Each sld In ActiveWindow.Presentation.Slides
For Each shp In sld.Shapes
lctr = lctr + 1
shp.Name = "MyPicture" & lctr
Next
Next
End Sub