Vba Code Probleme

[thomson]

Hallo,
folgendes Problem! Habe einen VBA Code in Excel, der mir meine Bilder in Powerpoint exportiert!
Jetzt nimmt er aber nur die Bilder aus der Mappe in der der Button zum Makro ist und nicht die Bilder aus der ganzen Excel Mappe, was ist da falsch?

Sub jede_Grafik_nach_PowerPoint()
'Extras - Verweise: Microsoft PowerPoint x.x Object Library
Dim Grafik As Shape
Dim PP As PowerPoint.Application
Dim PP_Datei As PowerPoint.Presentation
Dim PP_Folie As PowerPoint.Slide

On Error GoTo Hell

Set PP = CreateObject("Powerpoint.Application")
With PP
  .Visible = True
  .Presentations.Add
End With

Set PP_Datei = PP.ActivePresentation

For Each Grafik In ActiveSheet.Shapes
 'neue Folie einfügen
  PP.ActivePresentation.Slides.Add 1, ppLayoutBlank
  Set PP_Folie = PP_Datei.Slides(1)
 'kopieren
  Grafik.CopyPicture
 'einfügen
  PP_Folie.Shapes.Paste
Next

Set PP_Folie = Nothing
Set PP_Datei = Nothing
Set PP = Nothing

Exit Sub

Hell:
Set PP_Folie = Nothing
Set PP_Datei = Nothing
Set PP = Nothing
    MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
    & "Beschreibung: " & Err.Description _
    , vbCritical, "Fehler"
End Sub

 

[Alex F.]

du läufts in deiner schleife durch ActiveSheet.shapes damit sind nur die Shapes gemeint die auf dem aktuellen Tabellenblatt sind.


Grüsse bb

 

[thomson]

Ok!? Aber wie sollte es dann heissen? Konnte nichts dazu finden!

 

[Alex F.]

Versuch es mal so

Dim sheet As Worksheet
    Dim oshape As Shape
    
    For Each sheet In ActiveWorkbook.Sheets
        For Each oshape In sheet.Shapes
            '...........
            ' Dein Code
            '...........
        Next oshape
    Next sheet

 

[thomson]

Hi danke für deine Hilfe, sorry für mein unwissen!
Habe den Code denke mal falsch!

Sub jede_Grafik_nach_PowerPoint()
'Extras - Verweise: Microsoft PowerPoint x.x Object Library
Dim Sheet As Worksheet
Dim oshape As Shape
Dim Grafik As Object
Dim PP As PowerPoint.Application
Dim PP_Datei As PowerPoint.Presentation
Dim PP_Folie As PowerPoint.Slide

On Error GoTo Hell

Set PP = CreateObject("Powerpoint.Application")
With PP
  .Visible = True
  .Presentations.Add
End With

Set PP_Datei = PP.ActivePresentation

For Each Sheet In ActiveWorkbook.Sheets
For Each oshape In Sheet.Shapes
 'neue Folie einfügen
  PP.ActivePresentation.Slides.Add 1, ppLayoutBlank
  Set PP_Folie = PP_Datei.Slides(1)
 'kopieren
  Grafik.CopyPicture
 'einfügen
  PP_Folie.Shapes.Paste
Next oshape
Next Sheet

Set PP_Folie = Nothing
Set PP_Datei = Nothing
Set PP = Nothing

Exit Sub

Hell:
Set PP_Folie = Nothing
Set PP_Datei = Nothing
Set PP = Nothing
    MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
    & "Beschreibung: " & Err.Description _
    , vbCritical, "Fehler"
End Sub

 

[Alex F.]

Fehler ist hier :

For Each oshape In Sheet.Shapes

bei dir muss es heissen :

For Each Grafik In Sheet.Shapes

Grüsse bb