Shapes (unknown member):Invalid request - pasting from excel to powerpoint with VBA

[gazpage]

Hi, I've been trying to write some code that pastes ranges from excel into powerpoint as enhanced metafiles. I am getting occasional errors with the pasting in the following line:

sldCurrent.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

From google and searching this site I think the error is that powerpoint is not in the correct view, ie in slide sorter view, but I don't know how to fix the issue.

Any help would be much appreciated.

Gary

Private Const cstrNotOpen As String = "The target Powerpoint presentation is not open. Please open the presentation and try again."
Private Const cstrNotOpenTitle As String = "Target file not open!"
Private Const cstrNotPasted As String = "Not pasted"

Sub MasterCopy()

'Subroutine purpose: Copy/Paste Excel Ranges Into a The Definted PowerPoint Presentation
'NOTE: Must have PowerPoint Object Library Active in Order to Run _
  (VBE > Tools > References > Microsoft PowerPoint xx.x Object Library)

Dim rngCopy As Range
Dim TargetFile As Range
Dim pptApp As PowerPoint.Application
Dim pptTarget As PowerPoint.Presentation
Dim sldCurrent As PowerPoint.Slide
Dim shpCurrent As PowerPoint.Shape

'Turn on error handling
On Error Resume Next

'Is PowerPoint already open?
Set pptApp = GetObject(, "Powerpoint.Application")

'Is target file already open? Identify target file if so
Set TargetFile = ThisWorkbook.Names("TargetFile").RefersToRange
Set pptTarget = pptApp.Presentations(TargetFile.Value)

'If file is open then proceed with macro, else print error and exit.
If Err.Number = 0 Then
        
    'Turn off error handling
    On Error GoTo 0
    
    'Call shape pasting sub routine
    Call RunThroughRanges(pptTarget:=pptTarget)
    
Else
    
    'Turn off error handling
    On Error GoTo 0
    
    'Print error message for user
    MsgBox prompt:=cstrNotOpen, _
           Title:=cstrNotOpenTitle
    
End If

End Sub

Sub PasteRange(strRange As String, _
                pptTarget As PowerPoint.Presentation, _
                intSlideNo As Integer, _
                sngLeft As Single, _
                sngTop As Single, _
                sngSize As Single, _
                ByVal i As Integer)

'Subroutine purpose: Paste Identified Excel Range Into Powerpoint Presentation

'Define variables
Dim sldCurrent As PowerPoint.Slide
Dim rngCopy As Range
Dim mcrWarningAnchor As Range

Set mcrWarningAnchor = ThisWorkbook.Names("mcrWarningAnchor").RefersToRange

'Check if target slide number exceeds number of slides in presentation
If intSlideNo <= pptTarget.Slides.Count Then

    'Turn on error handling
    On Error Resume Next
    
    'Identify Range from Excel. Error will be caused if range name does not exist.
    Set rngCopy = ThisWorkbook.Names(strRange).RefersToRange
    
    'Check if error exists
    If Err.Number = 0 Then
            
        'Turn off error handling
        On Error GoTo 0
        
        'Copy Excel Range
        rngCopy.Copy
        
        'Paste to PowerPoint and position
        Set pptTarget = pptTarget
        Set sldCurrent = pptTarget.Slides(intSlideNo)
        
        'Paste
        sldCurrent.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
        Set shpCurrent = sldCurrent.Shapes(sldCurrent.Shapes.Count)
          
                'Set position:
                shpCurrent.Left = sngLeft
                shpCurrent.Top = sngTop
                shpCurrent.ScaleHeight Factor:=sngSize, _
                                       RelativeToOriginalSize:=msoTrue
                    
        'Clear The Clipboard
        Application.CutCopyMode = False

    Else
    
        'Turn off error handling
        On Error GoTo 0
        
        'Add warning message to range
        
    
    End If

End If

End Sub

Sub RunThroughRanges(pptTarget As PowerPoint.Presentation)

'Subroutine purpose: Paste Series of Ranges Into PowerPoint Presentation

'Define variable
Dim mcrErrorAnchor As Range
Dim mcrRangeAnchor As Range
Dim mcrSlideNoAnchor As Range
Dim mcrHorizPosAnchor As Range
Dim mcrVertPosAnchor As Range
Dim mcrScaleAnchor As Range
Dim mcrWarningAnchor As Range
Dim lngNumRows As Long
Dim i As Long

'Set range variables
Set mcrErrorAnchor = ThisWorkbook.Names("mcrErrorAnchor").RefersToRange
Set mcrRangeAnchor = ThisWorkbook.Names("mcrRangeAnchor").RefersToRange
Set mcrSlideNoAnchor = ThisWorkbook.Names("mcrSlideNoAnchor").RefersToRange
Set mcrHorizPosAnchor = ThisWorkbook.Names("mcrHorizPosAnchor").RefersToRange
Set mcrVertPosAnchor = ThisWorkbook.Names("mcrVertPosAnchor").RefersToRange
Set mcrScaleAnchor = ThisWorkbook.Names("mcrScaleAnchor").RefersToRange
Set mcrWarningAnchor = ThisWorkbook.Names("mcrWarningAnchor").RefersToRange


'Check how many rows worth of range names need to be ran through the macro
lngNumRows = FindUsedRows(rngColumn:=mcrRangeAnchor)

'Clear previous pasting errors
Range(mcrWarningAnchor.Offset(1), mcrWarningAnchor.Offset(lngNumRows)).ClearContents

'Loop through each of the rows
For i = 1 To lngNumRows

    If Not IsEmpty(mcrRangeAnchor.Offset(i)) Then
    
        If mcrErrorAnchor.Offset(i) = 0 Then
        
            Call PasteRange(strRange:=mcrRangeAnchor.Offset(i).Value, _
                            pptTarget:=pptTarget, _
                            intSlideNo:=mcrSlideNoAnchor.Offset(i).Value, _
                            sngLeft:=mcrHorizPosAnchor.Offset(i).Value, _
                            sngTop:=mcrVertPosAnchor.Offset(i).Value, _
                            sngSize:=mcrScaleAnchor.Offset(i).Value, _
                            i:=i)
                            
        Else
        
            mcrWarningAnchor.Offset(i).Value = cstrNotPasted
                            
        End If
                        
    End If

Next i
                        
End Sub

Function FindUsedRows(rngColumn As Range)

'Define variables
Dim rngLastCell As Range
Dim lngRows As Long

Set rngColumn = ThisWorkbook.Names("mcrRangeAnchor").RefersToRange
Set rngLastCell = Cells(Rows.Count, rngColumn.Column).End(xlUp)

lngRows = rngLastCell.Row - rngColumn.Row

FindUsedRows = lngRows

End Function