Private Sub RangeToPowerPoint(rng As Range, slide As Integer, size As Double, _
left As Integer, top As Integer, title As String)
Calculate
Dim pptSlide As PowerPoint.slide
Dim shapeRng As PowerPoint.ShapeRange
If slide = -1 Then
'Count the slides and add a new one after the last slide.
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
Else
Set pptSlide = pptPres.Slides(slide)
End If
'Copy the range and paste as image
rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Set shapeRng = pptSlide.Shapes.PasteSpecial(DataType:=0)
shapeRng.Line.Visible = msoFalse
shapeRng.left = left
shapeRng.top = top
shapeRng.ScaleHeight size, 2
shapeRng.ScaleHeight size, msoCTrue
shapeRng.ScaleWidth size, msoCTrue
shapeRng.ZOrder msoSendToBack
shapeRng.PictureFormat.CropLeft = 1
shapeRng.PictureFormat.CropTop = 1
End Sub
Bookmarks