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
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 am searching for a VBA code that activate the option "Shrink text on overflow" for all textboxes in a PowerPoint document. I tried this :
Sub Change()
Dim oSlide As Slide
Dim oShape As Shape
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
oShape.TextFrame2.AutoSize = MsoAutoSize.msoAutoSizeTextToFitShape
Next oShape
Next oSlide
End Sub
But that unfortunately doesn't work. I am a very beginner.
Any thought ?
Thank you.
Just use msoAutoSizeTextToFitShape instead of MsoAutoSize.msoAutoSizeTextToFitShape. It's also good to check if the shape actually has a textframe first. This version gets shapes inside groups as well:
Sub Change()
Dim oSlide As Slide
Dim oShape As Shape
Dim oSubShape As Shape
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Type = msoGroup Then
For Each oSubShape In oShape.GroupItems
If oSubShape.HasTextFrame Then
oSubShape.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
End If
Next oSubShape
Else
If oShape.HasTextFrame Then
oShape.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
End If
End If
Next oShape
Next oSlide
End Sub
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 have a macro that creates a new slide at the beginning of a section in my PowerPoint presentation.
Is there a method to replace .MoveToSectionStart that would move the slide to the end?
The method is found in the Sub at the end called Sub AddCustomSlide().
Private Function GetSectionNumber( _
ByVal sectionName As String, _
Optional ParentPresentation As Presentation = Nothing) As Long
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
GetSectionNumber = -1
With ParentPresentation.SectionProperties
Dim i As Long
For i = 1 To .Count
If .Name(i) = sectionName Then
GetSectionNumber = i
Exit Function
End If
Next i
End With
End Function
Public Function GetLayout( _
LayoutName As String, _
Optional ParentPresentation As Presentation = Nothing) As CustomLayout
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
Dim oLayout As CustomLayout
For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
If oLayout.Name = LayoutName Then
Set GetLayout = oLayout
Exit For
End If
Next
End Function
Sub AddCustomSlide()
Dim oSlides As Slides, oSlide As Slide
Dim Shp As Shape
Dim Sld As Slide
Set oSlides = ActivePresentation.Slides
Set oSlide = oSlides.AddSlide(oSlides.Count - 2, GetLayout("Processwindow"))
oSlide.MoveToSectionStart GetSectionNumber("Main Process")
End Sub
Sorry, there's no such method. Here's how to insert one at the end:
Sub AddCustomSlide()
Dim oSlides As Slides, oSlide As Slide
Dim Shp As Shape
Dim Sld As Slide
Dim SecNum As Integer, SlideCount As Integer, FirstSecSlide As Integer
Set oSlides = ActivePresentation.Slides
Set oSlide = oSlides.AddSlide(oSlides.Count - 2, GetLayout("Processwindow"))
SecNum = GetSectionNumber("Main Process")
With ActivePresentation.SectionProperties
SlideCount = .SlidesCount(SecNum)
FirstSecSlide = .FirstSlide(SecNum)
End With
oSlide.MoveTo toPos:=FirstSecSlide + SlideCount - 1
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