Hallo Zusammen,
ich habe eine PowerPoint Präsentation in der sich Tabellen befinden, die mit einer Excel verknüpft sind.
Ich habe einen Code geschrieben, der mir automatisch wenn ich will, einen neuen Ordner erstellt und eine Kopie der PowerPoint darin speichert (jede neue Kalenderwoche). Sozusagen als wöchentliches Backup.
Der Code funktioniert auch einwandfrei, einziges Problem ist jetzt, dass in der Kopie der PowerPoint ebenfalls die Tabellen synchronisiert werden. Das ist aber eher unvorteilhaft, da ich ja dann den Stand von zum Beispiel vor 3 Wochen nicht mehr kenne sondern alle abgespeicherten Backups gleich sind.
Meine Frage ist also, kann ich beim speichern der Kopie der PowerPoint, direkt einen Befehl oder eine Routine schreiben, die die aktuelle Verknüpfung zu Excel löscht, sodass sich immer nur die aktuellste Version der PowerPoint updated?
Vielleicht habt ihr Ideen zur Problemlösung, ich würde mich über Vorschläge freuen,
Gruß Olli
7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread
-
29.11.2019 22:59:54volti
-
02.12.2019 08:13:47Olli
-
02.12.2019 14:10:00volti
-
02.12.2019 15:01:24Olli
-
02.12.2019 16:15:41volti
-
02.12.2019 16:28:12Olli
-
02.12.2019 16:22:46Olli
teste mal folgendes Makro, welches von Excel aus die Links in der aktiven Präsentation löschen soll.
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
viele Grüße
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
es ist nicht so, dass in allen geöffneten PowerPoint-Mappen die Verknüpfugnen gelöschen werden.
Es werden nur die Verknüpfungen in der aktiven PPt gelöscht.
Je nachdem, wie und wann Du den Code aufrufst, ist es aber vielleicht Glücksache, welche PPt gerade aktiv ist.
Deshalb könnte man eine Sicherheitsabfrage in den Code einbauen.
Außerdem solltest Du die Sub auch nur aus der Sub zur Kopieerstellung aufrufen, dann dürfte nichts mehr passieren
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
Call EntferneVerknuepfungenAusPowerPoint
End Sub
Sub EntferneVerknuepfungenAusPowerPoint()
'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
If pptPres.Name Like "*KW_*.ppt*" Then 'Nur Präsentationen mit KW_ drin
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
End If
End Sub
viele Grüße
Karl-Heinz
an sich verstehe ich was du meinst und es macht auch Sinn aber ich glaube das Problem ist, dass die Backup Datei nie geöffnet ist sondern nur gespeichert wird, ich versuche die neue gespeicherte Datei mal Kurz zu öffnen und danach wieder direkt zu schließen. Währenddessen natürlich den Verknüpfung entfernen Sub laufen zu lassen.
Könnte das funktionieren?
Freue mich über andere Theorien,
Grüße
Olli
Na klar, über PPT.ActivePresentation.SaveCopyAs erstellt Du nur eine Kopie der Datei.
Naja, dann müsste die Kopie noch mal geöffnet werden, die Links rausgemacht werden und wieder abgespeichert werden. Da stimme ich Dir zu.
Am besten den Dateinamen beim Aufruf der Sub mitgeben:
Call EntferneVerknuepfungenAusPowerPoint (pfad2 & "\" & dateiname & "KW_" & KW & ".pptm")
Sub EntferneVerknuepfungenAusPowerPoint(pptFile As String)
'Verknüpfungen in einer geöffneten Präsentation von Exce aus entfernen
Dim pptApp As Object, pptPres As Object, bWarNichtOffen As Boolean
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 pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
bWarNichtOffen = True
End If
If Not pptApp Is Nothing Then
If Dir$(pptFile) <> "" Then
pptApp.Presentations.Open (pptFile)
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
pptPres.Save
pptPres.Close
If bWarNichtOffen = True Then pptApp.Quit
End If
End If
End Sub
viele Grüße
Karl-Heinz
Ich hab ausversehen gleichzeitig geantwortet wie du, ignorier meine letzte Frage einfach!
So wie es aussieht funktioniert alles einwandfrei, ich danke dir!
Falls ich nochmal Fragen habe, weiß ich, bei wem ich mich melden werde ;)
Gruß
Olli
Ich möchte lediglich die neu abgespeicherte Datei vor deinem Code öffnen, damit sie als "Active presentation" angesehen wird. Nach der Prozedur soll sie aber bestenfalls auch wieder geschlossen werden.
Ich habe nun das hier probiert, scheint laut Debugger aber mächtig falsch zu sein...
Ich habe zu deinem Code lediglich den Code ab "Dim pptDatei As PowerPoint.Application" bis zur "pptDatei.Open" Zeile geschrieben.
Freue mich über Hilfe!
Gruß Olli
Sub EntferneVerknuepfungenAusPowerPoint()
'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
Dim pptDatei As PowerPoint.Application 'ab hier ist der Code von mir
Dim pfad2 As String
Dim dateiname As String
Dim KWalsString As String
pfad2 = "OrtderneuabgespeichertenPowerPointDatei\KW_" & KW
dateiname = "speicherversuch"
KWalsString = KW
Set pptDatei = New PowerPoint.Application
pptDatei.Visible = True
pptDatei.Presentations.Open FileName:=pfad2 & "\" & dateiname & "KW_" & KW & ".pptm" 'bis hier _
ist der Code von mir
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
If pptPres.Name Like "*KW_*.ppt*" Then 'Nur Pr?sentationen mit KW_ drin
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
End If
End Sub
Beliebteste Forumthreads (12 Monate)
-
ThreadtitelLesezugriffe
-
33669
-
22972
-
16198
-
15738
-
15516
-
15050
-
13647
-
11953
-
11777
-
11130
-
10254
-
9889
-
9458
-
9301
-
9223
-
9152
-
8787
-
8676
-
8130
-
8092
-
7874
-
7857
-
7843
-
7835
-
7766
-
7274
-
7261
-
6953
-
6936
-
6811
-
6767
-
6509
-
6232
-
6218
-
6000
-
5890
-
5885
-
5862
-
5808
-
5803
-
5758
-
5740
-
5661
-
5634
-
5604
-
5573
-
5555
-
5482
-
5456
-
5393
-
5384
-
5188
-
5181
-
5113
-
5011
-
4961
-
4960
-
4911
-
4908
-
4845
-
4843
-
4787
-
4764
-
4742
-
4712
-
4711
-
4708
-
4699
-
4698
-
4619
-
4559
-
4531
-
4529
-
4518
-
4513
-
4494
-
4460
-
4443
-
4441
-
4400
-
4393
-
4368
-
4344
-
4327
-
4319
-
4313
-
4301
-
4280
-
4272
-
4258
-
4251
-
4235
-
4225
-
4206
-
4205
-
4202
-
4148
-
4065
-
4033
-
4017