AW: Powerpoint Verknüpfung zu Excel löschen / deaktivieren (beim speichern)
02.12.2019 08:13:47
Olli
Hey Karl-Heinz,
soweit funktioniert der Code super und fehlerfrei. Danke dafür!
Jetzt habe ich leider noch das Problem, dass ich den Code ja in der PowerPoint laufen lasse, die immer aktuell sein soll. Das bedeutet, dass wenn die Kopie der PowerPoint erstellt wird sind sowohl die Kopie als auch das Original geöffnet. Demnach wird die Verknüpfung auch aus beiden Dateien gelöscht.
Ist es denn überhaupt möglich deinen Code speziell auf die eine Datei anzuwenden (möglicherweise durch den Dateinamen) oder kennst du zufällig einen Trick dazu?
Ich versuche mich auch nochmal daran und sobald ich eine Lösung habe, melde ich mich nochmal.
Danke und Gruß
Olli
Option Explicit
Public KW As Variant
Sub Zelleauslesen()
Dim pfad As String, datei As String, blatt As String, bezug As String
pfad = "PfadDerExcelTabelle"
datei = "AutospeichernKW.xlsx"
blatt = "AktuelleKW"
bezug = "D3"
KW = GetValue(pfad, datei, blatt, bezug) 'Wert aus Zelle D3 in der Excl als KW speichern
Call NeuenOrdnerErstellen
Call DateispeichernmitKW
Call EntferneVerknuepfungen
End Sub
Private Function GetValue(pfad As String, datei As String, blatt As String, bezug As String) As _
String
With CreateObject("Excel.Application")
With .Workbooks.Open(pfad & "\" & datei)
GetValue = .Sheets(blatt).Range(bezug).Value
Application.DisplayAlerts = False
End With
.Quit
End With
End Function
Sub NeuenOrdnerErstellen()
If Dir("PfadFürNeuenOrdner\KW_" & KW, vbDirectory) = "" Then
MkDir ("PfadFürNeuenOrdner\KW_" & KW)
MsgBox "Ordner für ''KW_" & KW & "'' wurde angelegt!"
Else
MsgBox "Ordner für ''KW_" & KW & "'' ist vorhanden!"
End If
End Sub
Sub DateispeichernmitKW()
Dim PPT As PowerPoint.Application
Dim pfad2 As String
Dim dateiname As String
Dim KWalsString As String
KWalsString = KW
Set PPT = New PowerPoint.Application
pfad2 = "PfadDerNeuenPowerPoint\KW_" & KW
dateiname = "speicherversuch"
Application.DisplayAlerts = False
PPT.ActivePresentation.SaveCopyAs FileName:=pfad2 & "\" & dateiname & "KW_" & KW & ".pptm" ' _
Neue Powerpoit abspeichern mit Name+KW aus der Excl
Application.DisplayAlerts = True
End Sub
Sub EntferneVerknuepfungen()
'Verknüpfungen in einer geöffneten Präsentation von Excel aus entfernen
Dim pptApp As Object, pptPres As Object
Dim pptObj As Object, pptFolie As Object, msoLinkedOLEObject As Integer
msoLinkedOLEObject = 10
On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application") 'geöffnete PPt ansprechen
If Not pptApp Is Nothing Then
If pptApp.Presentations.Count > 0 Then 'Mindestens 1 Präsentation offen
Set pptPres = pptApp.ActivePresentation 'Aktive Präsentation nehmen
For Each pptFolie In pptPres.Slides 'Alle Folien durchgehen
For Each pptObj In pptFolie.Shapes 'Alle Shapes durchgehen
If pptObj.Type = msoLinkedOLEObject Then 'Ist Link?
pptObj.LinkFormat.BreakLink 'Link entfernen
End If
Next pptObj
Next pptFolie
End If
End If
Set pptObj = Nothing
Set pptFolie = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
End Sub
