Deselecting connectors in shape range in PowerPoint using VBA

[CuriosityBug]

Hello All,

How can we make the macro to deselect shapes of type connectors? The idea is to select set of shapes manually with cursor and then run macro. While running macro, I want the functionality(macro) to effect only on shapes like rectangles, boxes not on connectors. How can we approach this? Please help!

Here, I selected few shapes in slide and run macro. All selected shapes except connectors should be stored in an array "Shapesarray" and then I can play with other functionalities.

Draft code:

For Each oshp In ActiveWindow.Selection.ShapeRange
If oshp.Type = msoLine Then
oshp.Select Replace:=msoFalse
End If
Next oshp
ReDim Shapesarray(1 To ActiveWindow.Selection.ShapeRange.Count)
For V = 1 To ActiveWindow.Selection.ShapeRange.Count
Set Shapesarray(V) = ActiveWindow.Selection.ShapeRange(V)
Next V


Please help:bow:

[John Wilson]

It is very unclear why you need an array.

msoLine is not a viable test for connectors.

Maybe


Sub collect()
Dim oshp As Shape
For Each oshp In ActiveWindow.Selection.ShapeRange
If oshp.AutoShapeType = 1 Then
If oshp.AutoShapeType <> -2 Then ' NOT connector
' Do this
' example
oshp.Fill.ForeColor.RGB = RGB(255, 0, 0)
oshp.Width = 100
End If
End If
Next oshp
End Sub

[CuriosityBug]

Hello John,


Thanks for the insight. I would like to do something like..
oshp.Fill.ForeColor.RGB = color of first shape ' All shapes should pick the color of first shape.


Inorder to do this I thought of placing all shapes in an array and then accessing first shape properties.


Please help, how to do this?



It is very unclear why you need an array.

msoLine is not a viable test for connectors.

Maybe


Sub collect()
Dim oshp As Shape
For Each oshp In ActiveWindow.Selection.ShapeRange
If oshp.AutoShapeType = 1 Then
If oshp.AutoShapeType <> -2 Then ' NOT connector
' Do this
' example
oshp.Fill.ForeColor.RGB = RGB(255, 0, 0)
oshp.Width = 100
End If
End If
Next oshp
End Sub

[John Wilson]

This is how to create the array. Problem will be knowing which is the first shape.




Sub collect()


Dim oshp As Shape
Dim raySHP() As Shape
Dim L As Long
ReDim raySHP(1 To 1)


For Each oshp In ActiveWindow.Selection.ShapeRange
If oshp.AutoShapeType = 1 Then
If oshp.AutoShapeType <> -2 Then ' NOT connector
Set raySHP(UBound(raySHP)) = oshp
ReDim Preserve raySHP(1 To UBound(raySHP) + 1)
End If
End If
Next oshp
If UBound(raySHP) > 1 Then
ReDim Preserve raySHP(1 To UBound(raySHP) - 1)
End If
raySHP(1).PickUp
For L = 1 To UBound(raySHP)
raySHP(L).Apply
Next L
End Sub

[CuriosityBug]

In order to know the first shape, we can assume that the first shape selected as first shape in the array. So, I am trying to access this first element in array and setting it's color to rest of elements in array.

Rough draft:

FirstShapeColor = Shapearray(1).color ( or any other properties like left, top values)
For V = 2 To UBound(Shapesarray)
Shapesarray(V).Fill.ForeColor.RGB = FirstShapeColor
Next V

Can we use something similar like this..combining this in the above deselecting of connectors...





This is how to create the array. Problem will be knowing which is the first shape.




Sub collect()


Dim oshp As Shape
Dim raySHP() As Shape
Dim L As Long
ReDim raySHP(1 To 1)


For Each oshp In ActiveWindow.Selection.ShapeRange
If oshp.AutoShapeType = 1 Then
If oshp.AutoShapeType <> -2 Then ' NOT connector
Set raySHP(UBound(raySHP)) = oshp
ReDim Preserve raySHP(1 To UBound(raySHP) + 1)
End If
End If
Next oshp
If UBound(raySHP) > 1 Then
ReDim Preserve raySHP(1 To UBound(raySHP) - 1)
End If
raySHP(1).PickUp
For L = 1 To UBound(raySHP)
raySHP(L).Apply
Next L
End Sub

[Paul_Hossler]

I have this in my PP Addin -- select a shape and run the macro -- it used FormatPainter, but you can change it

The supporting macros are in the attachment, but this is the main one

Should give you nudge in the direction I think you want to go




Option Explicit


Sub FormatAllShapes()
Dim oSlide As Slide
Dim oShape As Shape, oSelectedShape As Shape

If NoPresentation Then Exit Sub



Set oSelectedShape = Nothing
On Error Resume Next
Set oSelectedShape = PowerPoint.ActiveWindow.Selection.ShapeRange(1)
On Error GoTo 0
If oSelectedShape Is Nothing Then Exit Sub

If MsgBox("Do you want to format all " & StrShapeName(oSelectedShape, True) & " like the selected one?", vbOKCancel + vbQuestion, "Sub: FormatAllShapes") = vbCancel Then Exit Sub

ScreenUpdating = False

oSelectedShape.PickUp

For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Type = oSelectedShape.Type Then
oShape.Apply
End If
Next oShape
Next oSlide

ActiveWindow.Selection.Unselect

ScreenUpdating = True

Call MsgBox("All " & StrShapeName(oSelectedShape, True) & " have been formatted like the selected " & StrShapeName(oSelectedShape) & " in " & ActivePresentation.Name, vbInformation + vbOKOnly, "Sub: FormatAllShapes")

End Sub

[CuriosityBug]

Hello Paul,

Thank you so much for the work, this is almost what I want but the major struck point is as follow:
1.Instead of format applying on all similar shapes, I would like to apply feature on only selected shapes
2. The way of selection I am trying to do is illustrated in presentation...

when bunch of objects/shapes are selected using cursor - rectangles along with connectors are selected.

Any thoughts on this? please help:bow:


I have this in my PP Addin -- select a shape and run the macro -- it used FormatPainter, but you can change it

The supporting macros are in the attachment, but this is the main one

Should give you nudge in the direction I think you want to go




Option Explicit


Sub FormatAllShapes()
Dim oSlide As Slide
Dim oShape As Shape, oSelectedShape As Shape

If NoPresentation Then Exit Sub



Set oSelectedShape = Nothing
On Error Resume Next
Set oSelectedShape = PowerPoint.ActiveWindow.Selection.ShapeRange(1)
On Error GoTo 0
If oSelectedShape Is Nothing Then Exit Sub

If MsgBox("Do you want to format all " & StrShapeName(oSelectedShape, True) & " like the selected one?", vbOKCancel + vbQuestion, "Sub: FormatAllShapes") = vbCancel Then Exit Sub

ScreenUpdating = False

oSelectedShape.PickUp

For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Type = oSelectedShape.Type Then
oShape.Apply
End If
Next oShape
Next oSlide

ActiveWindow.Selection.Unselect

ScreenUpdating = True

Call MsgBox("All " & StrShapeName(oSelectedShape, True) & " have been formatted like the selected " & StrShapeName(oSelectedShape) & " in " & ActivePresentation.Name, vbInformation + vbOKOnly, "Sub: FormatAllShapes")

End Sub

[Paul_Hossler]

I don't think defining the 'First Shape' by 'lassoing' them is 100%, but play with this

The alternative which I think is more reliable is to click the 'master' shape, and then Shift-Click the others that you want to apply the master shape formats to




Option Explicit


Sub FormatAllShapes()
Dim oShape As Shape, oFirstShape As Shape


If NoPresentation Then Exit Sub


ScreenUpdating = False

For Each oShape In ActiveWindow.Selection.ShapeRange

If oFirstShape Is Nothing Then
Set oFirstShape = oShape
oFirstShape.PickUp
Else
If oShape.Type = oFirstShape.Type Then
oShape.Apply
End If
End If
Next


ScreenUpdating = True


End Sub