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
Related
I hope this is a super simple question but for some reason i cant figure it out.
I need to delete a subset of the selected shapes on a powerpoint slide using VBA. I can do this using:
ActivePresentation.Slides(1).Shapes.Range(_Index_).Delete
Where _Index_ is either an array of shape indexes (integers) or shape names (stings).
Since the shape names are not unique (and people i am making this macro for have a nasty habit of having multiple shapes with the same name) i need to rely on the shape index number. My problem is i dont know how to get the index number of a given shape.
I can only see how i get the shape name or shape ID using:
ActiveWindow.Selection.ShapeRange(IdNum).Name
ActiveWindow.Selection.ShapeRange(IdNum).ID
So my question is: How do i get the shape index of selected shapes?
When you group a selection of shapes, the group becomes a new shape appended to the end of the previous z-order position. All of the individual shapes within the group are appended to the z-order after the group shape itself.
I can't find a way of determining which individual item within a group is selected (sub-selected, I guess we should say, since the original parent group remains selected and that's what PPT returns when you query ActiveWindow.Selection.ShapeRange(1).
To identify the currently subselected item within a group, you can use this as a starting point:
Sub WorkWithSubSelectedShapes()
' Do stuff with sub-selected shapes within a group
' Courtesy of Andy Pope
Dim oSh As Shape
Dim oGSh As Shape
Dim x As Long
Set oSh = ActiveWindow.Selection.ShapeRange(1)
' Do something with each shape in the group:
For Each oGSh In oSh.GroupItems
Debug.Print oGSh.TextFrame.TextRange.Text
Next
' Now do something with each SUB-SELECTED
' shape within the group
With ActiveWindow.Selection.ChildShapeRange
For x = 1 To .Count
Debug.Print .Item(x).Name
Debug.Print .Item(x).TextFrame.TextRange.Text
Next
End With
End Sub
Here's some code that may help generally in processing shapes/groups. It takes account of the fact that there might be groups within groups (within groups (within groups)) ...
Sub ProcessShapes()
Dim oSh As Shape
For Each oSh In ActivePresentation.Slides(1).Shapes
If oSh.Type = msoGroup Then
Debug.Print "GROUP" & vbTab & oSh.Name & vbTab & oSh.ZOrderPosition
Call DealWithGroup(oSh)
Else
Debug.Print oSh.Name & vbTab & oSh.ZOrderPosition
End If
Next
End Sub
Sub DealWithGroup(oSh As Shape)
Dim x As Long
For x = 1 To oSh.GroupItems.Count
If oSh.GroupItems(x).Type = msoGroup Then
Call DealWithGroup(oSh.GroupItems(x))
Else
Debug.Print "GROUP ITEM" & vbTab & oSh.GroupItems(x).Name & vbTab & oSh.GroupItems(x).ZOrderPosition
End If
Next
End Sub
And to answer Peter's further (excellent) question, this should work:
Sub TestIndexOf()
MsgBox IndexOf(ActiveWindow.Selection.ShapeRange(1))
End Sub
Function IndexOf(oSh As Shape) As Long
Dim x As Long
With ActiveWindow.Selection.SlideRange.Shapes
For x = 1 To .Count
If .Item(x).Name = oSh.Name Then
' Found it, report it
IndexOf = x
End If
Next
End With
End Function
Try the few lines of code and yow will get names of all the shapes in immediate window (Cttl+G to view Immediate window)
Dim shp As Shape, I As Integer
For Each shp In ActivePresentation.Slides(1).Shapes
I = I + 1
Debug.Print "Index=" & I & " Name= " & shp.Name & " ID= " & shp.Id & " Type= " & shp.Type
Next
I have big shapes on my worksheet (a group of shapes), and inside everyone of them others little shapes (the blue rectangles),
I made a for loop for inside each Big shape to fill automatically the little shapes, but how can I loop over the Big ones, because all the big shapes are similars, and they have the same names for the littles shapes inside ?
How can I acces the little shape from the big one ?
I tried this but didn't worked
ActiveSheet.Shapes.Range(gr).Select
ActiveSheet.Shapes.Range(Array(x)).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Format(Range(y_1).Value, "#,##0") & " k" & Chr(13) & Format(Range(y_2).Value, "#,##0.00") & " DT"
The "gr" variable takes every time the name of the big shapes (Graph_1 .. Graph_5)
and the x variable takes the name of the little shapes inside (rect_1 .. rect_21)
I think this code does not help because my approach it's like how to access a case in an array if I can say ?
For Each myshape In ActiveSheet.Shapes
You can access child shapes inside a group by using following example:
Sub test()
Dim shp As Shape
Dim shpChild As Shape
For Each shp In Sheet1.Shapes
If shp.Type = msoGroup Then
'/ Found a group. List all the child shapes here.
For Each shpChild In shp.GroupItems
Debug.Print "Child name :" & shpChild.Name & " Group name : " & shp.Name
Next
Else
'/ No group. Individual shape.
Debug.Print shp.Name
End If
Next
End Sub
Here... you should have figured it out yourself :)
Sub test()
Dim shp As Shape
Dim shpChild As Shape
For Each shp In Sheet1.Shapes
If shp.Type = msoGroup And shp.Name = "A" Then
'/ Found a group called "A". List all the child shapes here.
For Each shpChild In shp.GroupItems
If shpChild.Name = "X" Then
'/ Found X.
shpChild.TextFrame2.TextRange.Text = "Hello from VBA!!!"
End If
Next
Else
'/ No group. Individual shape.
Debug.Print shp.Name
End If
Next
End Sub
I have several PowerPoints with a great deal of text in the notes. I need to search the note text and delete any paragraphs that start with "A."
Here is what I tried - but am getting type mismatch error
Dim curSlide As Slide
Dim curNotes As Shape
Dim x As Long
For Each curSlide In ActivePresentation.Slides
Set curNotes = curSlide.NotesPage.Shapes(2).TextFrame.TextRange
With curNotes.TextFrame.TextRange
For x = 1 To Len(curNotes.TextFrame.TextRange)
If Mid(curNotes.TextFrame.TextRange, x, 2) = "A." Then
curNotes.TextFrame.TextRange.Paragraphs = ""
End If
Next x
End With
Next curSlide
End Sub
Thanks for your help!!
You get a mismatch error whenever you try to assign data of a different type specified by your variable. This is happening in your code because you defined curNotes as type Shape and then tried to set that object variable to a different data type, TextRange. You are then trying to process the object TextRange as a string. You need to work on the .Text child of .TextRange The use of Mid is not checking the start of the string and finally, when you set the text to "", you are deleting all the text in the Note but that's not what you said you're trying to do.
This is the corrected code to delete only paragraphs starting with "A."
' PowerPoint VBA macro to delete all slide note paragraphs starting with the string "A."
' Rewritten by Jamie Garroch of youpresent.co.uk
Option Explicit
Sub DeleteNoteParagraphsStartingA()
Dim curSlide As Slide
Dim curNotes As TextRange
Dim iPara As Long
For Each curSlide In ActivePresentation.Slides
Set curNotes = curSlide.NotesPage.Shapes(2).TextFrame.TextRange
With curNotes
' Count backwards in any collection when deleting items from it
For iPara = .Paragraphs.Count To 1 Step -1
If Left(.Paragraphs(iPara), 2) = "A." Then
.Paragraphs(iPara).Delete
Debug.Print "Paragraph " & iPara & " deleted from notes pane on slide " & curSlide.SlideIndex
End If
Next
End With
Next curSlide
End Sub
What I need to be able to do is find a up arrow character and replace it with an up arrow shape and do the same thing for down arros. I am a novice to VBA but have an idea for how I want the Macro to work. It should loop through all slides on the powerpoint.
1) Find the location of the arrow character? (using the INSTR command? and the CHR code command. Not sure if INSTR works in ppt or is the appropriate code here)
2) Add shape with the location returned from the previous line of code. My code is below that already adds this shape to my specifications.
Dim i As Integer
Dim shp As Shape
Dim sld As Slide
Set sld = Application.ActiveWindow.View.Slide
Set shp = sld.Shapes.AddShape(36, 10, 10, 5.0399, 8.6399)
shp.Fill.ForeColor.RGB = RGB(89, 0, 0)
shp.Fill.BackColor.RGB = RGB(89, 0, 0)
shp.Line.ForeColor.RGB = RGB(89, 0, 0)
3) Find and delete all character arrows so the shapes are the only ones left behind.
I've been struggling my way through VBA in PPT and would appreciate any help you could give me.
You're on the right track. Assume I have a shape like this, where it has letters and also a special character, represented by the hex value &H25B2.
First, you need to identify what is the value of your character. There are lots of places where you can find these references.
Then, how to work with in your code, here is one example that finds the shape, and covers it with your arrow, revised per #SteveRindsberg's suggestion, below :)
Public Const upArrow As String = &H25B2 'This is the Hex code for the upward triangle/arrow
Public Const downArrow As String = &H25BC 'This is the Hex code for the downward triangle/arrow
Sub WorkWithSpecialChars()
Dim pres As Presentation
Dim sld As Slide
Dim shp As Shape
Dim foundAt As Long
Dim arrowTop As Double
Dim arrowLeft As Double
Dim arrow As Shape
Set pres = ActivePresentation
For Each sld In pres.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
foundAt = InStr(shp.TextFrame.TextRange.Characters.Text, ChrW(upArrow))
If foundAt > 0 Then
MsgBox "Slide " & sld.SlideIndex & " Shape " & shp.Name & " contains " & _
"the character at position " & foundAt, vbInformation
'Select the text
With shp.TextFrame.TextRange.Characters(foundAt, 1)
'Get the position of the selected text & add the arrow
Set arrow = sld.Shapes.AddShape(36, _
.BoundLeft, .BoundTop, .BoundWidth, .BoundHeight)
'additional code to format the shape
' or call a subroutine to format the shape, etc.
End With
Else:
Debug.Print "Not found in shape " & shp.Name & ", Slide " & sld.SlideIndex
End If
End If
Next
Next
End Sub
To add a bit to what David's done already, once you get a reference to a text range (pretty much any chunk of text), you can get the text's bounding box and use that to position your shape. Here's a start:
Sub testMe()
Dim oSh As Shape
Dim oRng As TextRange
' As an example, use the currently selected shape:
Set oSh = ActiveWindow.Selection.ShapeRange(1)
With oSh.TextFrame.TextRange
' Does it contain the character we're looking for?
If InStr(.Text, "N") > 0 Then
' Get a range representing that character
Set oRng = .Characters(InStr(.Text, "N"), 1)
' And tell us the top
Debug.Print TopOf(oRng)
' And as an exercise for the reader, do companion
' BottomOf, LeftOf, WidthOf functions below
' then use them here to position/size the shape
' atop the existing character
End If
End With
End Sub
Function TopOf(oRng As TextRange)
TopOf = oRng.BoundTop
End Function
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.