PowerPoint - Bilder nach Excel holen...

Frage: Eine Powerpointdatei enthält einige Bilder. Diese Bilder brauche ich in Excel. Wie geht das?
Info: Funktioniert nicht mit PowerPoint 2013 (im Moment). Speichern als HTML ist dort wohl nicht vorgesehen.

A PowerPoint file contains a few pictures. These pictures I need in Excel. How does it work?
Info: Does not work with PowerPoint 2013 (at the moment). Save as HTML is not well provided there.

Link: PP 2010 and Save as HTML...

Achtung! / Attention! PowerPoint - Bilder nach Excel holen - the next level...

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

Option Explicit
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
' 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      : 14.02.2013 
' Purpose   : Bilder aus PowerPoint nach Excel holen... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Variablendeklaration 
    Dim objPicture As Picture
    Dim strTMPPath As String
    Dim strFile As String
    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"
        ' TEMP - Pfad bilden - muss NUR angepasst werden, wenn ENGLISCHE 
        ' Excelversion - dann heisst es NICHT "-Dateien" sondern "_files" 
        strTMPPath = strPath & Application.PathSeparator & _
            strName & "-Dateien" & Application.PathSeparator
        ' Erste Grafikdatei in Variable holen 
        strFile = Dir$(strTMPPath & "*.jpg", vbDirectory)
        ' In Zeile 2 mit dem Einfügen beginnen 
        lngRow = 2
        ' Mach das solange bis keine JPG-Datei mehr im Ordner ist 
        Do While strFile <> ""
            With ThisWorkbook.Worksheets(1)
                ' Einfügen und anpassen 
                With .Cells(lngRow, 2)
                    Set objPicture = .Parent.Pictures.Insert _
                        (strTMPPath & strFile)
                    objPicture.Top = .Top
                    objPicture.Left = .Left
                    objPicture.Height = .Height
                    objPicture.Width = .Width
                End With
                ' Nächstes Bild 2 Zeilen weiter unten einfügen 
                lngRow = lngRow + 2
            End With
            ' Nächste Datei in die Variable holen 
            strFile = Dir$()
        Loop
        ' Wenn der Pfad existiert, dann lösche den Ordner 
        If IsFilePath(strPath) Then Call FolDel
    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
    ' 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      : 14.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      : 14.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)
    ' 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

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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