Not able to resize and position shapes in Power Point-CodePudding

I am working on a VBA script which copies some ranges from an Excel to a PowerPoint. I am able to do that successfully without any errors. However, after copying the range, when I re-size and re-align the shapes, I am not able to do so. Can you help me to know what I might 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")
'Range Loop is the loop ramge 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 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 Power Point-----------------------------------------------
    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
    'This line below is showing 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

CodePudding user response：

In 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)

CodePudding user response：

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