PowerPoint - bestehende Datei - vorhandene TextBoxen befüllen...

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      : 03.05.2013
' Purpose   : PowerPoint - Template - TextBoxen 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
SetobjPPPres=.Presentations.Open_
(Filename:=ThisWorkbook.Path&_
Application.PathSeparator&"Template1.ppt")
SetobjPPDoc=objPPPres.Slides(1)
' Schleife um 16 Zellinhalte nach 16 TextBoxen in PP zu kopieren
ForintTMP=1To16
objPPDoc.Shapes(intTMP).TextFrame.TextRange.Text=" Inhalt aus "&_
ThisWorkbook.Worksheets(1).Cells(intTMP,1).Value
NextintTMP
' Unter neuem Namen speichern
objPPPres.SaveAsThisWorkbook.Path&_
Application.PathSeparator&strPPSave&_
Format(Now,"ddMMyyyy_hhmmss")
' 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      : 03.05.2013
' 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