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"
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
Does anyone know how to lock all shapes from all slides in vba and also unlock in another macro?
I've the beggining but I can't find how to apply the lock function.
Sub test()
On Error Resume Next
For Each oSlide In ActivePresentation.Slides
oSlide.Shapes.SelectAll
xxx.locked
Next
End Sub
Air code, but it should work, assuming you have a version of PPT that supports .Locked:
sub test
Dim oSlide As Slide
Dim oShape as Shape
On Error Resume Next
For Each oSlide In ActivePresentation.Slides
For Each oShape in oSlide.Shapes
oShape.Locked = True
Next
Next
end sub
the correct macro need to activate the slide before processing
I'm looking for the next step "oSlide.Shapes.SelectAll" with lock to accelerate, if anyone...
Sub Lock()
Dim oSlide As Slide
dim oShape As Shape
Dim slideIndex As Long
Set oSlide = Application.ActiveWindow.View.Slide
oslideIndex = oSlide.slideIndex
On Error Resume Next
For Each oSlide In ActivePresentation.Slides
ActivePresentation.Slides(oSlide.slideIndex).Select
For Each oShape In oSlide.Shapes
oShape.Locked = True
Next
Next
ActivePresentation.Slides(oslideIndex).Select
End Sub
Here we go
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Lock()
Dim oSlide As Slide
Dim oShape As Shape
Dim slideIndex As Long
Set oSlide = Application.ActiveWindow.View.Slide
oSlideIndex = oSlide.slideIndex
On Error Resume Next
For Each oSlide In ActivePresentation.Slides
ActivePresentation.Slides(oSlide.slideIndex).Select
Sleep (100)
ActivePresentation.Slides(oSlide.slideIndex).Shapes.Range.Locked = msoTrue
Next
ActivePresentation.Slides(oSlideIndex).Select
End Sub
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 usually use this one couple times for converting charts to image in PPT. But this time, when running this code, it shown " Error 242, Subject Required"
Anyone master of VBA can help me fix it?
Here the code:
`Sub EnumChartsInPresentation()
Dim sld As Slide
Dim shp As Shape
Dim ctr As Long
For Each sld In ActivePresentation.Slides
For ctr = sld.Shapes.Count To 1 Step -1
If GetShapeType(sld.Shapes(ctr)) = msoChart Then
Call ConvertChartToImage(sld, sld.Shapes(ctr))
End If
Next
Next
End Sub
Function GetShapeType(shp As Shape) As MsoShapeType
If shp.Type = msoPlaceholder Then
If shp.PlaceholderFormat.ContainedType = msoChart Then
GetShapeType = msoChart
Exit Function
End If
End If
GetShapeType = shp.Type
End Function
Sub ConvertChartToImage(sld As Slide, shp As Shape)
Dim shpChartImage As Object
shp.Copy
DoEvents
Set shpChartImage = sld.Shapes.PasteSpecial(ppPastePNG)
With shpChartImage
.Left = shp.Left
.Top = shp.Top
Do While shp.ZOrderPosition < shpChartImage.ZOrderPosition
Call shpChartImage.ZOrder(msoSendBackward)
Loop
shp.Visible = False
'shp.Delete
'Set shp = Nothing
End With
End Sub`
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