'How to clone and align selected counted shapes to table by index, skipping one column
After the table with the number of column equal to the shapes selected is created, I would like to realign each of them (the shapes) respectively to the relative column (here the third, fifth etc.) and duplicate them in the following slides that are not using a Layout named Section. However I am not able to declare this, could someone help please?
Option Explicit
Sub NavigatorX()
Dim nCounter As Long
Dim oSlide As Slide
Dim oSlides As Slides
Set oSlides = ActivePresentation.Slides
Dim oShapeNavigator As Shape
Dim Shapesarray() As Shape
ReDim Shapesarray(1 To ActiveWindow.Selection.ShapeRange.Count) - 1
Dim V As Long
Dim iIcon As Shape
For V = 1 To ActiveWindow.Selection.ShapeRange.Count
Set Shapesarray(V) = ActiveWindow.Selection.ShapeRange(V)
Next V
Debug.Print V
For Each oSlide In oSlides
If oSlide.CustomLayout.Name = "Section Header" Then
nCounter = nCounter + 1
Set oShapeNavigator = oSlide.Shapes.AddTable(1, V, Left:=10, Top:=10, Width:=MasterTitle.Width * 2 / 3, Height:=2)
CellLeft = oShapeNavigator.Table.Cell(iRow, iColumn).Shape.Left
CellTop = oShapeNavigator.Table.Cell(iRow, iColumn).Shape.Top
CellWidth = oShapeNavigator.Table.Cell(iRow, iColumn).Shape.Width
CellHeight = oShapeNavigator.Table.Cell(iRow, iColumn).Shape.Height
Debug.Print CellWidth
Debug.Print CellHeight
Shp_Cntr = CellLeft + CellWidth / 2
Shp_Mid = CellTop + CellHeight / 2
Next
With oShapeNavigator.Table '@@ TABLE @@
For iRow = 1 To .Rows.Count
For iColumn = 1 To .Columns.Count Step 2
For Each iIcon In Shapesarray ' Here is where I am having problems figuring out how to do it
If V = nCounter Then
Icon.Left = Shp_Cntr - CellHeight
Icon.Top = Shp_Mid - CellHeight
Icon.Width = CellHeight
Icon.Height = CellHeight
Next
'
Next iColumn
Next iRow
Next oSlide
End Sub
I tried the below also (Shp_Cntr and the rest to be defined, but thats's not the issue at the moment as I get Only one shape moving):
Currently it's like below, it's copying but pasting all in the same slide
...
For V = 1 To ActiveWindow.Selection.ShapeRange.Count - 1 'Set Selected Array of Shapes
Set Shapesarray(V) = ActiveWindow.Selection.ShapeRange(V)
Set iIcon = Shapesarray(V)
Next V
...
With oShapeNavigator.Table '@@ TABLE @@
For iRow = 1 To .Rows.Count
For iColumn = 1 To .Columns.Count Step 2
For V = LBound(Shapesarray) To UBound(Shapesarray) - 1
CellLeft = oShapeNavigator.Table.Cell(iRow, iColumn).Shape.Left
CellTop = oShapeNavigator.Table.Cell(iRow, iColumn).Shape.Top
CellWidth = oShapeNavigator.Table.Cell(iRow, iColumn).Shape.Width
CellHeight = oShapeNavigator.Table.Cell(iRow, iColumn).Shape.Height
Debug.Print CellWidth
Debug.Print CellHeight
Shp_Cntr = CellLeft + CellWidth / 2
Shp_Mid = CellTop + CellHeight / 2
With iIcon.Duplicate
iIcon.Left = Shp_Cntr - CellHeight
iIcon.Top = Shp_Mid - CellHeight
iIcon.Width = CellHeight
iIcon.Height = CellHeight
End With
' End If
Next V
Next iColumn
Next iRow
End With
But only one shape (with three selected, the second) gets cloned and only in the first slide. Also, I noticed there is a massive amount of shapes created, here (Copy paste shape by using VBA in PowerPoint) they mention to set a new collection, but it did not help as I am not able to integrate it.
Currently it's like below but it's pasting in the first slide
For V = LBound(Shapesarray) To UBound(Shapesarray) - 1
Set iIcon = ActiveWindow.Selection.ShapeRange(V)
' For Each Icon In ShapeRange
CellLeft = oShapeNavigator.Table.Cell(iRow, iColumn).Shape.Left
CellTop = oShapeNavigator.Table.Cell(iRow, iColumn).Shape.Top
CellWidth = oShapeNavigator.Table.Cell(iRow, iColumn).Shape.Width
CellHeight = oShapeNavigator.Table.Cell(iRow, iColumn).Shape.Height
Debug.Print CellWidth
Debug.Print CellHeight
Shp_Cntr = CellLeft + CellWidth / 2
Shp_Mid = CellTop + CellHeight / 2
iIcon.Left = Shp_Cntr - (CellHeight * IconRatio / 2)
iIcon.Top = Shp_Mid - (CellHeight * IconRatio / 2)
iIcon.Width = CellHeight * IconRatio
iIcon.Height = CellHeight * IconRatio
iIcon.ZOrder msoBringToFront
iIcon.Fill.ForeColor.RGB = RGB(0, 0, 0)
iIcon.Line.Weight = 0#
iIcon.Line.Visible = msoFalse
iIcon.LockAspectRatio = msoTrue
' Next
' For nCounter = 1 To oSlides.Count
iIcon.Copy
For nCounter = 1 To oSlides.Count
'
' oSlide.Shapes.Paste
End If
' Next
Next V
Looping through I can see If I remove the iIcon.Copy part it moves the selected icons all the way to the last column together, so it seems it should deselect the shapes one by one first.
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|
