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

Frage: Drei Diagramme sollen nach PowerPoint auf eine Folie kopiert und plaziert werden. Wie geht das?

Three charts to be copied to PowerPoint on a slide and placed. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Excel - PowerPoint - drei Diagramme auf eine Folie...[XLS 80 KB]

' Leeres Slide in PowerPoint
Const ppLayoutBlank As Long = 12
' Objektvariable für Applikation
Dim objPP As Object
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.04.2013
' Purpose   : PowerPoint - New Presentation - Slide add - Chart...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim intHeight As Integer
    Dim intWidth As Integer
    Dim intCount As Integer
    Dim objShape As Object
    Dim objPPDoc As Object
    Dim intLeft As Integer
    Dim intTop As Integer
    Dim intTMP As Integer
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Abmasse bzw. der Abstand
    intHeight = 210
    intWidth = 340
    intCount = 10
    intLeft = 10
    intTop = 10
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' 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
    End With
    ' PowerPoint starten
    ' Wenn PowerPoint ausgeblendet werden soll, dann so:
    ' http://vbanet.blogspot.de/2010/09/excel-powerpoint.html
    Set objPP = OffApp("PowerPoint")
    If Not objPP Is Nothing Then
        With objPP
            ' Neue Präsentation
            .Presentations.Add
            ' Neues LEERES Slide
            .ActivePresentation.Slides.Add 1, ppLayoutBlank
            ' Objektvariable mit dem Slide füllen
            Set objPPDoc = .ActivePresentation.Slides(1)
        End With
        For intTMP = 1 To Sheet1.ChartObjects.Count
            ' Diagramm als Bild kopieren
            Sheet1.ChartObjects(intTMP).Chart.CopyPicture 1, 1, -4147
            ' Objektvariable mit dem eingefügten Shape füllen
            Set objShape = objPPDoc.Shapes.Paste
            ' Plazieren
            With objShape
                .Top = intCount
                .Height = intHeight
                .Width = intWidth
                If intTMP = 3 Then
                    .Left = intLeft + .Width + intLeft
                    .Top = 10
                Else
                    .Left = intLeft
                End If
                intCount = intCount + .Height + intTop
            End With
        Next intTMP
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    ' Objektvariablen zurücksetzen
    Set objShape = Nothing
    Set objPPDoc = Nothing
    Set objPP = Nothing
    ' Die Applikation aufwecken
    With Application
        ' 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
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.04.2013
' Purpose   : Start application...
'--------------------------------------------------------------------------
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            If blnVisible = True Then
                On Error Resume Next
                objPP.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
End Function

Hier wird PowerPoint ausgeblendet - läuft nicht in allen Versionen.

Here is PowerPoint hidden - does not run on all versions.

Option Explicit
Private Declare Function GetWindowText Lib "user32" _
    Alias "GetWindowTextA" (ByVal hwnd As Long, _
    ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal _
    hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetWindow Lib "user32" _
    (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias _
    "GetTempPathA" (ByVal strBufferLength As Long, ByVal _
    lpBuffer As String) As Long
Private Declare Function GetParent Lib "user32" _
    (ByVal hwnd As Long) As Long
Const strPPSave As String = "Test.ppt" ' anpassen!!!
Const GW_HWNDNEXT = 2
Const SW_MINIMIZE = 6
' Leeres Slide in PowerPoint
Const ppLayoutBlank As Long = 12
' Objektvariable für Applikation
Dim objPP As Object
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main_1
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.04.2013
' Purpose   : PowerPoint - New Presentation - Slide add - Chart...
'--------------------------------------------------------------------------
Public Sub Main_1()
    ' Variablendeklaration
    Dim intHeight As Integer
    Dim intWidth As Integer
    Dim intCount As Integer
    Dim objShape As Object
    Dim objPPDoc As Object
    Dim intLeft As Integer
    Dim intTop As Integer
    Dim intTMP As Integer
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Abmasse bzw. der Abstand
    intHeight = 210
    intWidth = 340
    intCount = 10
    intLeft = 10
    intTop = 10
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' 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
    End With
    ' PowerPoint starten
    ' Wenn PowerPoint ausgeblendet werden soll, dann so:
    ' http://vbanet.blogspot.de/2010/09/excel-powerpoint.html
    Set objPP = OffApp("PowerPoint")
    If Not objPP Is Nothing Then
        With objPP
            ' Neue Präsentation
            .Presentations.Add
            ' Neues LEERES Slide
            .ActivePresentation.Slides.Add 1, ppLayoutBlank
            Call PP_Klein
            ' Objektvariable mit dem Slide füllen
            Set objPPDoc = .ActivePresentation.Slides(1)
        End With
        For intTMP = 1 To Sheet1.ChartObjects.Count
            ' Diagramm als Bild kopieren
            Sheet1.ChartObjects(intTMP).Chart.CopyPicture 1, 1, -4147
            ' Objektvariable mit dem eingefügten Shape füllen
            Set objShape = objPPDoc.Shapes.Paste
            ' Plazieren
            With objShape
                .Top = intCount
                .Height = intHeight
                .Width = intWidth
                If intTMP = 3 Then
                    .Left = intLeft + .Width + intLeft
                    .Top = 10
                Else
                    .Left = intLeft
                End If
                intCount = intCount + .Height + intTop
            End With
        Next intTMP
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    ' Objektvariablen zurücksetzen
    Set objShape = Nothing
    Set objPPDoc = Nothing
    Set objPP = Nothing
    ' Die Applikation aufwecken
    With Application
        ' 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
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.04.2013
' Purpose   : Start application...
'--------------------------------------------------------------------------
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            If blnVisible = True Then
                On Error Resume Next
                objPP.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
End Function
Private Sub PP_Klein()
    Dim hWindow As Long
    hWindow = SearchHndByWndName_Parent("Microsoft PowerPoint")
    Call ShowWindow(hWindow, SW_MINIMIZE)
End Sub
Private Function SearchHndByWndName_Parent(strSearch As String) As Long
    Dim strTMP As String * 100
    Dim nhWnd As Long
    nhWnd = FindWindow(vbNullString, vbNullString)
    Do While Not nhWnd = 0
        If GetParent(nhWnd) = 0 Then
            GetWindowText nhWnd, strTMP, 100
            If InStr(strTMP, strSearch) > 0 Then
                SearchHndByWndName_Parent = nhWnd
                Exit Do
            End If
        End If
        nhWnd = GetWindow(nhWnd, GW_HWNDNEXT)
    Loop
End Function

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...