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