I'm trying to change text in a SmartArt. Specifically this type:
I can replicate the Minimum Working Example below on two machines.
This code enters the .HasText = msoTrue branch even though the debugger says that .HasText = 0. This causes shi.TextFrame.TextRange.Text to fail.
Sub enumerate_subshapes(shi As Shape, Optional depth As Integer = 0)
'If True Then
If shi.HasTextFrame Then
If shi.TextFrame.HasText Then
Debug.Print depth & " YES: ", shi.Type, shi.HasTextFrame, shi.TextFrame.HasText, shi.TextFrame.TextRange.Text
Else
Debug.Print depth & " NO: ", shi.Type, shi.HasTextFrame, shi.TextFrame.HasText
End If
End If
Select Case shi.Type
Case msoSmartArt
For i = 1 To shi.GroupItems.Count
enumerate_subshapes shi.GroupItems.Item(i), depth + 1
Next i
End Select
End Sub
Sub vba_bug_mwe()
Dim shi As Shape
For Each shi In ActivePresentation.Slides(1).Shapes
Debug.Print "############### " & shi.Name
enumerate_subshapes shi
Next
End Sub
If you uncomment the If true then line and comment the If shi.HasTextFrame Then line, then you get the expected result, i.e., the inner test works correctly.
It looks like a bug to me, TBH, in which case it doesn't really belong here. But maybe there is some VBA subtlety I'm missing.
A piece of SmartArt is a nested group of shapes. You need to drill down to individual subshapes to get any useful information. You haven't stated your overall goal with this, but here's how to get the text from each node:
Sub GetSmartArtNodeText()
Dim oShape As Shape
Dim oNode As SmartArtNode
For Each oShape In ActivePresentation.Slides(1).Shapes
If oShape.HasSmartArt = True Then
For Each oNode In oShape.SmartArt.Nodes
MsgBox oNode.TextFrame2.TextRange.Text
Next oNode
End If
Next oShape
End Sub
Related
I am migrating a lot of old presentations to a new design using VBA. I have created the new file from a template, copied each slide across and applied the correct custom layout that I need to each one. Once done, I am left with a load of the old custom layouts that are not used, and want to delete them all. The new design uses 50 custom layouts. Is there a way to find the ones after that 50 and delete them? Or delete all layouts after a layout of a specific name?
Here is the code I'm using at the moment. This doesn't remove them all, for some reason. Any help is welcome.
Dim colUsedLayouts As New Collection
For Each sld In NewPres.Slides
colUsedLayouts.Add sld.CustomLayout
Next
Dim UsedLayout As CustomLayout
Dim LayoutHasBeenUsed As Boolean
Dim EndPointLogoFound As Boolean
For Each lay In NewPres.Designs(1).SlideMaster.CustomLayouts
If Trim(LCase(lay.name)) = "blank no logo" Then 'Used the else statement so it doesn't delete the Blank No logo layout
EndPointLogoFound = True
Else
If EndPointLogoFound Then
LayoutHasBeenUsed = False
For Each UsedLayout In colUsedLayouts
If UsedLayout Is lay Then
LayoutHasBeenUsed = True
End If
Next
If Not LayoutHasBeenUsed Then
lay.Delete
End If
End If
End If
Next
PowerPoint doesn't really track the order of slide layouts, so trying to delete layouts after a certain one isn't reliable. I would go by the layout name. Create a Select Case statement based on the layout name. In the first Case statement, place the names of all 50 good layouts. This Select Case statement will have no commands. Then create a Case Else statement that deletes any layout not found in in the first:
Select Case lay.name
Case "Title Slide", "Title and Content", "Comparison" 'etc. place all 50 names
'do nothing
Case Else
lay.Delete
End Select
When deleting things from a collection (slides, shapes, layouts, whatever), you need to step through the collection in reverse order otherwise you end up with this situation:
You delete the first one.
The second item in the collection is now item 1, so when you move to the second item and delete it, you're actually deleting what WAS item 3, leaving what WAS item 2 alone.
Instead:
For x = Collection.Count to 1 step -1
Collection(x).Delete
Next
In this case, you'd use Designs in place of Collection.
This macro deletes any unused custom layouts in a presentation, provided they are not set to "Preserved":
Sub RemoveUnusedCustomLayouts(newPres As Presentation)
On Error GoTo RemoveUnusedCustomLayouts_Error
Dim oLayout As CustomLayout
Dim tLayout As CustomLayout
Dim oSld As Slide
Dim delLayoutCnt As Integer
Dim delLayoutArray() As CustomLayout
Dim layoutUsed As Boolean
Dim i As Integer
delLayoutCnt = 0
' We're assuming the deck only has one slide master.
' This sub is only called by other subs that have already
' collapsed the deck into one slide master.
ReDim delLayoutArray(newPres.SlideMaster.CustomLayouts.Count)
For Each oLayout In newPres.SlideMaster.CustomLayouts
layoutUsed = False
If oLayout.Preserved = msoFalse Then
' Can't delete a layout if it's in use, so we check
' for that and add any unused, un-preserved layouts
' to Delete array.
For Each oSld In newPres.Slides
If oSld.CustomLayout.Name = oLayout.Name Then
layoutUsed = True
Exit For
End If
Next
If layoutUsed = False Then
delLayoutCnt = delLayoutCnt + 1
Set delLayoutArray(delLayoutCnt) = oLayout
End If
End If
Next
If delLayoutCnt > 0 Then
For i = 1 To delLayoutCnt
Set tLayout = delLayoutArray(i)
tLayout.Delete
Next
End If
On Error GoTo 0
Exit Sub
RemoveUnusedCustomLayouts_Error:
Debug.Print "Error " & Err.Number & " (" & Err.Description & ") in procedure RemoveUnusedCustomLayouts, line " & Erl & "."
End Sub
Every CustomLayout in a Design must have a unique name (this is why you'll often see "Title and Content_2" in a bloated deck), so checking against the CustomLayout name is the best way to get at the ones you want to delete.
this is going to be easy for any VBA expert out there so, apologies for the novice question! I have a code to condense text into a text box. At the moment the code condensed all the text inside the text box but I want the code to work for selected text only. How can I modify this code to make it work?
Many thanks on advance!
PJ
Sub CondenseText()
On Error GoTo Catch
Dim o As Shape, b As Boolean
Set o = ActiveWindow.Selection.ShapeRange(1)
If Not o Is Nothing Then
With o
.TextFrame2.TextRange.Font.Spacing = .TextFrame2.TextRange.Font.Spacing - 0.1
End With
End If
Exit Sub
Catch:
If Err.Number = -2147188160 Then MsgBox CG_NOTHING_SELECTED
End Sub
Sub CondenseText()
Dim oTextRange2 As TextRange2
' You can check Selection.Type rather than relying
' on an errorhandler if you like
If ActiveWindow.Selection.Type = ppSelectionText Then
Set oTextRange2 = ActiveWindow.Selection.TextRange2
If Not oTextRange2 Is Nothing Then
oTextRange2.Font.Spacing = oTextRange2.Font.Spacing - 0.1
End If
' and you could add an Else clause with msg for the
' user here if you like:
Else
MsgBox "Yo! Select some text first, OK?"
End If
End Sub
I would like to build a condition on a command button on a Macro enabled powerpoint presentation. If the shape exists then I would like it deleted, otherwise the button should produce a statement about the fact that there is no such shape. Currently I am having trouble with existence...! How do I get Power point to recognise the shape is null? Here is my code:
If ActivePresentation.Slides(3).Shapes("Picture") Is Nothing Then
MsgBox "no Picture"
Else
ActivePresentation.Slides(3).Shapes("Picture").Delete
MsgBox "Picture Cleared"
End If
This code only produces an error because the shape doesn't exist so the first if statement fails. Perhaps we need to check whether its in the selection pane?
Some of the other suggestions will work but in general, it's bad practice to rely on selection unless absolutely necessary. Instead, you could call a slightly different function:
Function ShapeExists(ByVal oSl as Slide, ByVal ShapeName as String) as Boolean
Dim oSh as Shape
For Each oSh in oSl.Shapes
If oSh.Name = ShapeName Then
ShapeExists = True
Exit Function
End If
Next ' Shape
' No shape here, so though it's not strictly necessary:
ShapeExists = False
End Function
You could also modify this to return a reference to the shape if found or nothing if not.
If you prefer not to use early Exit Functions, there are easy ways to write around that.
As #davidmneedham gives in the link in the comments (#TimWilliams answer), you can use a construct similar to as follows:
Option Explicit
Sub test()
Dim shp As Shape
Dim myshapeName As String
myshapeName = "Picture"
Dim sl As Slide
Set sl = ActivePresentation.Slides(1)
If shapePresent(sl, myshapeName) Then
sl.Shapes(myshapeName).Delete
Else
MsgBox myshapeName & " not present"
End If
End Sub
Private Function shapePresent(ByVal sl As Slide, ByVal myshapeName As String) As Boolean
On Error GoTo errhand
sl.Shapes(myshapeName).Select
shapePresent = True
Exit Function
errhand:
shapePresent = False
Err.Clear
End Function
Using the same format as that answer:
Private Function shapePresent(ByVal sl As Slide, ByVal myshapeName As String) As Boolean
Dim myShape As Shape
On Error Resume Next
Set myShape = sl.Shapes(myshapeName)
On Error GoTo 0
shapePresent = Not myShape Is Nothing
End Function
Does anyone have any idea why this is not working in publisher? There's very little documentation on it aside from msdn, and I can't figure it out. Every time I run it, it just says "Publisher Cannot link to this textbox".
Is there maybe some property I have to set to true first? Is that a common requirement in vba and other programming languages?
Option Compare Text
**Sub LinkTextBoxes()**
Dim shpTextBox1 As Shape
Dim shpTextBox2 As Shape
oAPIndex = ActiveDocument.ActiveView.ActivePage.PageIndex
Set shpTextBox1 = FindTB1(ActiveDocument.Pages(oAPIndex))
Set shpTextBox2 = FindTB1(ActiveDocument.Pages(oAPIndex + 1))
If shpTextBox1 Is Nothing Or shpTextBox2 Is Nothing Then
MsgBox ("Textbox missing!" & vbLf & vbLf & "No can do!")
Exit Sub
End If
shpTextBox1.TextFrame.NextLinkedTextFrame = shpTextBox2.TextFrame
ActiveDocument.ActiveView.ActivePage = ActiveDocument.Pages(oAPIndex + 1)
End Sub
**Function FindTB1(oPage As Page) As Shape**
Dim oShape As Shape
Dim oFoundShape As Shape
For Each oShape In oPage.Shapes
If oShape.AlternativeText Like "*Text*" Then
Set oFoundShape = oShape
GoTo Found
End If
Next
Found:
If oFoundShape Is Nothing Then
MsgBox ("Text Box not found on page: " & oPage.PageNumber)
Set FindTB1 = Nothing
Else
Set FindTB1 = oFoundShape
End If
End Function
Sorry guys, figured it out I think... Missed a line on msdn:
https://msdn.microsoft.com/en-us/library/office/ff940597.aspx
says it will be invalid if the shape already contains text.
Looks I might have to erase the text and repaste it or something similar first...
I have a very long ppt presentation (about 850 slides) and the second half is full of shapes with certain text that I would like to delete. Sadly, it appears that is has nothing to do with the Slide Master, so I can't use that.
I got an error:
Run-time error '-2147024809 (80070057)':
The specified value is out of range
Here's the code, I got at the moment
Sub DeleteShapeWithSpecTxt()
Dim oSl As Slides, oSh As Shapes, oTr As TextRange
Dim str As String
Dim testcomp1, testcomp2
Dim lppt, ShapeNb, k, j As Long
Dim pptAct
Set pptAct = PowerPoint.ActivePresentation
str = pptAct.Slides(335).Shapes(4).TextFrame.TextRange.Text
lppt = pptAct.Slides.Count
For k = 1 To lppt
ShapeNb = pptAct.Slides(k).Shapes.Count
For j = 1 To ShapeNb
If pptAct.Slides(k).Shapes(j).HasTextFrame And StrComp(str, pptAct.Slides(k).Shapes(j).TextFrame.TextRange.Text) = 0 Then
pptAct.Slides(k).Shapes(j).Delete
End If
Next
Next
End Sub
There are several reasons this code could raise an error. Firstly, if slide 335 or shape 4 doesn't exist (try to make those numbers dynamic or handle errors). Next, your If line will evaluate both parts so if the shape doesn't have a TextFrame, VBA will still try to evaluate the second part and hence raise an error. Finally, you also need to count backwards in any object collection that you may delete objects. You could also simplify this using the For Each Next construct and optionally pass the search text to the procedure from your main code:
Sub DeleteShapeWithSpecTxt(Optional sSearch As String)
Dim oSld As Slide
Dim oShp As Shape
Dim lShp As Long
On Error GoTo errorhandler
If sSearch = "" Then sSearch = ActivePresentation.Slides(335).Shapes(4).TextFrame.TextRange.Text
For Each oSld In ActivePresentation.Slides
' I would usually use the next line to loop through all shapes on the slide but can't in this case as shapes may be deleted
'For Each oShp In oSld.Shapes
For lShp = oSld.Shapes.Count To 1 Step -1
With oSld.Shapes(lShp)
If .HasTextFrame Then
If StrComp(sSearch, .TextFrame.TextRange.Text) = 0 Then .Delete
End If
End With
Next
Next
Exit Sub
errorhandler:
Debug.Print "Error in DeleteShapeWithSpecTxt : " & Err & ": " & Err.Description
On Error GoTo 0
End Sub
If you want to make the search text dynamic, this is a nice simple method. Just replace the If sSearch = ""... line with this:
If sSearch = "" Then sSearch = InputBox("Enter test to search for and all shapes matching the text will be deleted across this presentation:","Delete Matching Shapes","test")
#JamieG Thank you, I found the same solutions (but not as neat as your code). I was going to post it when I saw your answer
Cheers
EDIT: More precision: The dynamic setting of the string was kind of difficult (my knowledge of VBA isn't very advanced). For that reason it was a lot easier for me to select the text in a certain slide/shape.
The comment on IF was on point, as well as the backwards counting when deleting