CODEWITHSUNDEEP
excelvbapowerpoint
Mayank Jain
Mayank Jain

Reputation: 45

Not able to resize and position shapes in PowerPoint

I am working on a VBA script which copies some ranges from an Excel document to a PowerPoint document. I am able to do that successfully without any errors. However, after copying the range, when I resize and realign the shapes, I am not able to do so. What might I be missing?

I have defined the ranges of the Excel, slide numbers and the main Excel sheet in a separate file. So as of now, I am taking all the values from that separate file.

Option Explicit

Sub ExportToPPT()

    Dim ppt_app As New PowerPoint.Application
    Dim pre As PowerPoint.Presentation
    Dim slide As PowerPoint.slide
    Dim shp As PowerPoint.Shape
    Dim wb As Workbook
    Dim rng As Range

    Dim vSheet$
    Dim vRange$
    Dim vWidth As Double
    Dim vHeight As Double
    Dim vTop As Double
    Dim vLeft As Double

    Dim expRng As Range
    Dim vslidenum As Long

    Dim Adminsh As Worksheet
    Dim configRng As Range

    Dim xlfile$
    Dim pptfile$

    Application.DisplayAlerts = False
    Set Adminsh = ThisWorkbook.Sheets("Admin")
    ' "RangeLoop" is the loop range where we are defining the sheets
    Set configRng = Adminsh.Range("RangeLoop")

    xlfile = Adminsh.[ExcelPath]
    pptfile = Adminsh.[PPTPath]

    Set wb = Workbooks.Open(xlfile)
    Set pre = ppt_app.Presentations.Open(pptfile)

    wb.Activate

    For Each rng In configRng

        ' Pick values from the Excel sheet --------------------------------

        With Adminsh
            vSheet$ = .Cells(rng.Row, 2).Value
            vRange$ = .Cells(rng.Row, 3).Value

            vWidth = .Cells(rng.Row, 4).Value
            vHeight = .Cells(rng.Row, 5).Value
            vTop = .Cells(rng.Row, 6).Value
            vLeft = .Cells(rng.Row, 7).Value
            vslidenum = .Cells(rng.Row, 8).Value
        End With

        wb.Activate
        Sheets(vSheet$).Activate
        Set expRng = Sheets(vSheet$).Range(vRange$)
        expRng.Copy

        ' Paste values in PowerPoint-----------------------------------------------
        Set slide = pre.Slides(vslidenum)
        'ppt_app.Activate
        slide.Shapes.PasteSpecial ppPasteBitmap
        'ppt_app.ActiveWindow.View.PasteSpecial ppPasteOLEObject, msoFalse
        'slide.Shapes.PasteSpecial DataType:=ppPasteBitmap, Link:=msoFalse
        Set shp = slide.Shapes(1)

        With shp
            .Top = vTop
            .Left = vLeft
            .Width = vWidth
            .Height = vHeight
        End With

        Application.CutCopyMode = False
        Set shp = Nothing
        Set slide = Nothing

        ' The line below is showing an error (compile error)
        'Application.CutCopyMode = False
        'Application.CutCopyMode = False

        'aPPLICATION.CU
        Set expRng = Nothing

    Next rng

    pre.Save

    'pre.Close

    Set pre = Nothing
    Set ppt_app = Nothing
    Set expRng = Nothing
    wb.Close False
    Set wb = Nothing

    Application.DisplayAlerts = True

End Sub

Upvotes: 1

Views: 641

Answers (2)

Christopher Hamkins
Christopher Hamkins

Reputation: 1639

I think you're probably referencing the wrong shape using the constant index 1.

Set shp = slide.Shapes(1)

The shape you inserted will probably be at the end of the list.

Try doing this instead:

Set shp = slide.Shapes(slide.Shapes.Count)

Upvotes: 1

Siddharth Rout
Siddharth Rout

Reputation: 149295

Instead of pasting and then assigning the shape, you can do that in one go...

Here is an example

Set shp = slide.Shapes.PasteSpecial(ppPasteBitmap)

With shp
    '~~> Do what you want
End With

Upvotes: 1

Related Questions