AW: VBA Excel/PPt 2010: Copy Picture auf neues Slide
23.02.2013 12:11:13
fcs
Hallo Peter,
ich hab es mal versucht. Es ist mir aber nicht gelungen von Excel aus auf die aktive Präsentation in PowerPoint zuzugreifen. Entweder wurde automatisch eine leere neue Präsentation angelegt und danach gab es Probleme mit dem Zugriff auf die schon geöffnete Datei oder es konnte kein Active-X-Objekt erstellt werden.
Es funktioniert nur wenn der komplette Ablauf von Excel gesteuert wird. D.h. die PP-Datei darf noch nicht geöffnet sein!!
Dazu wird beim 1. Makrodurchlauf nach der PP-Datei gefragt in der die Slides mit Diagrammen angehängt werden sollen. Das Makro dupliziert die letzte vorhandene Folie, löscht ggf. das letzte vorhandene Shape-Objekt (sollte ein Diagramm sein) und fügt das neue Diagramm ein.
Excel speichert das PP-Objekt für die Diagramme solange bis die Exceldatei geschlossen wird oder die PP-Datei mit dem 2. Makro geschlossen wird. Solange können dann auch weitere Folien angehängt werden.
Gruß
Franz
'Code in einem allgemeinen Modul in Excel
'Erstellt unter Excel 2010 / Poweroint 2010
Option Explicit
Private Pfad As String
Private PP As Object, objPraes As Object
Sub Excel_nach_PP()
Dim objSlide As Object, objSlideRange As Object
Dim objShape As Object
Dim objChart As Chart
'Diagramm auswählen, in dem das Diagramm angefügt werden soll
If Pfad = "" Then
With Application.FileDialog(msoFileDialogOpen)
.Title = "Bitte PowerPoint-Datei auswälen in der Folie mit Diagramm angefügt werden _
soll"
.InitialFileName = "*.ppt*"
If .Show = -1 Then
Pfad = .SelectedItems(1)
Else
GoTo Beenden
End If
End With
Set PP = CreateObject("PowerPoint.Application")
PP.Visible = True
With PP
Set objPraes = .Presentations.Open(Pfad)
End With
PP.Visible = msoTrue
End If
'Letzte Folie kopieren und letztes Shape-Objekt löschen (sollte das Diagramm aus Excel sein) _
Set objSlide = objPraes.Slides(objPraes.Slides.Count)
objSlide.Duplicate
Set objSlide = objPraes.Slides(objPraes.Slides.Count)
With objSlide
If .Shapes.Count > 0 Then
Set objShape = .Shapes(.Shapes.Count)
objShape.Delete
End If
End With
'Neu eingefügte Folie selektieren
Set objSlide = objPraes.Slides(objPraes.Slides.Count)
objSlide.Select
'Diagrammbereich kopieren und positionieren
' Set objChart = Worksheets("Tabelle1").ChartObjects("Diagramm 1").Chart '###anPassen!!
Set objChart = ActiveWorkbook.Charts("Diagramm_DE") '###anPassen!!
objChart.ChartArea.Copy
' PP.ActiveWindow.View.PasteSpecial DataType:=10, Link:=msoFalse '10 = ppPasteOLEObject
PP.ActiveWindow.View.PasteSpecial DataType:=3 '3 = ppPasteMetafilePicture
With objSlide
Set objShape = .Shapes(.Shapes.Count)
With objShape
' .Top = 20
' .Left = 20
End With
End With
Application.CutCopyMode = False
PP.ActiveWindow.WindowState = 2 '2=ppWindowMinimized
Beenden:
Set objSlide = Nothing: Set objShape = Nothing
End Sub
Sub PP_Datei_Save_and_Close()
'Speichert die PowerPoint-Datei und schliesst die PowerPoint-Anwendung wieder
On Error Resume Next
If Not PP Is Nothing Then
objPraes.Save
objPraes.Close
PP.Quit
Pfad = ""
Set PP = Nothing: Set objPraes = Nothing
End If
End Sub