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
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
If ActivePresentation.Slides(1).Shapes("Rectangle 5").ActionSettings(ppMouseClick).Action = ppActionRunMacro(CorrectAnswer) Then
MsgBox "YEET"
End If
How do I make a MsgBox pop-up if a certain shape has a certain macro to it?
If your rectangle's ActionSettings are set like this
Sub Setup()
Dim ppt As Presentation
Set ppt = ActivePresentation
With ppt.Slides(1).Shapes("Rectangle 3").ActionSettings(ppMouseClick)
.Action = ppActionRunMacro
.Run = "CorrectAnswer"
End With
End Sub
Public Sub CorrectAnswer()
Debug.Print "show the correct answer"
End Sub
Then you can detect which shape has the macro you're looking for with
Sub test()
Dim ppt As Presentation
Set ppt = ActivePresentation
Dim sld As Slide
For Each sld In ppt.Slides
Dim shp As Shape
For Each shp In sld.Shapes
If shp.Name Like "Rectangle*" Then
If shp.ActionSettings(ppMouseClick).Run = "CorrectAnswer" Then
MsgBox "YaYaYeet"
End If
End If
Next
Next sld
End Sub
Your syntax is causing you the error.
Following is the correct syntax:
.ActionSettings.(ppMouseClick).Run = "CorrectAnswer"
I am trying to implement a error handling to my PowerPoint macro that restricts you to run the macro unless you are on slide 5. I am trying to utilize the command: "Application.ActiveWindow.View <> 5 Then" but it does not seem to recognize I am on slide 5, what is the correct comand for it ?
Private Sub CommandButton1_Click()
Dim Sld As Slide
Dim Shp As Shape
'ERROR HANDLING
If ActivePresentation.Slides.Count < 5 Then
MsgBox "You do not have any slides in your PowerPoint project."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
If activeSlide <> 5 Then
MsgBox "You are not on the correct slide."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
End Sub
activeSlide is not a PowerPoint object and you haven't defined it as anything else, replace it with Sld and add SlideIndex to get the number:
Private Sub CommandButton1_Click()
Dim Sld As Slide
Dim Shp As Shape
'ERROR HANDLING
If ActivePresentation.Slides.Count < 5 Then
MsgBox "You do not have any slides in your PowerPoint project."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
If Sld.SlideIndex <> 5 Then
MsgBox "You are not on the correct slide."
Exit Sub
End If
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
Trying to change the Excel source file for charts and objects linked in a PowerPoint deck.
I found this:
Sub ChangeOLELinks()
Dim oSld As Slide
Dim oSh As Shape
Dim sOldPath As String
Dim sNewPath As String
' EDIT THIS TO REFLECT THE PATHS YOU WANT TO CHANGE
sOldPath = InputBox("Enter Old Project ie: \Development\", "Old Path")
sNewPath = InputBox("Enter New Project ie: \Test\", "New Path")
On Error GoTo ErrorHandler
For Each oSld In ActivePresentation.Slides
For Each oSh In oSld.Shapes
If oSh.Type = msoLinkedOLEObject Then
Dim stringPath As String
stringPath = Replace(oSh.LinkFormat.SourceFullName, sOldPath, sNewPath, 1, , vbTextCompare)
oSh.LinkFormat.SourceFullName = stringPath
' set update mode to auto and update then set it back to manual
oSh.LinkFormat.AutoUpdate = ppUpdateOptionAutomatic
oSh.LinkFormat.Update
oSh.LinkFormat.AutoUpdate = ppUpdateOptionManual
End If
Next oSh
Next oSld
ActivePresentation.Save
MsgBox ("Done!")
NormalExit:
Exit Sub
ErrorHandler:
MsgBox ("Error " & Err.Number & vbCrLf & Err.Description)
Resume NormalExit
End Sub
This works for OLE objects/links. It isn't updating any of the linked charts.
How can I include charts?
As your charts are paste-linked (4th option) from Excel, they're of msoChart type.
The LinkFormat.SourceFullName property works for this type too so you just have to replace your
If oSh.Type = msoLinkedOLEObject
with
if oSh.Type = msoChart