asked on

Resizing Image in Power Point VBA

I have this code that works really well in excel...I wanted the existing code to actually paste it with height and width of the image so that it fits on my slide. It currently pastes the image big and I have to go into each slide and resize all of them. Atleast resize it within the slide parameters...

Here is the code.

Sub PasteMultipleSlides()

Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long

On Error Resume Next

Set PowerPointApp = GetObject(class:="PowerPoint.Application")

Err.Clear

If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, aborting."
Exit Sub
End If

If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If

On Error GoTo 0

PowerPointApp.ActiveWindow.Panes(2).Activate

Set myPresentation = PowerPointApp.ActivePresentation

MySlideArray = Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20)

MyRangeArray = Array(Sheet12.Range("A1:F50"), Sheet1.Range("A1:K17"), _
Sheet13.Range("A1:G50"), Sheet15.Range("A1:K17"), _
Sheet14.Range("A1:H30"), Sheet16.Range("A1:K17"), _
Sheet20.Range("A1:I30"), Sheet17.Range("A1:K17"), _
Sheet21.Range("A1:I50"), Sheet18.Range("A1:K17"), _
Sheet22.Range("A1:F50"), Sheet19.Range("A1:K17"), _
Sheet2.Range("A1:E50"), Sheet23.Range("A1:K17"), _
Sheet5.Range("A1:H17"))

For x = LBound(MySlideArray) To UBound(MySlideArray)
MyRangeArray(x).Copy

On Error Resume Next
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0

With myPresentation.PageSetup
shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
End With

Next x

Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Complete!"

End Sub

Jamie Garroch (MVP)

Change this bit:

      With myPresentation.PageSetup
        shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
        shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
      End With

Open in new window

to this:

      With myPresentation.PageSetup
        shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
        shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
        shp.Width = .SlideWidth
        shp.Height = .SlideHeight
      End With

Open in new window

LUIS FREUND

ASKER

Close.....it still does the same on some slides. Others are still big.....

ASKER CERTIFIED SOLUTION

Jamie Garroch (MVP)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial