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
Related
I've written some code that formats text. The code doesn't work if user has put the cursor in a shape that is part of a group of shapes, the solution for which is to ungroup the shapes.
I want to regroup the shapes after executing the formatting code.
I am able to store the underlying shapes as objects, as well as their names. But, the normal approach to grouping (using shape names) doesn't work, because there can be multiple instances of those shape names on a given slide. E.g. this doesn't work as there could be multiple instances of "textbox" on the slide:
Set TempShapeGroup = TempSlide.Shapes.Range(Array("textbox", "header", "separator")).Group
https://learn.microsoft.com/en-us/office/vba/api/powerpoint.shaperange.group
But, I have the shape objects stored in an array, the crux of which is this (the object 'TempShape' is the group of shapes):
Dim ShapesArray() As Shape
ReDim ShapesArray(1 To TempShape.GroupItems.Count)
For i = 1 To TempShape.GroupItems.Count
Set ShapesArray(i) = TempShape.GroupItems.Item(i)
Next i
So, what I want to do is recreate the group of shapes, using the array of shape objects, so something to the effect of the below would be ideal:
Set MyShapesGroup= ShapesArray.Group
But any way to group shapes using Shape objects would be fine.
TIA
Here's some starter code that you can modify into a function that'll return a reference to the paragraph that contains the current selection cursor. It doesn't really need all the debug.print stuff, of course, but that might help to illustrate the object hierarchy:
Sub WhereIsTheCursor()
Dim oRng As TextRange
Dim oParentRange As TextRange
Dim x As Long
Dim lSelStart As Long
Dim lSelLen As Long
With ActiveWindow.Selection.TextRange
' find the selection start relative to first character in shape
lSelStart = .Start
' lSelLen = .Length
Debug.Print TypeName(.Parent)
Debug.Print TypeName(.Parent.Parent)
Debug.Print TypeName(.Parent.Parent.Parent)
Debug.Print .Paragraphs.Count
Set oRng = .Characters(.Start, .Length)
Debug.Print oRng.Text
' Reference the overall shape's textrange
Set oParentRange = .Parent.Parent.TextFrame.TextRange
' For each paragraph in the range ...
For x = 1 To oParentRange.Paragraphs.Count
' is the start of the selection > the start of the paragraph?
If lSelStart > oParentRange.Paragraphs(x).Start Then
' is the start < the start + length of the paragraph?
If lSelStart < oParentRange.Paragraphs(x).Start _
+ oParentRange.Paragraphs(x).Length Then
' bingo!
MsgBox "The cursor is in paragraph " & CStr(x)
End If
End If
Next
End With
End Sub
Not sure I'm completely understanding the problem, but this may help:
If the user has selected text within a shape, it doesn't really matter whether the shape is part of a group or not. You may need to test the .Selection.Type and handle things differently depending on whether the .Type is text or shaperange. Example:
Sub FormatCurrentText()
If ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange
.Font.Name = "Algerian"
End With
End If
End Sub
After selecting a shape (f.e. square or more squares) all the connectors glued to this shape would highlight red, yellow whatever.
The found code below is not working for me, any advice? (I am not coder, so please have patience with me)
Set shpAtEnd = cnx(1).ToSheet
' use HitTest to determine whether Begin end of connector
' is outside shpAtEnd
x = shpAtEnd.HitTest(shpTaskLink.Cells("BeginX"), _
shpTaskLink.Cells("BeginY"), 0.01)
If x = visHitOutside Then
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 2
Else
' do other stuff
End If
This is my first answer on stackoverflow and I hope the following VBA code can solve your problem on how to highlight connectors or connected shapes in Visio!
Public Sub HighlightConnectedShapes()
Dim vsoShape As Visio.Shape
Dim connectedShapeIDs() As Long
Dim connectorIDs() As Long
Dim intCount As Integer
' Highlight the selected shape
Set vsoShape = ActiveWindow.Selection(1)
vsoShape.CellsU("Fillforegnd").FormulaU = "RGB(146, 212, 0)"
vsoShape.Cells("LineColor").FormulaU = "RGB(168,0,0)"
vsoShape.Cells("LineWeight").Formula = "2.5 pt"
' Highlight connectors from/to the selected shape
connectorIDs = vsoShape.GluedShapes _
(visGluedShapesAll1D, "")
For intCount = 0 To UBound(connectorIDs)
ActivePage.Shapes.ItemFromID(connectorIDs(intCount)).Cells("LineColor").FormulaU = "RGB(168,0,0)"
ActivePage.Shapes.ItemFromID(connectorIDs(intCount)).Cells("LineWeight").Formula = "2.5 pt"
Next
' Highlight shapes that are connected to the selected shape
connectedShapeIDs = vsoShape.connectedShapes(visConnectedShapesAllNodes, "")
For intCount = 0 To UBound(connectedShapeIDs)
ActivePage.Shapes.ItemFromID(connectedShapeIDs(intCount)).Cells("LineColor").FormulaU = "RGB(168,0,0)"
ActivePage.Shapes.ItemFromID(connectedShapeIDs(intCount)).Cells("LineWeight").Formula = "2.5 pt"
Next
End Sub
To run the macro, you can consider associating with double-click behavior of shapes.
If you only need to highlight incoming/outgoing connectors and incoming/outgoing shapes, replace visGluedShapesAll1D with visGluedShapesIncoming1D/visGluedShapesOutgoing1D and visConnectedShapesAllNodes with visConnectedShapesIncomingNodes/visConnectedShapesOutgoingNodes.
Learn more at visgluedshapesflags and visconnectedshapesflags. Good luck!
The following code will loop though all 1d-Shapes glued to the first shape in your Selection and write their name to the Immediate window. This should be a good starting point.
Visio has no Event that fires if a Shape is selected (at least not without some workarounds), so maybe bind the macro to a keybind.
The visGluedShapesAll1D flag can be replace with another filter as described here: Microsoft Office Reference
Sub colorConnectors()
If ActiveWindow.Selection(1) Is Nothing Then Exit Sub
Dim selectedShape As Shape
Set selectedShape = ActiveWindow.Selection(1)
Dim pg As Page
Set pg = ActivePage
Dim gluedConnectorID As Variant 'variant is needed because of "For Each" Loop
For Each gluedConnectorID In selectedShape.GluedShapes(visGluedShapesAll1D, "")
Debug.Print pg.Shapes.ItemFromID(gluedConnectorID).NameU
Next gluedConnectorID
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...
In Microsoft Visio Professional 2010 I've isolated the error I've been getting to this little code snippet. On the page is a container holding 2 shapes and I want to iterate through those shapes within another loop. But I keep getting an invalid parameter error.
My attempt at a solution is the top block, but it only works with the same definition for the inner loop. It seems like something is changing during the 2nd iteration of the outer loop, but I'm not sure. I feel it has to do with the way a For Each loop is defined.
Sub Nested_Loop_Error()
Dim a As Variant
Dim b As Variant
Dim lngs() As Long
'This Works
lngs = ActiveDocument.Pages(1).Shapes.ItemFromID(1).ContainerProperties.GetMemberShapes(visContainerFlagsDefault)
For a = 0 To 1
For Each b In lngs
'Do nothing
Next b
Next a
'This does not work
For a = 0 To 1
For Each b In ActiveDocument.Pages(1).Shapes.ItemFromID(1).ContainerProperties.GetMemberShapes(visContainerFlagsDefault)
MsgBox "In Loop for a=" & a
Next b
Next a
End Sub
Edit:
I've been playing around with it and got it to work, but what I'm really interested in is why it works. The 2nd block of code fails when a=1, giving an invalid parameter in the line docMyDoc.Pages...
The following is the code showing the difference of using a variant or a document variable to define the ActiveDocument within the loop. Using the debugger I can't see a difference in how docMyDoc or varMyDoc are defined.
Sub Nested_Loop_Error2()
Dim a As Variant
Dim b As Variant
Dim docMyDoc As Visio.Document
Dim varMyDoc As Variant
'This works
For a = 0 To 1
Set varMyDoc = ActiveDocument
For Each b In varMyDoc.Pages(1).Shapes.ItemFromID(1).ContainerProperties.GetMemberShapes(visContainerFlagsDefault)
MsgBox "Using variant, a=" & a
Next b
Next a
'This does not work
For a = 0 To 1
Set docMyDoc = ActiveDocument
For Each b In docMyDoc.Pages(1).Shapes.ItemFromID(1).ContainerProperties.GetMemberShapes(visContainerFlagsDefault)
MsgBox "Using document, a=" & a
Next b
Next a
End Sub
Using the Variant type doesn't help the compiler much: The variable called "b" should be of type Long, and the "a" variable of type Integer.
This said, you're not using the "a" variable but to repeat twice what you do in the inner loop (Msgbox), but nothing else changes.
Moreover, you need to reference the shape whose ID is b, that you're not doing.
And another tip: don't name variables after their type, but after their semantics.
I think that what you intended to do is something like the example in GetMemberShapes method's reference in MSDN:
Sub Nested_Loop()
Dim lngMemberID as Long
Dim vsoShape as Visio.Shape
Dim j as Integer
For j = 0 to 1
For Each lngMemberID In ActiveDocument.Pages(1).Shapes(1).ContainerProperties.GetMemberShapes(visContainerFlagsDefault)
Set vsoShape = ActivePage.Shapes.ItemFromID(memberID)
Debug.Print vsoShape.ID
Next lngMemberID
Next j
End Sub
Here, your vsoShape variable will refer first to one, then to the other of your shapes. And it will work even if you have more shapes in your page.
That's the good thing of Collections and the For Each loop: Collections are special objects made up as a list of other objects. They have their own methods, as Item, or Count, and shortcuts, like using a number between parenthesis to retrieve an individual object from the collection (as in Pages(1)).
What you do with For Each is to iterate through all the objects in the collection (or all the values in an array).
For your purposes, I'd try the following general structure:
dim oPage as Visio.Page
dim oShape as Visio.Shape
dim oInnerShape as Visio.Shape
For each oPage In ActiveDocument.Pages
For each oShape in oPage.Shapes
If oShape.Master.Name = "xxx" Then ' You can check the type of the shape
For each oInnerShape In oShape
' set and compute width and height
Next oInnerShape
' set and compute width and height of the containing shape
End If
Next oShape
' Rearrange shapes
Next oPage
You can construct an array storing the shape IDs, width and height, while iterating through the shapes, then use that array to rearrange the shapes.
Regards,
I don't have Visio on my computer but are you certain that the first nested loop worked?
I have doubt in lngs = ActiveDocument.Pages(1)... with Dim lngs() As Long:
Excel VBA will throw "Type mismatch" error with trying to store arr = Array(1,2) with Dim arr() As Long. Better off Dim lngs As Variant even if you know it's an array of Long being returned.
The second nested loop works in theory.