Consulting

Results 1 to 8 of 8

Thread: Deselecting connectors in shape range in PowerPoint using VBA

  1. #1

    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

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    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
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    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 View Post
    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

  4. #4
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  5. #5
    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 View Post
    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

  6. #6
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

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

    Quote Originally Posted by Paul_Hossler View Post
    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
    Attached Files Attached Files

  8. #8
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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
    Last edited by Paul_Hossler; 12-11-2019 at 03:11 PM.
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •