Skip to content

Shapes

Get Shape Using Name

ActivePresentation.Slides(1).Shapes("Player1Name").TextEffect.Text

Shape Property For Positioning

Sub Test()
    Dim shape As shape
    Set shape = ActivePresentation.Slides(2).Shapes("Test")

    With shape
        Debug.Print , "Name:" & .Name
        Debug.Print , "Left:" & .Left
        Debug.Print , "Top:" & .Top
        Debug.Print , "Width:" & .Width
        Debug.Print , "Height:" & .Height
        Debug.Print , "Rotation:" & .Rotation
        Debug.Print , "ZOrderPosition:" & .ZOrderPosition
    End With

End Sub

List All Shapes

Sub ListAllObjects()
    Dim curSlide As Slide
    Dim curShape As Shape
    For Each curSlide In ActivePresentation.Slides
        For Each curShape In curSlide.Shapes
            Debug.Print , curShape.Name
        Next curShape
    Next curSlide
End Sub

Copy All Object From One Slide to Another Slide

Sub CopyAllObjectFromFirstSlideToSecond()
    Dim curSlide As Slide
    Dim curShape As Shape

    With ActivePresentation

        'Copy All Object
        .Slides(1).Shapes.Range.Copy

        ''Copy 1st and 3rd Object
        '.Slides(1).Shapes.Range(Array(1, 3)).Copy

        ''Only Copy 3rd object
        '.Slides(1).Shapes.Range(Array(3)).Copy

        .Slides(2).Shapes.Paste

    End With
End Sub

Change Name Of Shape

Sub ChangeId()
    ActivePresentation.Slides(1).Shapes(1).Name = "test"
    Debug.Print , ActivePresentation.Slides(1).Shapes(1).Name
End Sub

Remove Specific type of shapes from Slide

Private Sub RemoveOldFolderObjects()
    Dim shape As shape
    Dim TotalShapes As Integer, i As Integer
    TotalShapes = ActivePresentation.Slides(1).Shapes.Count

    For i = TotalShapes To 1 Step -1
        Set shape = ActivePresentation.Slides(1).Shapes(i)
        If shape.Type = msoLine Then
            shape.Delete
        End If
    Next

End Sub

Remove Shape From Active Slide

Private Sub RemovePicture(PPSlide As PowerPoint.Slide, PictureName As String)
    Dim curShape As shape
    For Each curShape In PPSlide.Shapes
        If curShape.Name = PictureName Then
            curShape.Delete
        End If
    Next curShape
End Sub

Function to Check If ShapeExist

Function IsShapeExists(PPSlide As PowerPoint.Slide, shapeName As String) As Boolean
    Dim shape As PowerPoint.shape
    For Each shape In PPSlide.Shapes
        If shape.Name = shapeName Then IsShapeExists = True
    Next shape
End Function

Get Specific Shape From Active Slide

Private Function GetShape(PPSlide As PowerPoint.Slide, PictureName As String) As shape
    Dim curShape As shape
    For Each curShape In PPSlide.Shapes
        If curShape.Name = PictureName Then
            Set GetShape = curShape
            Exit Function
        End If
    Next curShape
End Function

Add Shapes

Private Function AddTextbox(PPSlide As PowerPoint.Slide, leftPos As Integer, topPos As Integer, width As Double, height As Double, data As String) As PowerPoint.shape
    'Add TextBox With Number
    Dim PPShape As PowerPoint.shape
    'Change AutoShapeType as per requirement
    Set PPShape = PPSlide.Shapes.AddShape(msoShapeRectangle, left:=leftPos, top:=topPos, width:=width, height:=height)
    Set AddTextbox = PPShape
End Function

Add New Picture

'Create New Pic On Same Position as Old One
    Dim PPShape As shape
    Set PPShape = PPSlide.Shapes.AddPicture(FileName:=PictureFilePath, _
                                            LinkToFile:=msoFalse, _
                                            SaveWithDocument:=msoTrue, _
                                            Left:=Picture.Left, _
                                            Top:=Picture.Top, _
                                            Width:=Picture.Width, _
                                            Height:=Picture.Height)

    PPShape.Name = Picture.Name