Copy/Paste CheckBoxes If True In PowerPoint - vba

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

Related

Align bottom all shapes according to a name with VBA (Powerpoint)

I have an issue aligning shapes using VBA on PowerPoint (office 360).
I know I can use .Shapes.Range.Align msoAlignBottom, msoFalse
but I don't understand how to make it work with a specific shape name as I always have an error or nothing is happening.
This is the code in which I would like to implement this action:
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
sn = InputBox("Enter the name of the shape")
On Error Resume Next
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.Name = sn Then
Select Case oSh.PlaceholderFormat.Type
Case 1, 3 'Title
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape ' OR msoAutoSizeNone
Case 2, 7 'Text / Content
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSh.Shapes.Range.Align msoAlignBottom, msoTrue
End Select
End If
Next oSh
Next oSl
End Sub
Thank you very much for your help,
Try this code:
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
'sn = InputBox("Enter the name of the shape")
sn = "Name1" 'debug
'On Error Resume Next
For Each oSl In ActivePresentation.Slides
For i = 1 To oSl.Shapes.Count
Set oSh = oSl.Shapes(i)
If oSh.Name = sn Then
Select Case oSh.Type 'placeholder or not placeholder?
Case msoPlaceholder
' it's a placeholder! check the placeholder's type
If oSh.PlaceholderFormat.Type = ppPlaceholderTitle _
Or oSh.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
'do smth with placeholder
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
End If
Case Else 'it's not a placeholder
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSl.Shapes.Range(i).Align msoAlignBottoms, msoTrue 'align it to bottom of the slide
End Select
End If
Next
Next oSl
End Sub
I also recommend removing the On Error Resume Next statement because it hides errors and you don't get useful information about how the code works.
You have to create a ShapeRange that includes the shapes you want to align. Since you are keying off the name of the shape, the example below shows how a wildcard can be used.
Option Explicit
Sub Test()
LineUpShapes 1, "Rectangle", msoAlignTops
End Sub
Sub LineUpShapes(ByVal SlideNumber As Long, _
ByVal ShapeName As String, _
ByVal alignment As MsoAlignCmd)
Dim sl As Slide
Set sl = ActivePresentation.Slides(SlideNumber)
Dim namedShapes() As Variant
Dim shapeCount As Integer
Dim sh As Shape
For Each sh In sl.Shapes
If sh.Name Like (ShapeName & "*") Then
shapeCount = shapeCount + 1
ReDim Preserve namedShapes(shapeCount) As Variant
namedShapes(shapeCount) = sh.Name
Debug.Print "shape name " & sh.Name
End If
Next sh
Dim shapesToAlign As ShapeRange
Set shapesToAlign = sl.Shapes.Range(namedShapes)
shapesToAlign.Align alignment, msoFalse
End Sub
Thank you so much Алексей!
I have readapted your code and it works perfectly! It is always a placeholder in my case ;)
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
sn = InputBox("Enter the name of the shape")
For Each oSl In ActivePresentation.Slides
For i = 1 To oSl.Shapes.Count
Set oSh = oSl.Shapes(i)
If oSh.Name = sn Then
Select Case oSh.PlaceholderFormat.Type
Case 1, 3 'Title
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape ' OR msoAutoSizeNone
Case 2, 7 'Text / Content
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSl.Shapes.Range(i).Align msoAlignBottoms, msoTrue 'align it to bottom of the slide
End Select
End If
Next
Next oSl
End Sub

If statement for ppActionRunMacro

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"

Powerpoint VBA foreach skipping some valid shapes

I do presentations with background wipes that are flowchart process shapes with the text "wipey" for yellow wipes and "wipeb" for blue wipes. When working out the animations for training slides, I place the wipes in front with 0.75 transparency. Once the wipe-animation order is correct and the wipes properly placed, I move the wipes behind the text with 0 transparency.
My Wipe_Back macro works fine but my Wipe_Front macro is only getting some of the wipes each time it is called. I have to call it multiple times to get all of the shapes moved forward. the macros are almost identical so I am not sure what I am doing wrong, but I am a VBA newbie-ish!
both macros are shown below and I am also open to recommendations on more elegant practices in the code.
Wipe_Back (seems to work):
Sub Wipe_Back()
Dim sld As slide
Dim shp As Shape
Dim str As String
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoAutoShape Then
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "wipey" Then
shp.Fill.Transparency = 0
shp.ZOrder msoSendToBack
'shp.Fill.Transparency = 0.75
'shp.ZOrder msoBringToFront
End If
If shp.TextFrame.TextRange = "wipeb" Then
shp.Fill.Transparency = 0
shp.ZOrder msoSendToBack
'shp.Fill.Transparency = 0.75
'shp.ZOrder msoBringToFront
End If
End If
End If
Next shp
Next sld
End Sub
Wipe_Front does not consistently work:
Sub Wipe_Front()
Dim sld As slide
Dim shp As Shape
Dim str As String
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoAutoShape Then
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "wipey" Then
'shp.Fill.Transparency = 0
'shp.ZOrder msoSendToBack
shp.Fill.Transparency = 0.75
shp.ZOrder msoBringToFront
End If
If shp.TextFrame.TextRange = "wipeb" Then
'shp.Fill.Transparency = 0
'shp.ZOrder msoSendToBack
shp.Fill.Transparency = 0.75
shp.ZOrder msoBringToFront
End If
End If
End If
Next shp
Next sld
End Sub
If you change the order of shapes (as changing the z-order does) or delete them in the midst of a For Each/Next loop, the results won't be what you expect.
If deleting shapes, you can use something like this:
For x = sld.Shapes.Count to 1 Step -1
' delete sld.Shapes(x) if it meets your conditions
Next
If changing the z-order, you may need to collect references to the shapes in an array and step through the array a shape at a time.
Okay, got it! Steve Rindsberg pointed me in the right direction and I corrected the "On Error Resume Next" and now the routines are doing what was expected. Thanks for the help!
Wipe Front():
Sub Wipe_Front()
Dim sld As slide
Dim shp As Shape
Dim str As String
Dim wshps() As Shape, i As Long
ReDim wshps(0 To 1)
i = 0
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoAutoShape Then
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "wipey" Then
Set wshps(i) = shp
i = i + 1
ReDim Preserve wshps(0 To i) As Shape
End If
If shp.TextFrame.TextRange = "wipeb" Then
Set wshps(i) = shp
i = i + 1
ReDim Preserve wshps(0 To i) As Shape
End If
End If
End If
Next shp
For Each wshp In wshps
On Error Resume Next
wshp.Fill.Transparency = 0.75
wshp.ZOrder msoBringToFront
'wshp.Fill.Transparency = 0
'wshp.ZOrder msoSendToBack
Next wshp
Next sld
End Sub
Wipe_Back():
Sub Wipe_Back_New()
Dim sld As slide
Dim shp As Shape
Dim str As String
Dim wshps() As Shape, i As Long
ReDim wshps(0 To 1)
i = 0
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoAutoShape Then
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "wipey" Then
Set wshps(i) = shp
i = i + 1
ReDim Preserve wshps(0 To i) As Shape
End If
If shp.TextFrame.TextRange = "wipeb" Then
Set wshps(i) = shp
i = i + 1
ReDim Preserve wshps(0 To i) As Shape
End If
End If
End If
Next shp
For Each wshp In wshps
On Error Resume Next
'wshp.Fill.Transparency = 0.75
'wshp.ZOrder msoBringToFront
wshp.Fill.Transparency = 0
wshp.ZOrder msoSendToBack
Next wshp
Next sld
End Sub

Convert charts to picture powerpoint

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`

PowerPoint vba macro - Copy Text Box text to note -need to also copy font & font color

I have a current macro that works well. It deletes all of the current notes in the PPT slide - then copies every shape that has text to the slide notes.
I need one more "tweak"--- when the text is copied to the note area, I need to also copy the current font, font color, size, etc.
Is there a way to do this?
Many thanks!!!
Sub Copy_SlideShapeText_ToNotes()
Dim curSlide As Slide
Dim curShape As Shape
Dim curNotes As Shape
Dim oSh As Shape
'delete all notes in receiving slides
For Each curSlide In ActivePresentation.Slides
curSlide.NotesPage.Shapes(2) _
.TextFrame.TextRange = ""
Next curSlide
For Each curSlide In ActivePresentation.Slides
For Each oSh In curSlide.NotesPage.Shapes
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
Set curNotes = oSh
Exit For
End If
Next oSh
For Each curShape In curSlide.Shapes
If curShape.TextFrame.HasText Then
curNotes.TextFrame.TextRange.InsertAfter curShape.TextFrame.TextRange.Text & vbCr
End If
Next curShape
Next curSlide
End Sub
Sub Example()
' Assume you have two rectangles on slide 1 and no other shapes
' And that the first rectangle has text with various formatting
' This will pick up the text from the first rectangle, run by run,
' and apply the text AND its formatting to the second rectangle
Dim oSrc As Shape
Dim oTgt As Shape
Dim x As Long
Dim oRng As TextRange
Set oSrc = ActivePresentation.Slides(1).Shapes(1)
Set oTgt = ActivePresentation.Slides(1).Shapes(2)
With oSrc.TextFrame.TextRange
For x = 1 To .Runs.Count
With .Runs(x)
' Add the text from the current run to the second rectangle
' and get a reference to its range in oRng
Set oRng = oTgt.TextFrame.TextRange.InsertAfter(.Text)
' now format the text in oRng to match the same range
' from the original
oRng.Font.Name = .Font.Name
oRng.Font.Bold = .Font.Bold
oRng.Font.Color = .Font.Color
' add other properties as required, stir well
End With
Next
End With
End Sub
Sub Copy_SlideShapeText_ToNotes()
Dim curSlide As Slide
Dim curShape As Shape
Dim curNotes As Shape
Dim oSh As Shape
' New variable:
Dim oRng As TextRange
'delete all notes in receiving slides
For Each curSlide In ActivePresentation.Slides
curSlide.NotesPage.Shapes(2) _
.TextFrame.TextRange = ""
Next curSlide
For Each curSlide In ActivePresentation.Slides
For Each oSh In curSlide.NotesPage.Shapes
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
Set curNotes = oSh
Exit For
End If
Next oSh
For Each curShape In curSlide.Shapes
If curShape.TextFrame.HasText Then
Set oRng = curNotes.TextFrame.TextRange.InsertAfter(curShape.TextFrame.TextRange.Text)
With oRng
.Font.Name = curShape.TextFrame.TextRange.Font.Name
.Font.Bold = curShape.TextFrame.TextRange.Font.Bold
.Font.Color.RGB = curShape.TextFrame.TextRange.Font.Color.RGB
' other properties as required
End With
End If
Next curShape
Next curSlide
End Sub