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
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
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 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
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
I have to go through numerous powerpoints replacing specific words with new ones. I made a macro that seemed to work, however after closer examination I realized that words within tables were not being replaced. After some searching I saw other people having this issue but no clear answer. I came up with the following but I also get the runtime error "This member can only be accessed for a group" on the line that reads For Each grpItem In shp.GroupItems
Could someone provide insight as to what I'm doing wrong, or perhaps a better way to do this?
Sub DataScrubAllSlidesAndTables()
Dim sld As Slide
Dim grpItem As Shape
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Store", "Seller")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Customer", "Buyer")
End If
End If
If shp.Type = msoTable Then
For Each grpItem In shp.GroupItems
If InStr(1, grpItem.Name, "Rectangle") Then
grpItem.TextFrame.TextRange.Text = Replace(grpItem.TextFrame.TextRange.Text, "Store", "Seller")
grpItem.TextFrame.TextRange.Text = Replace(grpItem.TextFrame.TextRange.Text, "Store", "Seller")
End If
Next grpItem
End If
Next shp
Next
End Sub
This:
Sub DataScrubAllSlidesAndTables()
Dim sld As Slide
Dim grpItem As Shape
Dim shp As Shape
Dim i As Long
Dim j As Long
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Store", "Seller")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Customer", "Buyer")
End If
End If
If shp.HasTable Then
For i = 1 To shp.Table.Rows.Count
For j = 1 To shp.Table.Columns.Count
shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Text = _
Replace(shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Text, "This", "That")
Next j
Next i
End If
Next shp
Next
End Sub
try using this:
Sub DataScrubAllSlidesAndTables()
Dim sld As Slide
Dim grpItem As Shape
Dim shp As Shape
Dim i As Integer
Dim j As Integer
Dim varTemp As Variant
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Store", "Seller")
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Customer", "Buyer")
End If
End If
On Error GoTo lblNotTable:
For i = 1 To shp.Table.Rows.Count
For j = 1 To shp.Table.Columns.Count
varTemp = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Text
Next j
Next i
lblNotTable:
Err.Clear
Next shp
Next
End Sub
Easy,
These 2 lines need to change from:
Dim grpItem As Shape
Dim shp As Shape
to:
Dim grpItem As Powerpoint.Shape
Dim shp As Powerpoint.Shape
Should do the trick.