Ændring af kilde mellem PowerPoint og Excel

Velkommen til Eksperten..

Det skulle være muligt, at opdatere kæderne via VBA. Har du mulighed for at sende en kopi af filerne? @-adresse under min profil.

PS: anvender Office 2007

Koden indsættes i Regnearksfilen:
Aktuelle navn på PP-filen tilpasses

Public pp As Object, systemSti As String
Public Sub opdaterKædeTilPP()
    systemSti = ActiveWorkbook.Path + "\"
   
    Set pp = CreateObject("PowerPoint.Application")
    With pp
        .Visible = True
        .Presentations.Open Filename:=systemSti & "Test eksempel.pptx", ReadOnly:=msoFalse  '<------------- aktuelle filnavn // PP
    End With
   
    tilpasKæder
         
    pp.ActivePresentation.SlideShowSettings.Run
End Sub
Private Sub tilpasKæder()
Dim ptSti As String, ptFilNavn As String
Dim oprKæde As String, glStart As String
Dim nyKæde As String
    ptSti = ActiveWorkbook.Path
    ptFilNavn = ActiveWorkbook.Name
   
    If Right(ptSti, 1) <> "\" Then
        ptSti = ptSti & "\"
    End If
   
    With ThisWorkbook.pp
        antalSlides = .ActivePresentation.Slides.Count
   
        For Each sld In .ActivePresentation.Slides
            For Each sh In sld.Shapes
                If sh.Type = msoLinkedOLEObject Then
                    oprKæde = sh.LinkFormat.SourceFullName
                    p = InStr(oprKæde, "!")
                    If p > 0 Then
                        glStart = Left(oprKæde, p - 1)
                        nyKæde = ptSti & Replace(oprKæde, glStart, ptFilNavn)
                    Else
                        Stop
                    End If
                   
                    sh.LinkFormat.SourceFullName = nyKæde
   
                End If
            Next
        Next
    End With
   
    opdaterDias
   
Rem Gem pp-filen
  ThisWorkbook.pp.ActivePresentation.Save
End Sub
Private Sub opdaterDias()
On Error Resume Next
    Application.ScreenUpdating = False
   
    With ThisWorkbook.pp
        For Each sld In .ActivePresentation.Slides
            For Each sh In sld.Shapes
                If sh.Type = msoLinkedOLEObject Then
                    sh.LinkFormat.Update
                End If
            Next
        Next
    End With
   
    Application.ScreenUpdating = True
End Sub

Perfekt, mange tak for hjælpen