Break Link and Rename the Shape in PPT

[abc_xyz]

I have a code which loop through all the slides in the active presentation and checks for the name of the shape and then breaks the linking. Now, I want to rename that shape. The problem is that the shape automatically gets converted to a picture and the PowerPoint automatically assigns a name on which I do not have control. Object Required error is shown. Is there a solution to this?

Sub BreakLinksInPPT()
    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim sld As PowerPoint.Slide
    Dim shp As PowerPoint.Shape
    Dim Newshp  As Shape
    Dim UniqueName As String
    
    'Open PowerPoint Application
    Set pptApp = GetObject(Class:="Powerpoint.Application")

    'Open the presentation you want to break links in
    Set pptPres = pptApp.ActivePresentation
    
    'Loop through each slide in the presentation
    For Each sld In pptPres.Slides
        
        'Loop through each shape in the slide
        For Each shp In sld.Shapes
            UniqueName = "HNM" & Format(Now, "yyyymmddhhmmss")
            
            'Check if the shape is linked to an external file
            If Left(shp.Name, 3) = "HNM" Then
                If shp.Type = 10 Then
                    'Break the link
                    shp.LinkFormat.BreakLink
                    shp.Name = UniqueName
                End If
            End If
        Next shp
    Next sld
    
End Sub

 

[Domenic]

Try doing it in two separate steps so that you'll have two separate loops.

First loop through each shape, and break the link.

Then loop through each shape again, and rename.

Hope this helps!

 

[abc_xyz]

Try doing it in two separate steps so that you'll have two separate loops.

First loop through each shape, and break the link.

Then loop through each shape again, and rename.

Hope this helps!

How do I reference it to the same shape for which I have broken the linking? There are many more shapes in the presentation.

 

[Domenic]

I have amended your macro as follows...

Option Explicit

Sub BreakLinksInPPT()

    Dim dicUniqueNamesByShapeIndexLookup As Scripting.Dictionary
    Dim key As Variant
    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim sld As PowerPoint.Slide
    Dim shp As PowerPoint.Shape
    Dim ShapeIndex As Long
    Dim UniqueName As String
   
    'Create a dictionary for the shape indexes and their corresponding unique names
    Set dicUniqueNamesByShapeIndexLookup = New Scripting.Dictionary
   
    'Open PowerPoint Application
    Set pptApp = GetObject(Class:="Powerpoint.Application")

    'Open the presentation you want to break links in
    Set pptPres = pptApp.ActivePresentation
   
    'Loop through each slide in the presentation
    For Each sld In pptPres.Slides
        'Loop through each shape in the slide and break the link
        For ShapeIndex = 1 To sld.Shapes.Count
            'Get the current shape
            Set shp = sld.Shapes(ShapeIndex)
            'Check if the shape is linked to an external file
            If Left(shp.Name, 3) = "HNM" Then
                If shp.Type = 10 Then
                    'Break the link
                    shp.LinkFormat.BreakLink
                    'Get a unique name for the shape
                    UniqueName = "HNM" & Format(Now, "yyyymmddhhmmss")
                    'Add the shape index and unique name to the dictionary
                    dicUniqueNamesByShapeIndexLookup.Add key:=ShapeIndex, Item:=UniqueName
                    'Wait one second to prevent duplicate unique names
                    Application.Wait Now() + TimeValue("00:00:01")
                End If
            End If
        Next ShapeIndex
        'Loop through each of the relevant shapes on the slide by index number and rename them using their corresponding unique names
        For Each key In dicUniqueNamesByShapeIndexLookup.Keys()
            sld.Shapes(key).Name = dicUniqueNamesByShapeIndexLookup(key)
        Next key
        dicUniqueNamesByShapeIndexLookup.RemoveAll
    Next sld
   
    Set shp = Nothing
    Set sld = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
    Set dicUniqueNamesByShapeIndexLookup = Nothing
   
End Sub

Hope this helps!

 

[abc_xyz]

I have amended your macro as follows...

Option Explicit

Sub BreakLinksInPPT()

    Dim dicUniqueNamesByShapeIndexLookup As Scripting.Dictionary
    Dim key As Variant
    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim sld As PowerPoint.Slide
    Dim shp As PowerPoint.Shape
    Dim ShapeIndex As Long
    Dim UniqueName As String
  
    'Create a dictionary for the shape indexes and their corresponding unique names
    Set dicUniqueNamesByShapeIndexLookup = New Scripting.Dictionary
  
    'Open PowerPoint Application
    Set pptApp = GetObject(Class:="Powerpoint.Application")

    'Open the presentation you want to break links in
    Set pptPres = pptApp.ActivePresentation
  
    'Loop through each slide in the presentation
    For Each sld In pptPres.Slides
        'Loop through each shape in the slide and break the link
        For ShapeIndex = 1 To sld.Shapes.Count
            'Get the current shape
            Set shp = sld.Shapes(ShapeIndex)
            'Check if the shape is linked to an external file
            If Left(shp.Name, 3) = "HNM" Then
                If shp.Type = 10 Then
                    'Break the link
                    shp.LinkFormat.BreakLink
                    'Get a unique name for the shape
                    UniqueName = "HNM" & Format(Now, "yyyymmddhhmmss")
                    'Add the shape index and unique name to the dictionary
                    dicUniqueNamesByShapeIndexLookup.Add key:=ShapeIndex, Item:=UniqueName
                    'Wait one second to prevent duplicate unique names
                    Application.Wait Now() + TimeValue("00:00:01")
                End If
            End If
        Next ShapeIndex
        'Loop through each of the relevant shapes on the slide by index number and rename them using their corresponding unique names
        For Each key In dicUniqueNamesByShapeIndexLookup.Keys()
            sld.Shapes(key).Name = dicUniqueNamesByShapeIndexLookup(key)
        Next key
        dicUniqueNamesByShapeIndexLookup.RemoveAll
    Next sld
  
    Set shp = Nothing
    Set sld = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
    Set dicUniqueNamesByShapeIndexLookup = Nothing
  
End Sub

Hope this helps!

This is awesome! I created a different method but works the same way. Learnt something new today. Instead of looping through all the slides, how can we loop through the selected slides only?

 

[Domenic]

In that case, you can replace...

For Each sld In pptPres.Slides

with

For Each sld In pptPres.Windows(1).Selection.SlideRange

or

For Each sld In pptApp.ActiveWindow.Selection.SlideRange

Hope this helps!