Excel - PowerPoint - Textfelder - Diagramm!

Immer wieder gefragt: Wie bekomme ich einen Bereich bzw. ein Diagramm in eine PowerPoint Datei, die auf einer Vorlage basiert? Für jedes Tabellenblatt soll eine Folie angelegt werden, bestimmte Werte in zu erzeugende Textfelder kopiert werden. Platzhalter bzw. Titel sollen befüllt werden. Dann soll noch das im jeweiligen Tabellenblatt eingebettete Diagramm auf die entsprechende Folie übernommen werden. Erstellt und getestet habe ich das in Excel 2010 (ergo die PowerPoint-Dateien in PP2010). Für andere Excel- PowerPointversionen müssen Änderungen vorgenommen werden. Insbesondere beim Dateinamen der Vorlage und in Excel 2003 darf das PowerPoint-Fenster NICHT ausgeblendet bleiben - das führt zu einem Fehler.

Excel - PowerPoint - Textfelder - Diagramm...[ZIP, 200 KB]

Code gehört in ein allgemeines Modul:
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 GW_HWNDNEXT = 2
Const SW_MINIMIZE = 6
Dim blnTMP As Boolean
Const strPPSave As String = "EXCELnachPP" ' anpassen!!!
Public Sub Test()
Dim objAppPraes As Object
Dim intSheet As Integer
Dim objShape As Object
Dim objSlide As Object
Dim objChart As Object
Dim intTMP As Integer
Dim objApp As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set objApp = OffApp("PowerPoint", False)
If Not objApp Is Nothing Then
Set objAppPraes = objApp.Presentations.Open _
(ThisWorkbook.Path & "\" & _
"TestVorlagePP2010.potx", Untitled:=msoCTrue)
Call PP_Klein
With objAppPraes
For Each objShape In .Slides(.Slides.Count).Shapes
' 3 = ppPlaceholderCenterTitle
' 4 = ppPlaceholderSubtitle
If objShape.PlaceHolderFormat.Type = 3 Then
objShape.TextFrame.TextRange.Text = _
Tabelle1.Range("A1").Text
ElseIf objShape.PlaceHolderFormat.Type = 4 Then
objShape.TextFrame.TextRange.Text = _
Tabelle1.Range("A2").Text
End If
Next objShape
' 11 = ppLayoutTitleOnly
For intSheet = 1 To ThisWorkbook.Worksheets.Count
Set objSlide = .Slides.Add(.Slides.Count + 1, 11)
.Slides(.Slides.Count).Shapes.Title _
.TextFrame.TextRange.Text = _
ThisWorkbook.Worksheets(intSheet).Range("B1").Text
' 1 = msoShapeRectangle
For intTMP = 1 To 9
With objSlide.Shapes.AddShape(Type:=1, _
Top:=100 + 40 * intTMP, _
Left:=60, _
Width:=50, _
Height:=20)
.Name = "Text" & intTMP
.Fill.ForeColor.RGB = RGB(223, 223, 223)
' 1 = msoLineSolid
.Line.DashStyle = 1
With .TextFrame.TextRange
.Text = ThisWorkbook.Worksheets(intSheet) _
.Cells(intTMP, 8).Text
.Font.Color.RGB = RGB(0, 0, 128)
.Font.Name = "Arial"
.Font.Size = 12
End With
End With
Next intTMP
ThisWorkbook.Worksheets(intSheet) _
.Shapes("TestChart").CopyPicture
' 3 = ppPasteMetafilePicture
Set objChart = objSlide.Shapes _
.PasteSpecial(DataType:=3)(1)
With objChart
.Top = 140
.Left = 140
.Width = 520
.Height = 320
End With
Next intSheet
.SaveAs ThisWorkbook.Path & "\" & strPPSave
End With
Else
MsgBox "Applikation nicht installiert!"
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
Set objSlide = Nothing
Set objAppPraes = Nothing
Set objApp = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = 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

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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