Hilfe! PowerPoint und neue Excel Verknüpfunge

Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal lpnShowCmd As Long) As Long
Begin Code Sequenz
Const ppPresName As String = "\POWER_POINT_KPI\KPI.ppt"
Const LinkIni As String = "\POWER_POINT_KPI\ppLink.ini"

Sub PP_Presentation_Start_and_Update_ObjectLinks()
'(C) Ramses
'Integer Delaration
Dim i As Integer, Qe As Integer
'Object Deklaration
Dim ppApp As Object, ppPres As Object, sh As Object
'String Deklaration
Dim ppFile As String, iniFile As String
Dim LinkFile As String, oldLinkfile As String, NewLinkfile As String
Dim tmpLink As String, onlyOldFileName As String, onlyNewFileName As String, cBSl As Integer
'Variablen füllen
NewLinkfile = ""
'Prüfen ob PP-Datei vorhanden
ppFile = ThisWorkbook.path & ppPresName
If Dir(ppFile) = "" Then
Beep
Qe = MsgBox("Die Datei " & ppFile & " existiert nicht!", vbCritical + vbOKOnly, "Datei Fehler")
Exit Sub
End If
'Zwischenspeichern des Namens für die Quelldatei
iniFile = ThisWorkbook.path & LinkIni
'Prüfen ob INI Datei vorhanden
If Dir(iniFile) = "" Then
Qe = MsgBox("Die Datei " & Chr$(13) & iniFile & Chr$(13) & "wurde noch nicht definiert," & Chr$(13) & _
"Es wird eine neue " & Chr$(13) & LinkIni & Chr$(13) & "erstellt mit der Quelle zu " & Chr$(13) & _
ThisWorkbook.FullName, vbInformation + vbOKCancel, "Source Fehler")
If Qe = vbCancel Then
Qe = MsgBox("Das Erstellen der Datei " & Chr$(13) & _
LinkIni & Chr$(13) & _
" wurde abgebrochen," & Chr$(13) & _
"Das Makro zum Starten der Präsentation wird " & Chr(13) & _
"gestoppt und die PP Links nicht upgedatet !", vbInformation + vbOKOnly, "Source Fehler")
Exit Sub
End If
'Erstellen einer neuen Link.ini
Open iniFile For Output As #1
'Schreiben der aktuell geöffneten Datei als Verknüpfung
Print #1, ThisWorkbook.FullName
Close #1
End If
'Schliessen einer eventuell geöffneten INI-Datei
Close #1
'Der Speicherort der INI Datei wird in der Const LiniIni definiert
Open iniFile For Input As #1
Do While Not EOF(1)
'Einlesen der SourceQuelle für die Präsentation
Input #1, oldLinkfile
Loop
'Schliessen der Datei
Close #1
'Abfrage ob neue Verknüpfungdatei definiert werden soll
Qe = MsgBox("Die aktuelle Verknüpfungdatei von " & Chr$(13) & ppPresName & Chr$(13) & _
"ist derzeit die Datei " & Chr$(13) & _
oldLinkfile & "." & Chr$(13) & _
"Soll die Verknüpfungsdatei geändert werden ?", vbQuestion + vbYesNo, "Source Definition")
If Qe = vbYes Then
'Wenn ja
NewLinkfile = Application.GetOpenFilename("XLS Dateien (*.xls),", True, "Neue Verknüpfungsdatei auswählen", "Übernehmen", False)
'sicherheitsabfrage
Qe = MsgBox("Soll die Datei " & Chr$(13) & NewLinkfile & Chr$(13) & "als neue Verknüpfung definiert werden?", _
vbQuestion + vbOKCancel, "Source Definition")
If Qe = vbNo Then
'Verwendung der bisherigen Datei um Update der Präsentation
Qe = MsgBox("Die Definition der Datei" & Chr$(13) & _
NewLinkfile & Chr$(13) & _
" wurde abgebrochen," & Chr$(13) & _
"Es wird die alte Datei " & oldLinkfile & "verwendet !", vbInformation + vbOKOnly, "Source Definition")
Else
'Neue Linkdatei wird geschrieben und zum Update verwendet
Open iniFile For Output As #1
'Schreiben der aktuell geöffneten Datei als Verknüpfung
Write #1, NewLinkfile
Close #1
End If
End If
Set ppApp = CreateObject("PowerPoint.Application")
ppApp.Visible = msoTrue
Set ppPres = ppApp.Presentations.Open(ppFile)
'Verknüpfungen updaten
'Wenn die Verknüpfungdatei nicht geändert wurde
'werden nur die Werte aktualisiert
If NewLinkfile = "" Then
For i = 1 To ppPres.Slides.count
For Each sh In ppPres.Slides(i).Shapes
If sh.Type = msoLinkedOLEObject Then
With sh.LinkFormat
.Update
End With
End If
Next
Next i
Else
'Die Verknüpfungsdatei wurde geändert
'Dazu muss der Filenamen extrahiert werden
'den die directen Object Bezüge müssen ebenfalls angepasst werden
'Variante für alle Excel Versionen
cBSl = 0
For i = Len(oldLinkfile) To 1 Step -1
If Mid(oldLinkfile, i, 1) = "\" Then
onlyOldFileName = Right(oldLinkfile, Len(oldLinkfile) - i)
Exit For
End If
Next i
cBSl = 0
For i = Len(NewLinkfile) To 1 Step -1
If Mid(NewLinkfile, i, 1) = "\" Then
onlyNewFileName = Right(NewLinkfile, Len(NewLinkfile) - i)
Exit For
End If
Next i
For i = 1 To ppPres.Slides.count
For Each sh In ppPres.Slides(i).Shapes
If sh.Type = msoLinkedOLEObject Then
With sh.LinkFormat
'Externen Filebezug updaten
tmpLink = Replace(.SourceFullName, oldLinkfile, NewLinkfile, 1)
'Updaten der direkten Object Bezüge
tmpLink = Replace(tmpLink, onlyOldFileName, onlyNewFileName, 1)
.SourceFullName = tmpLink
.Update
End With
End If
Next
Next i
End If
ppPres.SlideShowSettings.Run
'ppApp.Quit
Set ppPres = Nothing
Set ppApp = Nothing
End Sub