AW: Anfänger braucht Hilfe
18.08.2023 10:41:34
Ulf
Hallo Olga,
Diese Frage ist mehrfach hier aufgetaucht, ohne anzugeben wie die entsprechende Tabelle aussieht, ist das nicht ohne weiteres machbar.
Bisher testweise:
Option Explicit
Sub Test()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim strPfad As String, strPOTX As String, pptVorlage As String
Dim strBild As String
'Name des Shapes
strBild = "Logo"
'Temporäre Datei
Dim strBildDatei As String
strPOTX = "xl.pptx"
'Gleicher Pfad wie diese Datei
strPfad = ThisWorkbook.Path
If Right(strPfad, 1) > "\" Then
strPfad = strPfad & "\"
pptVorlage = strPfad & strPOTX
End If
Set pptApp = New PowerPoint.Application
pptApp.Presentations.Open Filename:=pptVorlage, untitled:=msoTrue
Set pptPres = pptApp.ActivePresentation
With pptPres
With .Slides(1)
'dein Code
strBildDatei = Environ("TEMP") & "\" & strBild & ".png"
If SaveShapeAsPicture(ActiveSheet.Shapes("Logo"), strBildDatei) Then
.Shapes("Bild").Fill.UserPicture (strBildDatei)
End If
End With
'Zum Testen offen lassen
'.SaveAs strPfad & Range("rng_Title") & ".pptx"
'.Close
End With
'pptApp.Quit
End Sub
Public Function SaveShapeAsPicture(ByRef ActiveShape As Shape, ByVal strBildDatei As String) As Boolean
On Local Error GoTo SaveShapeAsPictureERR
Dim bOK As Boolean
Dim cht As ChartObject
Dim UserSelection As Variant
Set cht = ActiveSheet.ChartObjects.Add( _
Left:=ActiveCell.Left, _
Width:=ActiveShape.Width, _
Top:=ActiveCell.Top, _
Height:=ActiveShape.Height)
cht.ShapeRange.Fill.Visible = msoFalse
cht.ShapeRange.Line.Visible = msoFalse
ActiveShape.Copy
cht.Activate
ActiveChart.Paste
cht.Chart.Export strBildDatei
cht.Delete
bOK = True
SaveShapeAsPictureOUT:
SaveShapeAsPicture = bOK
Exit Function
SaveShapeAsPictureERR:
bOK = False
Resume SaveShapeAsPictureOUT
End Function
Anbei 2 Dateien Excel mit Bild und PPT zum Test
https://www.herber.de/bbs/user/162372.zip
Anzupassen: Powerpoint Namen, Excel Bilder in Schleife abarbeiten
Mehr Infos oder selber tätig sein
hth
Ulf