Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema Frame
BildScreenshot zu Frame Frame-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema Image
BildScreenshot zu Image Image-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema Label
BildScreenshot zu Label Label-Seite mit Beispielarbeitsmappe aufrufen

VBA: Excel-Export als Screenshot in PPT


Betrifft: VBA: Excel-Export als Screenshot in PPT von: Victor
Geschrieben am: 18.10.2019 11:05:35

Hallo zusammen,

mit meinem aktuellen Code (siehe unten) wird ein Excel-Bereich automatisiert in eine PPT eingebettet.
Durch das Einbetten wird die PPT-Dateigröße sehr groß - daher würde ich das Ganze gerne als Screenshot einfügen.

Kennt ihr hierzu eine einfache Lösung ohne den gesamten Code neu aufzusetzen?

Vielen Dank im Voraus und freundliche Grüße

Set ppApp = CreateObject("Powerpoint.Application")
ppApp.Visible = msoTrue

Set PpDatei = ppApp.Presentations.Open(pfad & "Template.pptx", False, False, True)

Call Einbetten(rng:=wkb.Worksheets("Cockpit").Range("C36:AE39"), zahl:=2, z2:=1, pp:=ppApp)
Call Einbetten(rng:=wkb.Worksheets("Cockpit").Range("C10:H16"), zahl:=2, z2:=4, pp:=ppApp)
Call Einbetten(rng:=wkb.Worksheets("Cockpit").Range("C43:AE60"), zahl:=2, z2:=2, pp:=ppApp)
Call Einbetten(rng:=wkb.Worksheets("Cockpit").Range("C64:AE96"), zahl:=3, z2:=3, pp:=ppApp)


ppApp.ActivePresentation.Slides(1).Shapes("Rechteck 1").TextFrame.TextRange.Text = wkb.Worksheets("Hilfe").Range("A4").Value
numSlides = ppApp.ActivePresentation.Slides.Count
For intSlides = 2 To numSlides
ppApp.ActivePresentation.Slides(intSlides).Shapes("Fußzeilenplatzhalter 2").TextFrame.TextRange.Text = wkb.Worksheets("Hilfe").Range("A4").Value
Next intSlides

'Präsentation als neue Präsentation speichern
PpDatei.SaveAs pfad & name & "_" & num & ".pptx"
wkb.Worksheets("Hilfe").Range("B4").Value = num + 1


End Sub

Sub Einbetten(rng As Excel.Range, zahl As Integer, z2 As Integer, pp As Object)

Dim ppShape As Object
Dim ppSlide As Object
Dim num As Integer

rng.Copy

'Excelbereich als Grafik auf Folie einfügen
' pp.ActivePresentation.Slides(zahl).Shapes.PasteSpecial DataType:=2 '2=ppPasteEnhancedMetafile
'Excelbereich als Excel-Objekt ohne Verknüpfung auf Folie einfügen
pp.ActivePresentation.Slides(zahl).Shapes.PasteSpecial DataType:=10, Link:=msoFalse '10= ppPasteOLEObject

'eingefügtes Object - Shape-Objekt-Variable zuweisen
Set ppShape = pp.ActivePresentation.Slides(zahl).Shapes(pp.ActivePresentation.Slides(zahl).Shapes.Count)

'Eingefügtes Shape formatieren
If z2 = 1 Then

With ppShape
'Shape positionieren (zentrieren auf Folie)
'.Height = 78
.Width = 886
.Top = 112
.Left = pp.ActivePresentation.Slides(zahl).Parent.PageSetup.SlideWidth / 2 - ppShape.Width / 2

End With
End If

  

Betrifft: AW: VBA: Excel-Export als Screenshot in PPT von: volti
Geschrieben am: 18.10.2019 13:09:58

Hallo Victor,

vielleicht kommst Du mit u.g. Tipp weiter:
Zum Verständnis hier mal ein (ungetesteter) Auszug aus meinem Kopierprogramm, welches neben Bereichen auch Diagramme/Shape kopieren und formatieren kann.
Als zweites die Umsetzung auf Dein Problem (ebenfalls ungetestet).

Sub KopierenEinfuegen()
 Dim Einfuegetyp As String
'Kopieren
 With Sheets(Excelblatt).Range(Bereich)
  Select Case Einfuegetyp
  Case "bitmap": .CopyPicture Appearance:=xlScreen, Format:=xlBitmap  'Bereich aus dem Excelregister kopieren als Bitmap
  Case "bild":   .CopyPicture Appearance:=xlScreen, Format:=xlPicture 'Bereich aus dem Excelregister kopieren als Bild
  Case "ole", "link": .Copy
  Case "": .Copy
  End Select
 End With
 
'Einfügen
 Select Case Einfuegetyp
 Case "bild", "bitmap": Set pptObjekt = pptFolie.Shapes.Paste
 Case "icon":           Set pptObjekt = pptFolie.Shapes.PasteSpecial(DataType:=10, DisplayAsIcon:=msoTrue, IconLabel:="New Bitmap Image")
 Case "link":           Set pptObjekt = pptFolie.Shapes.PasteSpecial(DataType:=10, DisplayAsIcon:=msoFalse)
 Case "ole":            Set pptObjekt = pptFolie.Shapes.Paste
 Case Else:             Set pptObjekt = pptFolie.View.Paste
 End Select
End Sub

Sub Victor()
 Rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
 pp.ActivePresentation.Slides(zahl).Shapes.Paste
'eingefügtes Object - Shape-Objekt-Variable zuweisen
Set ppShape = pp.ActivePresentation.Slides(zahl).Shapes(pp.ActivePresentation.Slides(zahl).Shapes.Count)
End Sub


viele Grüße
Karl-Heinz