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]

OptionExplicit
PrivateDeclareFunction GetWindowText Lib"user32" _
    Alias"GetWindowTextA" (ByVal hwnd AsLong, _
    ByVal lpString AsString, ByVal cch AsLong) AsLong
PrivateDeclareFunction FindWindow Lib"user32" _
    Alias"FindWindowA" (ByVal lpClassName AsString, _
    ByVal lpWindowName AsString) AsLong
PrivateDeclareFunction ShowWindow Lib"user32" (ByVal _
    hwnd AsLong, ByVal nCmdShow AsLong) AsLong
PrivateDeclareFunction GetWindow Lib"user32" _
    (ByVal hwnd AsLong, ByVal wCmd AsLong) AsLong
PrivateDeclareFunction GetParent Lib"user32" _
    (ByVal hwnd AsLong) AsLong
PrivateDeclareFunction PathFileExists Lib"shlwapi.dll" _
    Alias"PathFileExistsA" (ByVal pszPath AsString) AsLong
PrivateDeclareFunction MakeSureDirectoryPathExists _
    Lib"imagehlp.dll" (ByVal Pfad AsString) AsLong
PrivateDeclareFunction SafeArrayGetDim Lib"oleaut32.dll" _
    (ByRef pArray() AsAny) AsLong
Private strList() AsString
Private lngCount AsLong
Const GW_HWNDNEXT = 2
Const SW_MINIMIZE = 6
' TEMP Pfad - muss in der Regel nicht angepasst werden 
Const strPath AsString = "C:\PicTMP"
' Konstanten 
Const strName AsString = "tmp"
Const PpSaveAsHTML = 12
' Variablen 
Dim blnPPT AsBoolean
Dim blnTMP AsBoolean
Dim objPP AsObject
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.02.2013 
' Purpose   : Bilder aus PowerPoint nach Excel holen... 
'-------------------------------------------------------------------------- 
PublicSub Main()
    ' Variablendeklaration 
    Dim intCount AsInteger
    Dim lngRow AsLong
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    OnErrorGoTo Fin
    ' Die PowerPointapplikation starten 
    Set objPP = OffApp("PowerPoint")
    IfNot objPP IsNothingThen
        ' 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) <> 0Then
            ' Schleife über alle Einträge 
            For intCount = Lbound(strList) ToUbound(strList)
                With ThisWorkbook.Worksheets(1)
                ' Einfügen und anpassen 
                    With .OLEObjects(intCount + 1)
                        .Object.PictureSizeMode = fmPictureSizeModeStretch
                        .Object.Picture = LoadPicture(strList(intCount))
                    EndWith
                    ' Nächstes Bild 2 Zeilen weiter unten einfügen 
                    lngRow = lngRow + 2
                EndWith
            Next intCount
            ' Array leeren 
            Erase strList
        EndIf
    Else
        MsgBox "Application is not installed!"
    EndIf
Fin:
    ' Aufräumen 
    IfNot objPP IsNothingThen
        If blnPPT = TrueThen
            objPP.Quit
            blnPPT = False
        EndIf
    EndIf
    ' Wenn der Pfad existiert, dann lösche den Ordner 
    If IsFilePath(strPath) ThenCall FolDel
    ' Objektvariable zurücksetzen 
    Set objPP = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0Then MsgBox "Fehler: "& _
        Err.Number &" "& Err.Description
EndSub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.02.2013 
' Purpose   : Application starten... 
'-------------------------------------------------------------------------- 
PrivateFunction OffApp(ByVal strApp AsString, _
    Optional blnVisible AsBoolean = False) AsObject
    OnErrorResumeNext
    Set objPP = GetObject(, strApp &".Application")
    SelectCase Err.Number
        Case429
            Err.Clear
            Set objPP = CreateObject(strApp &".Application")
            blnPPT = True
            If blnVisible = TrueThen
                OnErrorResumeNext
                objPP.Visible = True
                Err.Clear
            EndIf
    EndSelect
    OnErrorGoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
EndFunction
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : PPPicture 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.02.2013 
' Purpose   : PowerPoint - Datei als HTML spaichern... 
'-------------------------------------------------------------------------- 
PrivateSub PPPicture(strFileName AsString)
    Dim objPPT AsObject
    ' 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
EndSub
PrivateSub FolDel()
    Dim objFSO AsObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Ordner löschen 
    objFSO.DeleteFolder strPath
    Set objFSO = Nothing
EndSub
PrivateFunction IsFilePath(strPath AsString) AsBoolean
    IsFilePath = CBool(PathFileExists(strPath))
EndFunction
PrivateSub PP_Klein()
    Dim hWindow AsLong
    hWindow = SearchHndByWndName_Parent("Microsoft PowerPoint")
    Call ShowWindow(hWindow, SW_MINIMIZE)
EndSub
PrivateFunction SearchHndByWndName_Parent(strSearch AsString) AsLong
    Dim strTMP AsString * 100
    Dim nhWnd AsLong
    nhWnd = FindWindow(vbNullString, vbNullString)
    DoWhileNot nhWnd = 0
        If GetParent(nhWnd) = 0Then
            GetWindowText nhWnd, strTMP, 100
            If InStr(strTMP, strSearch) > 0Then
                SearchHndByWndName_Parent = nhWnd
                ExitDo
            EndIf
        EndIf
        nhWnd = GetWindow(nhWnd, GW_HWNDNEXT)
    Loop
EndFunction
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : SearchFiles 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.02.2013 
' Purpose   : Dateiliste erstellen... 
'-------------------------------------------------------------------------- 
PrivateSub SearchFiles(strFolder AsString, strFileName AsString)
    Dim objFolder AsObject
    Dim objFile AsObject
    Dim objFSO AsObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ForEach objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName Then
            RedimPreserve strList(lngCount)
            strList(lngCount) = objFile.Path
            lngCount = lngCount + 1
        EndIf
    Next
    ForEach objFolder In objFSO.GetFolder(strFolder).Subfolders
        SearchFiles strFolder &"\"& objFolder.Name, strFileName
    Next
EndSub