Can't quite figure out what's going wrong here.
I get a object variable not set for the last debug.print line.
N.B - the debug.print line in the loop prints fine and there are three shaped that should be in the array (and i is at 3 at the end of the loop).
I think I may just not understand exactly how arrays / variable setting works, I'm new to VBA (I do have programming experience though).
Dim allShapes As Shapes
Set allShapes = ActivePresentation.Slides(11).Shapes
Dim textShapes() As Shape
ReDim textShapes(0 To 2)
i = 0
For Each thisShape In allShapes
If thisShape.HasTextFrame Then
If thisShape.TextFrame.HasText Then
Debug.Print thisShape.TextFrame.TextRange.Text
Set textShapes(i) = thisShape
i = i + 1
ReDim textShapes(0 To i) As Shape
End If
End If
Next thisShape
ReDim textShapes(0 To i - 1)
Debug.Print textShapes(1).TextFrame.TextRange.Text
For Each thisShape In allShapes
What is allShapes? Is it declared somewhere?
Also to preserve the shapes in the array you have to use Redim Preserve
Is this what you are trying? This loops thorough all the shapes in Slide 1.
Sub Sample()
Dim textShapes() As Shape, i as Long
ReDim textShapes(0 To 2)
i = 0
For Each thisShape In ActivePresentation.Slides(1).Shapes
If thisShape.HasTextFrame Then
If thisShape.TextFrame.HasText Then
Set textShapes(i) = thisShape
i = i + 1
ReDim Preserve textShapes(0 To i) As Shape
End If
End If
Next thisShape
Debug.Print textShapes(1).TextFrame.TextRange.Text
End Sub
Also as the title of the question say Get all shapes with text; In such a case you will have to loop through the array. to get all shapes with text.
Related
How do I group all objects (or "shapes"?) on a slide and resize that group?
Subsequently the "big" group should be ungrouped.
My attempt fails with "function expected":
Sub Group_And_Resize()
Dim Sld As Slide
With Sld.Shapes
With .SelectAll.Group //Error here
.Width = 907
End With
End With
End Sub
By manual experimentation, I learned that some objects (or "shapes"?) cannot be added to a group, such as slide numbers which are automatically generated. Is there any possibility to exclude those from the selection?
If you want to group the shapes together first and then set the overall width to 907, you can use this code:
Sub Group_And_Resize()
Dim Sld As Slide, a As Variant, i As Integer
Set Sld = ActivePresentation.Slides(1) ' your slide
ReDim a(1 To Sld.Shapes.Count)
For i = LBound(a) To UBound(a)
a(i) = Sld.Shapes(i).Name
Next
Sld.Shapes.Range(a).Group.Width = 907
End Sub
If you want to make the width of each of the shapes on the slide = 907, you can use the following code:
Sub Group_And_Resize()
Dim Sld As Slide
Set Sld = ActivePresentation.Slides(1) ' your slide
Sld.Shapes.Range.Width = 907
End Sub
This is based on Алексей Р's answer but solves a few problems and also is more generic. It allows calling the routine on any slide in the active presentation and setting the width to any desired value. See comments for more details.
Sub Test()
With ActivePresentation
Call Group_And_Resize(.Slides(1), 200)
End With
End Sub
Sub Group_And_Resize(Sld As Slide, sngWidth As Single)
Dim a As Variant, i As Long ' Array indices are longs, not integers
Dim oGroup As Shape
' Call NonPlaceholderShapeCount to get number of
' shapes that are not placeholders, since placeholders
' cannot be grouped. Use that to ReDim the array:
ReDim a(1 To NonPlaceholderShapeCount(Sld))
For i = LBound(a) To UBound(a)
' Again, make sure we don't try to group placeholders
If Not Sld.Shapes(i).Type = msoPlaceholder Then
a(i) = Sld.Shapes(i).Name
End If
Next
' Get a reference to the new group
' since we need to set several properties on it
Set oGroup = Sld.Shapes.Range(a).Group
' This ensures that the group (and its shapes)
' aren't distorted:
oGroup.LockAspectRatio = True
' and finally, set the width
oGroup.Width = sngWidth
End Sub
Function NonPlaceholderShapeCount(Sld As Slide) As Long
' Returns the number of non-placeholder shapes on Sld
Dim x As Long
Dim lCount As Long
With Sld
For x = 1 To .Shapes.Count
If Not .Shapes(x).Type = msoPlaceholder Then
lCount = lCount + 1
End If
Next
End With
NonPlaceholderShapeCount = lCount
End Function
I am working on a landscape diagram that has many shapes. I am trying to do following in a slide that has many shapes by selecting all the shapes at once (Ctrl + A) and perform grouping. If I do this manually by selecting the inbuilt group function present in PowerPoint, the shapes (red and yellow boxes) are not grouped, instead all four boxes are grouped as bunch.
I am trying to achieve the following: (Taking reference of example attached)
Select all 4 shapes
when macro is run, the boxes should be grouped (i.e yellow and red shapes should be paired as well as green and blue shapes)
Following is the code I tried for achieving this. But, only first two shapes in the selection were grouped where as other two are not.
Sub Grouping2()
Dim V As Long
Dim oSh1 As Shape
Dim oSh2 As Shape
Dim Shapesarray() As Shape
Dim oGroup As Shape
Dim oSl As Slide
Call rename
On Error Resume Next
If ActiveWindow.Selection.ShapeRange.Count < 2 Then
MsgBox "Select at least 2 shapes"
Exit Sub
End If
ReDim Shapesarray(1 To ActiveWindow.Selection.ShapeRange.Count)
For V = 1 To ActiveWindow.Selection.ShapeRange.Count
Set oSh1 = ActiveWindow.Selection.ShapeRange(V)
Set oSh2 = ActiveWindow.Selection.ShapeRange(V + 1)
If ShapesOverlap(oSh1, oSh2) = True Then
Set Shapesarray(V) = oSh1
Set Shapesarray(V + 1) = oSh2
' group items in array
ActivePresentation.Slides(1).Shapes.Range(Array(oSh1.Name, oSh2.Name)).Group
'else move to next shape in selction range and check
End If
V = V + 1
Next V
End Sub
Sub rename()
Dim osld As Slide
Dim oshp As Shape
Dim L As Long
Set osld = ActiveWindow.Selection.SlideRange(1)
For Each oshp In osld.Shapes
If Not oshp.Type = msoPlaceholder Then
L = L + 1
oshp.Name = "myShape" & CStr(L)
End If
Next oshp
End Sub
In the first loop iteration, when the first two shapes are grouped, all of the shapes get de-selected. And so in your subsequent loop, you would have received an error, but since you enabled error handling with On Error Resume Next without disabling it afterwards, the error is hidden.
Error Handling After you've enabled error handling and tested whether more than one shape has been selected, you should disable it. Should you need it at some point, it can be enabled again.
On Error Resume Next
If ActiveWindow.Selection.ShapeRange.Count < 2 Then
MsgBox "Select at least 2 shapes"
Exit Sub
End If
On Error GoTo 0
Array Assignment Assign each of the selected shapes to an element within the array.
Dim Shapesarray() As Shape
ReDim Shapesarray(1 To ActiveWindow.Selection.ShapeRange.Count)
Dim V As Long
For V = 1 To ActiveWindow.Selection.ShapeRange.Count
Set Shapesarray(V) = ActiveWindow.Selection.ShapeRange(V)
Next V
Grouping Loop through the array, test whether the shapes within each pair overlap, and then make sure that neither are already part of a group.
For V = LBound(Shapesarray) To UBound(Shapesarray) - 1
If ShapesOverlap(Shapesarray(V), Shapesarray(V + 1)) Then
If Not Shapesarray(V).Child And Not Shapesarray(V + 1).Child Then
ActiveWindow.View.Slide.Shapes.Range(Array(Shapesarray(V).Name, Shapesarray(V + 1).Name)).Group
End If
End If
Next V
The complete code would be as follows...
Sub Grouping2()
'Call rename
On Error Resume Next
If ActiveWindow.Selection.ShapeRange.Count < 2 Then
MsgBox "Select at least 2 shapes"
Exit Sub
End If
On Error GoTo 0
Dim Shapesarray() As Shape
ReDim Shapesarray(1 To ActiveWindow.Selection.ShapeRange.Count)
Dim V As Long
For V = 1 To ActiveWindow.Selection.ShapeRange.Count
Set Shapesarray(V) = ActiveWindow.Selection.ShapeRange(V)
Next V
For V = LBound(Shapesarray) To UBound(Shapesarray) - 1
If ShapesOverlap(Shapesarray(V), Shapesarray(V + 1)) Then
If Not Shapesarray(V).Child And Not Shapesarray(V + 1).Child Then
ActiveWindow.View.Slide.Shapes.Range(Array(Shapesarray(V).Name, Shapesarray(V + 1).Name)).Group
End If
End If
Next V
End Sub
In VBA, it's possible to loop through shapes. For example:
For Each shp In slide.Shapes
shp.top=0
Next
The question is, which parameter is being used to determine the order of the loop and how can this parameter be set?
edited after OP's clarification about his need of looping through shapes from the highest on the lowest
you can use SortedList object use Shape Top property as the SortedList key and the Shape object itself as its corresponding value:
Sub Main()
Dim shp As Shape
Dim j As Long
With CreateObject("System.Collections.SortedList")
For Each shp In slide.Shapes
.Add shp.Top, shp
Next
For j = 0 To .Count - 1 'list shapes from the highest to the lowest
MsgBox .GetByIndex(j).Name & " - " & .getkey(j)
Next
End With
End Sub
I found the answer on the MicroSoft site:
Shape.ZOrderPosition Property (PowerPoint)
The site says "A shape's position in the z-order corresponds to the shape's index number in the Shapes collection.".
I then did a short sort routine to set the z-order position based on the .top parameter of the shape:
For i = 2 To sld.Shapes.Count
If sld.Shapes(i).Top < sld.Shapes(i - 1).Top _
and sld.Shapes(i).ZOrderPosition > sld.Shapes(i - 1).ZOrderPosition Then_
sld.Shapes(i).ZOrder msoSendBackward
Next i
I've successfully added shapes into cells (msoShapeOval) in a pivot table. I need to clear and recreate these shapes if the pivot / slicer selection changes. My current method works, but it is slow. Is there any better method to clear shapes in bulk? Note: I do know the exact cell range where all these shapes exist. I've also appied :
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Current code:
Dim Shp as Shape
For Each Shp In rng.Parent.Shapes
If InStrB(Shp.Name, "$") > 0 Then Shp.Delete
Next
It is possible to delete the shapes at once without selecting, with some fine tuning. Let's imagine you want to delete the rectangulars from this:
What you need to do is the following:
loop through all the objects
make an array with all the rectangular's names
delete the objects in the array
Tricky part is the looping through the objects, because you need to increment your array every time, which is not a built-in functionality (like in collection). incrementArray is the function for this.
Furthermore, the first time you increment to the unassigned array, you need to check whether it is allocated (achieved with the IsArrayAllocated function below).
Option Explicit
Sub TestMe()
Dim shp As Shape
Dim arrOfShapes() As Variant 'the () are important!
With ActiveSheet
For Each shp In .Shapes
If InStrB(shp.Name, "Rec") > 0 Then
arrOfShapes = incrementArray(arrOfShapes, shp.Name)
End If
Next
If IsArrayAllocated(arrOfShapes) Then
Debug.Print .Shapes.Range(arrOfShapes(0)).Name
.Shapes.Range(arrOfShapes).Delete
End If
End With
End Sub
The additional functions:
Public Function incrementArray(arrOfShapes As Variant, nameOfShape As String) As Variant
Dim cnt As Long
Dim arrNew As Variant
If IsArrayAllocated(arrOfShapes) Then
ReDim arrNew(UBound(arrOfShapes) + 1)
For cnt = LBound(arrOfShapes) To UBound(arrOfShapes)
arrNew(cnt) = CStr(arrOfShapes(cnt))
Next cnt
arrNew(UBound(arrOfShapes) + 1) = CStr(nameOfShape)
Else
arrNew = Array(nameOfShape)
End If
incrementArray = arrNew
End Function
Function IsArrayAllocated(Arr As Variant) As Boolean
On Error Resume Next
IsArrayAllocated = IsArray(Arr) And _
Not IsError(LBound(Arr, 1)) And _
LBound(Arr, 1) <= UBound(Arr, 1)
End Function
Credits to this guy for the finding that the arrOfShapes should be declared with parenthesis (I have spent about 30 minutes researching why I could not pass it correctly) and to CPearson for the IsArrayAllocated().
To delete all shapes except slicers:
Sub RemoveAllExceptSlicers()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If Not sh.Type = MsoShapeType.msoSlicer Then
sh.Delete
End If
Next
End Sub
Sub Driver()
'Highlights driver who have 1 point
Dim driverData ' array variable to hold driver names
driverData = Range("C2:C391").Value
ReDim driverData(390)
MsgBox driverData(3)
Though Range("C2:C391") has values in the worksheet, the array seems to be having only blanks
So, using the MsgBox command, only a blank appears
When you use just ReDim you clober all the contents in the array. You need to use ReDim Preserve to keep elements that are in the array.
That being said, the you can't simply redim a 2D array into a 1D array. You can do this:
Sub test()
Dim driverData As Variant
Dim newArray() As String
driverData = Range("C2:C391").Value
ReDim newArray(1 To UBound(driverData, 1))
For i = 1 To UBound(driverData)
newArray(i) = driverData(i, 1)
Next
MsgBox newArray(3)
End Sub
You can;
Dim driverData as Variant
driverData = Range("C2:C391")
msgbox driverData(3, 1)
(As you have it, you cannot assign a Range.value to an array, and even if you could the ReDim would erase its contents)