Option
Explicit
Sub
Test()
Dim
ppt
As
PowerPoint.Application
Dim
pptPres
As
PowerPoint.Presentation
Dim
pptSlide
As
PowerPoint.Slide
Set
ppt =
New
PowerPoint.Application
Set
pptPres = ppt.Presentations.Add(WithWindow:=msoFalse)
Dim
pptShp(1
To
2)
As
PowerPoint.Shape
Dim
rngCell
As
Excel.Range
Set
rngCell = Worksheets(
"Tabelle1"
).Range(
"A1"
)
Do
Until
Trim$(rngCell.Text) =
""
Set
pptSlide = pptPres.Slides.AddSlide(1 + pptPres.Slides.Count, pptPres.Designs(1).SlideMaster.CustomLayouts(7))
Set
pptShp(1) = pptSlide.Shapes.AddPicture( _
Filename:=Trim$(rngCell.Offset(, 1).Text), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, Top:=0)
Set
pptShp(2) = pptSlide.Shapes.AddPicture( _
Filename:=Trim$(rngCell.Offset(, 2).Text), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=15, Top:=15)
Set
rngCell = rngCell.Offset(1)
Loop
pptPres.SaveAs
"D:\MyTestFile"
ppt.Quit
End
Sub