Deselecting connectors in shape range in PowerPoint using VBA

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:

It is very unclear why you need an array.

msoLine is not a viable test for connectors.

Maybe

Code:

---

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

---

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?

Quote:

---

Originally Posted by John Wilson

It is very unclear why you need an array.

msoLine is not a viable test for connectors.

Maybe

Code:

---

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

---

---

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

Code:

---


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

---

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...

Quote:

---

Originally Posted by John Wilson

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

Code:

---


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

---

---

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

Code:

---

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

---

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:

Quote:

---

Originally Posted by 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

Code:

---

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

---

---

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

Code:

---

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

---