Excel - PowerPoint!

Oft nachgefragt - wie bekomme ich einen Bereich aus Excel nach PowerPoint. Nachfolgend eine Möglichkeit. Die PowerPoint Datei kann wahlweise auf dem Desktop oder im TEMP Ordner gespeichert werden. Abfrage des Bereiches über eine InputBox. Da PowerPoint sich über "WindowState" nicht vernünftig ausblenden lässt, habe ich auf API zurück gegriffen.

Excel PowerPoint...[ZIP, 55 KB]

Code:
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
Dim objPPApp As Object
Public Sub PowerPoint_Slide()
Application.ScreenUpdating = False
On Error GoTo Fin
On Error Resume Next
Set objPPApp = GetObject(, "PowerPoint.Application")
Select Case Err.Number
Case 429
Err.Clear
Set objPPApp = CreateObject("PowerPoint.Application")
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objPPApp = Nothing
Exit Sub
End If
Case 0
Case Else
MsgBox Err.Number & " " & Err.Description
Set objPPApp = Nothing
Exit Sub
End Select
On Error GoTo 0
On Error GoTo Fin
Call Do_PowerPoint
Fin:
If Err.Number <> 0 Then
If Err.Number = 13 Then
MsgBox "Inputbox - Rangeauswahl abgebrochen!"
Else
MsgBox "Fehler: " & Err.Number & " " & Err.Description
End If
End If
If Not objPPApp Is Nothing Then objPPApp.Quit
Set objPPApp = Nothing
With Application
.ScreenUpdating = True
.CutCopyMode = False
.ThisWorkbook.Close False
End With
End Sub
Private Sub Do_PowerPoint()
Dim objPPSlide As Object
Dim objPPPraes As Object
Dim strFolder As String
Dim intCount As Integer
Dim objShape As Object
Dim varTMP As Variant
Dim intTMP As Integer
With objPPApp
Set objPPPraes = .Presentations.Add
Call PP_Klein
For intCount = 1 To 2 ' Schleifendurchlauf anpassen!!!
Application.ScreenUpdating = True
Set varTMP = Application.InputBox _
("Range", "Auswahl", , , , , , 8)
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets(varTMP.Parent.Name)
.Range(varTMP.Address).Copy
End With
'Const ppLayoutBlank = 12
Set objPPSlide = objPPPraes.Slides.Add _
(intCount + intTMP, 12)
intTMP = intTMP + 1
'Const ppPasteOLEObject = 10
'Const msoTrue = -1 (Element von Office.MsoTriState)
objPPSlide.Shapes.PasteSpecial 10, , , , , -1
Set objPPSlide = objPPPraes.Slides.Add _
(intCount + intTMP, 12)
intTMP = intTMP + 1
'Const ppPasteEnhancedMetafile = 2
objPPSlide.Shapes.PasteSpecial 2
Set objShape = objPPPraes.Slides.Item(objPPPraes.Slides.Count)
With objShape.Shapes.Item(objShape.Shapes.Count)
.Top = 60
.Left = 60
.Width = 350
.Height = 350
End With
Set objPPSlide = objPPPraes.Slides.Add _
(intCount + intTMP, 12)
With ThisWorkbook.Worksheets(varTMP.Parent.Name)
.Range(varTMP.Address).CopyPicture
End With
objPPSlide.Shapes.Paste
Set objShape = objPPPraes.Slides.Item(objPPPraes.Slides.Count)
With objShape.Shapes.Item(objShape.Shapes.Count)
.Top = 60
.Left = 60
.Width = 350
.Height = 350
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
Set objShape = Nothing
Set objPPSlide = Nothing
Set varTMP = Nothing
Next intCount
' speichert auf dem Desktop
strFolder = Environ("UserProfile") & "\Desktop\"
If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
' speichert im TEMP-Ordner
'strFolder = PP_Save
objPPPraes.SaveAs strFolder & strPPSave
End With
Set objPPPraes = Nothing
End Sub
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
Private Function PP_Save() As String
Dim strBuffer As String
Dim lngReturn As Long
strBuffer = Space(255)
lngReturn = GetTempPath(255, strBuffer)
If lngReturn > 0 Then
PP_Save = Left$(strBuffer, lngReturn)
Else
PP_Save = CurDir$
End If
If Right(PP_Save, 1) <> "\" Then PP_Save = PP_Save & "\"
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)...