PowerPoint - Fusszeile - TextBox befüllen - alle Folien...

OptionExplicit
' Speichername der Datei
ConststrPPSaveAsString="EXCELnachPP"' anpassen!!!
' Leeres Slide in PowerPoint
ConstppLayoutBlankAsLong=12
' Objektvariable für Applikation
DimobjPPAsObject
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.08.2017
' Purpose   : PowerPoint - Fusszeile - TextBox befüllen...
'--------------------------------------------------------------------------
PublicSubMain()
' Variablendeklaration
DimobjPPPresAsObject
DimobjPPDocAsObject
DimintLeftAsInteger
DimintTMPAsInteger
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
WithApplication
' Das Bildschirmaktualisierung wird unterbrochen
.ScreenUpdating=False
' Ereignisroutinen werden deaktiviert
.EnableEvents=False
' Auslesen der momentanen Einstellung für die Berechnung
lngCalc=.Calculation
' Setzen der Berechnung auf "Manuell"
.Calculation=xlCalculationManual
'  Eingabeaufforderungen und Warnmeldungen unterdrücken
.DisplayAlerts=False
EndWith
' PowerPoint starten
' Wenn PowerPoint ausgeblendet werden soll, dann so:
' http://vbanet.blogspot.de/2010/09/excel-powerpoint.html
SetobjPP=OffApp("PowerPoint")
IfNotobjPPIsNothingThen
WithobjPP
' Vorhandene Präsentation öffnen GLEICHER Ordner wie die Exceldatei
SetobjPPPres=.Presentations.Open_
(Filename:=ThisWorkbook.Path&_
Application.PathSeparator&"Test.pptx")
' Schleife über alle Folien
ForintTMP=1ToobjPPPres.Slides.Count
SetobjPPDoc=objPPPres.Slides(intTMP)
' Fusszeile TextBox mit Name: "Footer Placeholder 3" befüllen
objPPDoc.Shapes("Footer Placeholder 3").TextFrame.TextRange.Text=_
ThisWorkbook.Worksheets("Tabelle1").Range("C3").Value
SetobjPPDoc=Nothing
NextintTMP
' Unter neuem Namen speichern
objPPPres.SaveAsThisWorkbook.Path&_
Application.PathSeparator&strPPSave&_
Format(Now,"ddMMyyyy_hhmmss")
' Auf langsamen Netzlaufwerken kann es zu Problemen kommen (Speichern)
' Deshalb hier 2 Sekunden Wartezeit - kann natürlich
' bei Bedarf auskommentiert bzw. verändert werden
Application.WaitNow+TimeSerial(0,0,2)
' Präsentation Schliessen
objPPPres.Close
' PP beenden
.Quit
EndWith
Else
MsgBox"Application not installed!"
EndIf
Fin:
' Objektvariablen zurücksetzen
SetobjPPDoc=Nothing
SetobjPPPres=Nothing
SetobjPP=Nothing
' Die Applikation aufwecken
WithApplication
' Bildschirmaktualisierung wieder einschalten
.ScreenUpdating=True
' Ereignisroutinen werden wieder aktiviert
.EnableEvents=True
' Setzen der Berechnung auf den gemerkten Wert
.Calculation=lngCalc
' Eingabeaufforderungen und Warnmeldungen wieder zulassen
.DisplayAlerts=True
' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
.CutCopyMode=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Error: "&_
Err.Number&" "&Err.Description
EndSub
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.08.2017
' Purpose   : Start application...
'--------------------------------------------------------------------------
PrivateFunctionOffApp(ByValstrAppAsString,_
OptionalblnVisibleAsBoolean=True)AsObject
OnErrorResumeNext
SetobjPP=GetObject(,strApp&".Application")
SelectCaseErr.Number
Case429
Err.Clear
SetobjPP=CreateObject(strApp&".Application")
IfblnVisible=TrueThen
OnErrorResumeNext
objPP.Visible=True
Err.Clear
EndIf
EndSelect
OnErrorGoTo0
SetOffApp=objPP
SetobjPP=Nothing
EndFunction