Excel - PowerPoint - drei Diagramme auf eine Folie...

' Leeres Slide in PowerPoint
ConstppLayoutBlankAsLong=12
' Objektvariable für Applikation
DimobjPPAsObject
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.04.2013
' Purpose   : PowerPoint - New Presentation - Slide add - Chart...
'--------------------------------------------------------------------------
PublicSubMain()
' Variablendeklaration
DimintHeightAsInteger
DimintWidthAsInteger
DimintCountAsInteger
DimobjShapeAsObject
DimobjPPDocAsObject
DimintLeftAsInteger
DimintTopAsInteger
DimintTMPAsInteger
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Abmasse bzw. der Abstand
intHeight=210
intWidth=340
intCount=10
intLeft=10
intTop=10
' 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
' Neue Präsentation
.Presentations.Add
' Neues LEERES Slide
.ActivePresentation.Slides.Add1,ppLayoutBlank
' Objektvariable mit dem Slide füllen
SetobjPPDoc=.ActivePresentation.Slides(1)
EndWith
ForintTMP=1ToSheet1.ChartObjects.Count
' Diagramm als Bild kopieren
Sheet1.ChartObjects(intTMP).Chart.CopyPicture1,1,-4147
' Objektvariable mit dem eingefügten Shape füllen
SetobjShape=objPPDoc.Shapes.Paste
' Plazieren
WithobjShape
.Top=intCount
.Height=intHeight
.Width=intWidth
IfintTMP=3Then
.Left=intLeft+.Width+intLeft
.Top=10
Else
.Left=intLeft
EndIf
intCount=intCount+.Height+intTop
EndWith
NextintTMP
Else
MsgBox"Application not installed!"
EndIf
Fin:
' Objektvariablen zurücksetzen
SetobjShape=Nothing
SetobjPPDoc=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.04.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

OptionExplicit
PrivateDeclareFunctionGetWindowTextLib"user32"_
Alias"GetWindowTextA"(ByValhwndAsLong,_
ByVallpStringAsString,ByValcchAsLong)AsLong
PrivateDeclareFunctionFindWindowLib"user32"_
Alias"FindWindowA"(ByVallpClassNameAsString,_
ByVallpWindowNameAsString)AsLong
PrivateDeclareFunctionShowWindowLib"user32"(ByVal_
hwndAsLong,ByValnCmdShowAsLong)AsLong
PrivateDeclareFunctionGetWindowLib"user32"_
(ByValhwndAsLong,ByValwCmdAsLong)AsLong
PrivateDeclareFunctionGetTempPathLib"kernel32"Alias_
"GetTempPathA"(ByValstrBufferLengthAsLong,ByVal_
lpBufferAsString)AsLong
PrivateDeclareFunctionGetParentLib"user32"_
(ByValhwndAsLong)AsLong
ConststrPPSaveAsString="Test.ppt"' anpassen!!!
ConstGW_HWNDNEXT=2
ConstSW_MINIMIZE=6
' Leeres Slide in PowerPoint
ConstppLayoutBlankAsLong=12
' Objektvariable für Applikation
DimobjPPAsObject
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main_1
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.04.2013
' Purpose   : PowerPoint - New Presentation - Slide add - Chart...
'--------------------------------------------------------------------------
PublicSubMain_1()
' Variablendeklaration
DimintHeightAsInteger
DimintWidthAsInteger
DimintCountAsInteger
DimobjShapeAsObject
DimobjPPDocAsObject
DimintLeftAsInteger
DimintTopAsInteger
DimintTMPAsInteger
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Abmasse bzw. der Abstand
intHeight=210
intWidth=340
intCount=10
intLeft=10
intTop=10
' 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
' Neue Präsentation
.Presentations.Add
' Neues LEERES Slide
.ActivePresentation.Slides.Add1,ppLayoutBlank
CallPP_Klein
' Objektvariable mit dem Slide füllen
SetobjPPDoc=.ActivePresentation.Slides(1)
EndWith
ForintTMP=1ToSheet1.ChartObjects.Count
' Diagramm als Bild kopieren
Sheet1.ChartObjects(intTMP).Chart.CopyPicture1,1,-4147
' Objektvariable mit dem eingefügten Shape füllen
SetobjShape=objPPDoc.Shapes.Paste
' Plazieren
WithobjShape
.Top=intCount
.Height=intHeight
.Width=intWidth
IfintTMP=3Then
.Left=intLeft+.Width+intLeft
.Top=10
Else
.Left=intLeft
EndIf
intCount=intCount+.Height+intTop
EndWith
NextintTMP
Else
MsgBox"Application not installed!"
EndIf
Fin:
' Objektvariablen zurücksetzen
SetobjShape=Nothing
SetobjPPDoc=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.04.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
PrivateSubPP_Klein()
DimhWindowAsLong
hWindow=SearchHndByWndName_Parent("Microsoft PowerPoint")
CallShowWindow(hWindow,SW_MINIMIZE)
EndSub
PrivateFunctionSearchHndByWndName_Parent(strSearchAsString)AsLong
DimstrTMPAsString*100
DimnhWndAsLong
nhWnd=FindWindow(vbNullString,vbNullString)
DoWhileNotnhWnd=0
IfGetParent(nhWnd)=0Then
GetWindowTextnhWnd,strTMP,100
IfInStr(strTMP,strSearch)>0Then
SearchHndByWndName_Parent=nhWnd
ExitDo
EndIf
EndIf
nhWnd=GetWindow(nhWnd,GW_HWNDNEXT)
Loop
EndFunction