Sub Kopfzeile_Ausfuellen()
Dim Folie As Slide, Textfeld As Shape
sTxt = InputBox(prompt:="Eingabe der Kopfzeile:", Title:="Kopfzeile")
Dim fd As FileDialog
Dim sFilename As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Filters.Add "PowerPoint Files", "*.ppt; *.pptx", 1
.InitialFileName = Environ("USERPROFILE") & "\Desktop\"
.AllowMultiSelect = False
If .Show = True Then sFilename = .SelectedItems(1)
End With
Dim myApp As Object
Dim myFile As String
Dim numSl As Long
myFile = ("" & sFilename)
Set myApp = CreateObject("PowerPoint.application")
With myApp
.Activate
.Presentations.Open FileName:=myFile
numSl = .ActivePresentation.Slides.Count
End With
Set myApp = Nothing
numSl = numSl - 1
Dim i As Integer
For i = 2 To numSl
Set Folie = ActivePresentation.Slides(i)
<strong>Set Textfeld = Folie.Shapes("Fußzeilenplatzhalter 1" Or "Fußzeilenplatzhalter 2")</strong>
Textfeld.TextFrame.TextRange.Text = ("Willy Vogel I/EG-721 in-tech GmbH Steinschlagsimulation " & sTxt)
Next
End Sub