PowerPoint - Bilder nach Excel holen - the next level...

Frage: Zu dem Thema "Bilder aus PowerPoint nach Excel" gab es verschiedene Nachfragen. Die Bilder werden nicht permanent gespeichert. Ein Problem aus Excel 2010. Im Netz gibt es verschiedene Lösungen. Ich lade die Bilder in ein ActiveX Steuerelement (Image). Die Verzeichnisauswahl (temporäre Bilder) habe ich geändert. PowerPoint soll minimiert werden. Läuft nicht unter PowerPoint 2003. Codezeile löschen oder kommentieren. Getestet in Excel 2007 und 2010. Für andere Versionen muss gegebenenfalls angepasst werden.

On the topic of "images from PowerPoint to Excel" there were different demands. The images are not stored permanently. A problem of Excel 2010. On the web there are various solutions. I load the images in an ActiveX control (Image). The directory selection (temporary images) I have changed. PowerPoint should be minimized. Does not work in PowerPoint 2003. Line of code to delete or comment. Tested in Excel 2007 and 2010. For other versions may need to be adjusted.

Hier noch eine Beispieldatei / Here's a sample file:
PowerPoint - Bilder nach Excel holen - the next level...[ZIP 500 KB]

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 GetParent Lib "user32" _
    (ByVal hwnd As Long) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" _
    Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" _
    (ByRef pArray() As Any) As Long
Private strList() As String
Private lngCount As Long
Const GW_HWNDNEXT = 2
Const SW_MINIMIZE = 6
' TEMP Pfad - muss in der Regel nicht angepasst werden 
Const strPath As String = "C:\PicTMP"
' Konstanten 
Const strName As String = "tmp"
Const PpSaveAsHTML = 12
' Variablen 
Dim blnPPT As Boolean
Dim blnTMP As Boolean
Dim objPP As Object
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.02.2013 
' Purpose   : Bilder aus PowerPoint nach Excel holen... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Variablendeklaration 
    Dim intCount As Integer
    Dim lngRow As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die PowerPointapplikation starten 
    Set objPP = OffApp("PowerPoint")
    If Not objPP Is Nothing Then
        ' Die Sub "PPPicture" mit Parameter aufrufen 
        PPPicture ThisWorkbook.Path & Application.PathSeparator & _
            "Picture.ppt"
        SearchFiles strPath, "*.jpg"
        ' In Zeile 2 mit dem Einfügen beginnen 
        lngRow = 2
        ' Wenn das Array dimensioniert, dann... 
        If SafeArrayGetDim(strList) <> 0 Then
            ' Schleife über alle Einträge 
            For intCount = Lbound(strList) To Ubound(strList)
                With ThisWorkbook.Worksheets(1)
                ' Einfügen und anpassen 
                    With .OLEObjects(intCount + 1)
                        .Object.PictureSizeMode = fmPictureSizeModeStretch
                        .Object.Picture = LoadPicture(strList(intCount))
                    End With
                    ' Nächstes Bild 2 Zeilen weiter unten einfügen 
                    lngRow = lngRow + 2
                End With
            Next intCount
            ' Array leeren 
            Erase strList
        End If
    Else
        MsgBox "Application is not installed!"
    End If
Fin:
    ' Aufräumen 
    If Not objPP Is Nothing Then
        If blnPPT = True Then
            objPP.Quit
            blnPPT = False
        End If
    End If
    ' Wenn der Pfad existiert, dann lösche den Ordner 
    If IsFilePath(strPath) Then Call FolDel
    ' Objektvariable zurücksetzen 
    Set objPP = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.02.2013 
' Purpose   : Application starten... 
'-------------------------------------------------------------------------- 
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = False) As Object
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            blnPPT = True
            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
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : PPPicture 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.02.2013 
' Purpose   : PowerPoint - Datei als HTML spaichern... 
'-------------------------------------------------------------------------- 
Private Sub PPPicture(strFileName As String)
    Dim objPPT As Object
    ' Ordner erstellen - beste Methode 
    MakeSureDirectoryPathExists strPath & Application.PathSeparator
    ' PowerPointdatei öffnen bzw. an Objektvariable binden 
    Set objPPT = objPP.Presentations.Open(strFileName)
    ' PowerPoint per API ausblenden 
    ' WICHTIG! Wenn es Probleme gibt die nächste Zeile AUSKOMMENTIEREN!!! 
    Call PP_Klein
    ' Als HTML speichern 
    objPPT.SaveAs strPath & Application.PathSeparator & _
        strName, PpSaveAsHTML
    ' Schliessen 
    objPPT.Close
    Set objPPT = Nothing
End Sub
Private Sub FolDel()
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Ordner löschen 
    objFSO.DeleteFolder strPath
    Set objFSO = Nothing
End Sub
Private Function IsFilePath(strPath As String) As Boolean
    IsFilePath = CBool(PathFileExists(strPath))
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
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : SearchFiles 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.02.2013 
' Purpose   : Dateiliste erstellen... 
'-------------------------------------------------------------------------- 
Private Sub SearchFiles(strFolder As String, strFileName As String)
    Dim objFolder As Object
    Dim objFile As Object
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName Then
            Redim Preserve strList(lngCount)
            strList(lngCount) = objFile.Path
            lngCount = lngCount + 1
        End If
    Next
    For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
        SearchFiles strFolder & "\" & objFolder.Name, strFileName
    Next
End Sub