Fusszeile erneuern - Im Master bleibt alte Fusszeile drinnen

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