10.02.2020, 01:02
Hi ihr lieben VBA-Programmierer
Mit fremder Hilfe habe ich ein Makro erstellt, das in allen PPTs, die in einem Ordner sind, die Datei-Eigenschaften und zeitgleich die Fusszeile erneuert. Das klappt bestens. Leider habe ich erst heute festgestellt, dass die Fusszeile in der Masteransicht noch die alte bleibt. Im Menü Fusszeile/Kopfzeile einfügen steht jeweils korrekt die neue Fusszeile - leider im Master nicht ... angezeigt wird in einer bearbeiteten PPT in der normalen Ansicht die korrekte und neue Fusszeile. Ich habe keine Ahnung wo der Fehler liegen könnte oder was man ergänzen müsste ...
Weiss jemand einen Rat?
Besten Dank für allfällige Tipps.
VERSION: Office 2019
Hier der Code:
SIEHE AUCH:
http://www.office-loesung.de/p/viewtopic...1#p3277241
http://www.vba-forum.de/Forum/View.aspx?...le_drinnen
Mit fremder Hilfe habe ich ein Makro erstellt, das in allen PPTs, die in einem Ordner sind, die Datei-Eigenschaften und zeitgleich die Fusszeile erneuert. Das klappt bestens. Leider habe ich erst heute festgestellt, dass die Fusszeile in der Masteransicht noch die alte bleibt. Im Menü Fusszeile/Kopfzeile einfügen steht jeweils korrekt die neue Fusszeile - leider im Master nicht ... angezeigt wird in einer bearbeiteten PPT in der normalen Ansicht die korrekte und neue Fusszeile. Ich habe keine Ahnung wo der Fehler liegen könnte oder was man ergänzen müsste ...
Weiss jemand einen Rat?
Besten Dank für allfällige Tipps.
VERSION: Office 2019
Hier der Code:
Code:
Sub SetDocPropsPlusFootereintragen()
Dim dd1 As Presentation
Dim dokupfad As String, endung As String, dateiname As String
Dim s As Slide
Dim p As Slide
dokupfad = "C:\Users\..." '**der Pfad, in dem die zu bearbeitenden Dokumente liegen anpassen!
endung = "*.pptx" '**Anpassen, falls nötig!
dateiname = Dir(dokupfad & endung)
'**********Beginn der Schleife durch alle Dateien im Ordner ***************
Do While dateiname <> ""
Set dd1 = Presentations.Open(FileName:=dokupfad & dateiname) 'öffnet das Dokument
'********************* Zu wiederholende "Arbeit"*******************************************************
If Presentations.Count > 0 Then
'********** Alle Eigenschaften des Files werden gelöscht "***********
Dim oProp As DocumentProperty
On Error Resume Next
For Each oProp In ActiveDocument.BuiltInDocumentProperties
oProp.Value = "" 'entsprechende Eigenschaft wird gelöscht
Next oProp
'********** Alle Eigenschaften des Files werden NEU gesetzt "***********
Dim dp As Object
Set dp = ActivePresentation.BuiltInDocumentProperties
dp("Title") = "NAME XYZ"
dp("Subject") = "NAME XYZ"
dp("Keywords") = "NAME XYZ"
dp("Category") = "NAME XYZ"
dp("Comments") = "NAME XYZ"
dp("Author") = "NAME XYZ"
dp("Company") = "NAME XYZ"
dp("Manager") = "NAME XYZ"
End If
For Each s In ActivePresentation.Slides
s.HeadersFooters.Footer.Visible = msoTrue 'Footer soll erst sichtbar werden
s.HeadersFooters.SlideNumber.Visible = msoTrue 'Foliennummer sichtbar machen
s.HeadersFooters.Footer.Text = " NEUER NAME XYZ" 'Footer mit Text füllen
Next s
ActivePresentation.SlideMaster.HeadersFooters.DisplayOnTitleSlide = msoFalse
For Each p In ActivePresentation.Slides 'Footer gets visible
If p.CustomLayout.Index <> 1 Then
p.HeadersFooters.Footer.Visible = msoTrue
p.HeadersFooters.SlideNumber.Visible = msoTrue 'Slidenumber gets visible
p.HeadersFooters.Footer.Text = "NEUER NAME XYZ" 'Footer gets filled with text
End If
Next p
For Each p In ActivePresentation.Slides 'Footer Titlesloide gets invisible
If p.CustomLayout.Index = 1 Then
p.HeadersFooters.Footer.Visible = msoFalse
p.HeadersFooters.SlideNumber.Visible = msoFalse 'Slidenumber gets invisible
End If
Next p
'Dokument speichern
dd1.Save
'Dateien schliessen
dd1.Close
Set dd1 = Nothing
'********************Fortsetzung der Schleife durch alle Dokumente********************
dateiname = Dir ' nächste Datei
Loop
End Sub
SIEHE AUCH:
http://www.office-loesung.de/p/viewtopic...1#p3277241
http://www.vba-forum.de/Forum/View.aspx?...le_drinnen