AW: Verlinkte Charts in PPT - Update funktioniert nich
09.04.2018 16:08:19
fcs
Hallo Franzi,
um hier gezielt weiterzukommen muss man die Links der einzelnen Shapes untersuchen.
Die Tatsache, dass die Excel-Datei für alle Links identisch ist macht es wieder etwas einfacher.
Gruß
Franz
Per Makro von Excel aus sieht ein entsprechendes Makro etwa wie folgt aus:
'Erstellt unter Excel 2010 - Makro in Excel bei geschlossener Powerpoint-Präsentation starten
Sub Excellinks_in_PP_Datei_aktualisieren()
Dim sExcellink_alt As Variant, sExcelLink_neu As Variant
Dim ppOLEFormat As Object 'PowerPoint.OLEFormat
Dim sExcelFile_Neu, sExcelFile_Alt, sPP_File_Name As String
Dim ppPresentation As Object 'PowerPoint.Presentation
Dim ppSlide As Object 'PowerPoint.Slide
Dim ppShape As Object 'PowerPoint.Shape
Dim ppApp As Object 'PowerPoint.Application
Set ppApp = VBA.CreateObject("PowerPoint.Application")
ppApp.Visible = True
sPP_File_Name = "\\S000A00001\homedirs\Username\Test\Tes_Links.pptm"'!!! anpassen !!!
Set ppPresentation = ppApp.Presentations.Open(Filename:=sPP_File_Name, withwindow:=msoTrue)
'alte Link-Datei ermitteln
For Each ppSlide In ppPresentation.Slides
For Each ppShape In ppSlide.Shapes
If ppShape.Type = msoLinkedOLEObject Then
Set ppOLEFormat = ppShape.OLEFormat
If Left(ppOLEFormat.progID, Len("Excel.Sheet")) = "Excel.Sheet" Then
sExcellink_alt = ppShape.LinkFormat.SourceFullName
sExcelFile_Alt = Mid(sExcellink_alt, InStrRev(sExcellink_alt, "\") + 1)
sExcelFile_Alt = Left(sExcelFile_Alt, InStr(sExcelFile_Alt, "!") - 1)
If InStr(1, sExcelFile_Alt, ".xls") > 0 Then
sExcelFile_Alt = Left(sExcelFile_Alt, InStrRev(sExcelFile_Alt, ".") - 1)
End If
GoTo weiter
End If
End If
Next
Next
If sExcelFile_Alt = "" Then
MsgBox "Keine Excel-Links in Präsention"
Exit Sub
End If
weiter:
sExcelFile_Neu = ActiveWorkbook.Name
sExcelFile_Neu = Left(sExcelFile_Neu, InStrRev(sExcelFile_Neu, ".") - 1)
'Links ersetzen.
For Each ppSlide In ppPresentation.Slides
For Each ppShape In ppSlide.Shapes
If ppShape.Type = msoLinkedOLEObject Then
Set ppOLEFormat = ppShape.OLEFormat
If Left(ppOLEFormat.progID, Len("Excel.Sheet")) = "Excel.Sheet" Then
sExcellink_alt = ppShape.LinkFormat.SourceFullName
' Debug.Print sExcellink_alt
sExcelLink_neu = VBA.Replace(sExcellink_alt, sExcelFile_Alt, sExcelFile_Neu)
' Debug.Print sExcelLink_neu
ppShape.LinkFormat.SourceFullName = sExcelLink_neu
End If
End If
Next
Next
ppPresentation.UpdateLinks
End Sub
Mit einem Makro innerhalb von PowerPoint etwa so - hier sollte die neue Excel-Datei vor dem Start des PP-Makros geöffnet sein.:
'Erstellt unter PowerPoint 2010 - Makro starten, wenn die Präsentation mit den Links _
die aktive Präsentation ist
Sub Excel_Links_aktualisieren()
Dim sExcellink_alt As Variant, sExcelLink_neu As Variant
Dim ppOLEFormat As PowerPoint.OLEFormat
Dim sExcelFile_Neu, sExcelFile_Alt
Dim ppPresentation As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim ppShape As PowerPoint.Shape
Set ppPresentation = ActivePresentation
Application.DisplayAlerts = ppAlertsNone
'alte Link-Datei ermitteln
For Each ppSlide In ppPresentation.Slides
For Each ppShape In ppSlide.Shapes
If ppShape.Type = msoLinkedOLEObject Then
Set ppOLEFormat = ppShape.OLEFormat
If Left(ppOLEFormat.ProgID, Len("Excel.Sheet")) = "Excel.Sheet" Then
sExcellink_alt = ppShape.LinkFormat.SourceFullName
sExcelFile_Alt = Mid(sExcellink_alt, InStrRev(sExcellink_alt, "\") + 1)
sExcelFile_Alt = Left(sExcelFile_Alt, InStr(sExcelFile_Alt, "!") - 1)
If InStr(1, sExcelFile_Alt, ".xls") > 0 Then
sExcelFile_Alt = Left(sExcelFile_Alt, InStrRev(sExcelFile_Alt, ".") - 1)
End If
GoTo weiter
End If
End If
Next
Next
If sExcelFile_Alt = "" Then
MsgBox "Keine Excel-Links in Präsention"
Exit Sub
End If
weiter:
sExcelFile_Neu = InputBox("Neuer Name der Excel-Datei", "Excel-Links ändern", sExcelFile_Alt)
If sExcelFile_Neu = "" Then GoTo Beenden 'abgebrochen
'Links ersetzen.
For Each ppSlide In ppPresentation.Slides
For Each ppShape In ppSlide.Shapes
If ppShape.Type = msoLinkedOLEObject Then
Set ppOLEFormat = ppShape.OLEFormat
If Left(ppOLEFormat.ProgID, Len("Excel.Sheet")) = "Excel.Sheet" Then
sExcellink_alt = ppShape.LinkFormat.SourceFullName
' Debug.Print sExcellink_alt
sExcelLink_neu = VBA.Replace(sExcellink_alt, sExcelFile_Alt, sExcelFile_Neu)
' Debug.Print sExcelLink_neu
ppShape.LinkFormat.SourceFullName = sExcelLink_neu
End If
End If
Next
Next
ppPresentation.UpdateLinks
Beenden:
Application.DisplayAlerts = ppAlertsAll
End Sub