none
Run-time error '1004': CopyPicture method of Range class failed in VBA when copy data to PPT from Excel RRS feed

  • Question

  • The error is throwing on the bold marked line in the below code.  Can anyone know how to resolve this issue or help me to point the right direction to how I can solve this?

    Run-time error '1004':

    CopyPicture method of Range class failed

    Here is my code...

    Sub PPTMedium()
    '
    ' PPTMedium Macro
    '
        Dim pptApp As Object
        Dim sTemplatePPt As String
        Dim wks As Worksheet
        Dim fileName As String
        Dim cellName As String
        Dim pathName As String
        Dim saveLoc As String
        Dim loopName As String
        Dim iIndex As Integer
       
        Sheets("AN").Select
        ActiveSheet.Range("A1").Select
        a = Selection.Text
        ActiveSheet.Range("A10").Select
        b = Selection.Text
        ActiveSheet.Range("A4").Select
        cellName = Selection.Text
        ActiveSheet.Range("A11").Select
        loopName = Selection.Text
        Sheets("AN").Select

        iIndex = 0
        Set pptApp = CreateObject("Powerpoint.Application")
        With pptApp
            .Visible = True
            .Presentations.Open _
                fileName:=sTemplatePPt, Untitled:=msoTrue
            For Each wks In Worksheets
                wks.Select
                .ActiveWindow.View.gotoslide _
                    Index:=.ActivePresentation.Slides.Add _
                    (Index:=5 + iIndex, Layout:=11).SlideIndex
                iIndex = iIndex + 1
               
                .ActiveWindow.Selection.SlideRange.Shapes(1).Select
                .ActiveWindow.Selection.ShapeRange.IncrementLeft -18#
                .ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
                If a = "O" Then
                    '.ActiveWindow.Selection.ShapeRange.Top = 50
                    .ActiveWindow.Selection.ShapeRange.Top = 30
                    .ActiveWindow.Selection.ShapeRange.Left = 28
                    .ActiveWindow.Selection.ShapeRange.Height = 36
                ElseIf a = "U" Then
                    .ActiveWindow.Selection.ShapeRange.Top = 35
                    .ActiveWindow.Selection.ShapeRange.Left = 75
                    .ActiveWindow.Selection.ShapeRange.Height = 36
                    If iIndex = 6 Then
                        .ActiveWindow.Selection.ShapeRange.Top = 20
                        .ActiveWindow.Selection.ShapeRange.Left = 75
                        .ActiveWindow.Selection.ShapeRange.Height = 56
                    ElseIf iIndex = 11 Or iIndex = 15 Then
                        .ActiveWindow.Selection.ShapeRange.Top = 20
                        .ActiveWindow.Selection.ShapeRange.Left = 75
                        .ActiveWindow.Selection.ShapeRange.Height = 56
                        .ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
                        .ActiveWindow.Selection.ShapeRange.Width = 450
                    End If
                Else
                    .ActiveWindow.Selection.ShapeRange.Left = 37
                    .ActiveWindow.Selection.ShapeRange.Height = 36
                End If
                .ActiveWindow.Selection.TextRange.ParagraphFormat.Alignment = 1 '1 - left, 2 - centre
                .ActiveWindow.Selection.ShapeRange.ScaleWidth 0.99, msoFalse, msoScaleFromTopLeft
                If a = "U" And iIndex = 6 Then
                    .ActiveWindow.Selection.ShapeRange.ScaleWidth 0.79, msoFalse, msoScaleFromTopLeft
                End If
                .ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select

            With .ActiveWindow.Selection.TextRange
                If iIndex = 1 Then
                    .Text = "I"
                ElseIf iIndex = 2 Then
                    .Text = "D"
                ElseIf iIndex = 3 Then
                    .Text = "C"
                ElseIf iIndex = 4 Then
                    .Text = "A"
                ElseIf iIndex = 5 Then
                    .Text = "Is"
                ElseIf iIndex = 6 Then
                    .Text = "Co"
                ElseIf iIndex = 7 Then
                    .Text = "S"
                ElseIf iIndex = 8 Then
                    .Text = "De"
                ElseIf iIndex = 9 Then
                    .Text = "M"
                ElseIf iIndex = 10 Then
                    .Text = "Ev"
                ElseIf iIndex = 11 Then
                    .Text = "Em"
                ElseIf iIndex = 12 Then
                    .Text = "Da"
                ElseIf iIndex = 13 Then
                    .Text = "Ch"
                ElseIf iIndex = 14 Then
                    .Text = "Ad"
                ElseIf iIndex = 15 Then
                    .Text = "Co"
                ElseIf iIndex = 16 Then
                    .Text = "nl"
                End If

                With .Font
                    .Name = "Arial"
                    .NameOther = "Arial"
                    .Size = 20
                    .Bold = msoTrue
                    .Italic = msoFalse
                    .Underline = msoFalse
                    .Shadow = msoFalse
                    .Emboss = msoFalse
                    .BaselineOffset = 0
                    .AutorotateNumbers = msoFalse
                    '.Color.SchemeColor = ppTitle
                End With
            End With
           If iIndex = 6 Then
               wks.ChartObjects(1).CopyPicture xlScreen, xlBitmap

               .ActiveWindow.View.gotoslide (iIndex + 2)
               .ActiveWindow.View.Paste
        Application.CutCopyMode = False
               If a = "U" Then
                   .ActiveWindow.Selection.ShapeRange.Left = 40
                   .ActiveWindow.Selection.ShapeRange.Top = 95
               ElseIf a = "O" Then
                   .ActiveWindow.Selection.ShapeRange.Top = 88
                   .ActiveWindow.Selection.ShapeRange.Left = 35
               Else
                   .ActiveWindow.Selection.ShapeRange.Top = 75
                   .ActiveWindow.Selection.ShapeRange.Left = 17
               End If
           Else
                wks.UsedRange.CopyPicture xlScreen, xlBitmap

                If iIndex = 1 Then
                    .ActiveWindow.View.gotoslide (1)
                ElseIf iIndex = 2 Then
                    .ActiveWindow.View.gotoslide (3)
                Else
                    .ActiveWindow.View.gotoslide (iIndex + 2)
                End If
                .ActiveWindow.View.Paste
          Application.CutCopyMode = False
                If iIndex = 1 Then
                    .ActiveWindow.Selection.ShapeRange.Top = 170
                    If a = "U" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 210
                        .ActiveWindow.Selection.ShapeRange.Left = 210
                    End If
                ElseIf iIndex = 2 Then
                    .ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
                    .ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
                    .ActiveWindow.Selection.ShapeRange.Top = 60
                    If a = "U" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 85
                        .ActiveWindow.Selection.ShapeRange.Left = 60
                    ElseIf a = "O" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 87
                        .ActiveWindow.Selection.ShapeRange.Left = 35
                    ElseIf a = "O" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 75
                    End If
                ElseIf iIndex = 3 Then
                    .ActiveWindow.Selection.ShapeRange.Height = 410
                    .ActiveWindow.Selection.ShapeRange.Left = 35
                    .ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
                    If a = "U" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 65
                        .ActiveWindow.Selection.ShapeRange.Width = 645
                    ElseIf a = "O" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 88
                        .ActiveWindow.Selection.ShapeRange.Height = 400
                        .ActiveWindow.Selection.ShapeRange.Width = 650
                    ElseIf a = "U" Then
                        .ActiveWindow.Selection.ShapeRange.Left = 60
                        .ActiveWindow.Selection.ShapeRange.Top = 95
                        .ActiveWindow.Selection.ShapeRange.Height = 405
                    Else
                        .ActiveWindow.Selection.ShapeRange.Width = 645
                    End If
                ElseIf iIndex = 4 Then
                    If a = "U" Then
                        .ActiveWindow.Selection.ShapeRange.Left = 60
                        .ActiveWindow.Selection.ShapeRange.Top = 95
                    ElseIf a = "O" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 88
                        .ActiveWindow.Selection.ShapeRange.Left = 35
                    Else
                        .ActiveWindow.Selection.ShapeRange.Top = 75
                        .ActiveWindow.Selection.ShapeRange.Left = 37
                    End If
                ElseIf iIndex = 5 Or iIndex = 8 Then
                    .ActiveWindow.Selection.ShapeRange.Height = 400
                    .ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
                    .ActiveWindow.Selection.ShapeRange.Width = 645
                    If a = "U" Then
                        .ActiveWindow.Selection.ShapeRange.Left = 60
                        .ActiveWindow.Selection.ShapeRange.Top = 95
                        .ActiveWindow.Selection.ShapeRange.Width = 640
                    ElseIf a = "O" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 88
                        .ActiveWindow.Selection.ShapeRange.Left = 35
                    Else
                        .ActiveWindow.Selection.ShapeRange.Top = 75
                        .ActiveWindow.Selection.ShapeRange.Left = 37
                    End If
                ElseIf iIndex = 7 Then
                    .ActiveWindow.Selection.ShapeRange.Width = 645
                    If a = "U" Then
                        .ActiveWindow.Selection.ShapeRange.Left = 60
                        .ActiveWindow.Selection.ShapeRange.Top = 105
                        .ActiveWindow.Selection.ShapeRange.Width = 640
                    ElseIf a = "O" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 100
                        .ActiveWindow.Selection.ShapeRange.Left = 35
                    Else
                        .ActiveWindow.Selection.ShapeRange.Top = 85
                        .ActiveWindow.Selection.ShapeRange.Left = 37
                    End If
                ElseIf iIndex = 17 Or iIndex = 12 Then
                    .ActiveWindow.Selection.ShapeRange.Height = 390
                    .ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
                    .ActiveWindow.Selection.ShapeRange.Width = 645
                    If a = "U" Then
                        .ActiveWindow.Selection.ShapeRange.Left = 60
                        .ActiveWindow.Selection.ShapeRange.Top = 95
                        .ActiveWindow.Selection.ShapeRange.Width = 640
                    ElseIf a = "O" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 88
                        .ActiveWindow.Selection.ShapeRange.Left = 35
                    Else
                        .ActiveWindow.Selection.ShapeRange.Top = 75
                        .ActiveWindow.Selection.ShapeRange.Left = 37
                    End If
                ElseIf iIndex = 10 Then
                    If a = "U" Then
                        .ActiveWindow.Selection.ShapeRange.Left = 60
                        .ActiveWindow.Selection.ShapeRange.Top = 95
                    ElseIf a = "O" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 95
                        .ActiveWindow.Selection.ShapeRange.Left = 35
                    Else
                        .ActiveWindow.Selection.ShapeRange.Top = 75
                        .ActiveWindow.Selection.ShapeRange.Left = 37
                    End If
                ElseIf iIndex = 9 Or iIndex = 13 Or iIndex = 11 Then
                    If a = "U" Then
                        .ActiveWindow.Selection.ShapeRange.Left = 60
                        .ActiveWindow.Selection.ShapeRange.Top = 95
                    ElseIf a = "O" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 88
                        .ActiveWindow.Selection.ShapeRange.Left = 35
                    Else
                        .ActiveWindow.Selection.ShapeRange.Top = 75
                        .ActiveWindow.Selection.ShapeRange.Left = 37
                    End If
                ElseIf iIndex = 14 Or iIndex = 15 Or iIndex = 16 Or iIndex = 18 Then
                    If a = "U" Then
                        .ActiveWindow.Selection.ShapeRange.Left = 60
                        .ActiveWindow.Selection.ShapeRange.Top = 105
                    ElseIf a = "O" Then
                        .ActiveWindow.Selection.ShapeRange.Top = 100
                        .ActiveWindow.Selection.ShapeRange.Left = 35
                    Else
                        .ActiveWindow.Selection.ShapeRange.Top = 85
                        .ActiveWindow.Selection.ShapeRange.Left = 37
                    End If
                End If
            End If
            Next
            .Visible = True
           .ActiveWindow.View.gotoslide (21)
           .ActiveWindow.Selection.SlideRange.Delete
           .ActiveWindow.View.gotoslide (21)
           .ActiveWindow.Selection.SlideRange.Delete
          
           .ActiveWindow.View.gotoslide (2)
           If a = "O" Then
               .ActiveWindow.Selection.SlideRange.Shapes(2).Select
               .ActiveWindow.Selection.ShapeRange.IncrementLeft -18#
               .ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
               .ActiveWindow.Selection.ShapeRange.Top = 13
               .ActiveWindow.Selection.ShapeRange.Left = 35
               .ActiveWindow.Selection.ShapeRange.Height = 53
           ElseIf a = "U" Then
               .ActiveWindow.Selection.SlideRange.Shapes(3).Select
               .ActiveWindow.Selection.ShapeRange.IncrementLeft -18#
               .ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
               .ActiveWindow.Selection.ShapeRange.Top = 25
               .ActiveWindow.Selection.ShapeRange.Left = 70
               .ActiveWindow.Selection.ShapeRange.Height = 50
               .ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
               .ActiveWindow.Selection.ShapeRange.Width = 475
           Else
               .ActiveWindow.Selection.SlideRange.Shapes(3).Select
               .ActiveWindow.Selection.ShapeRange.IncrementLeft -18#
               .ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
               .ActiveWindow.Selection.ShapeRange.Left = 37
               .ActiveWindow.Selection.ShapeRange.Height = 53

           End If
           .ActiveWindow.Selection.TextRange.ParagraphFormat.Alignment = 1 '1 - left, 2 - centre
           .ActiveWindow.Selection.ShapeRange.ScaleWidth 0.99, msoFalse, msoScaleFromTopLeft
           .ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select

           With .ActiveWindow.Selection.TextRange
               .Text = b
                With .Font
                    .Name = "Arial"
                    .NameOther = "Arial"
                    .Size = 14
                    .Bold = msoTrue
                    .Italic = msoFalse
                    .Underline = msoFalse
                    .Shadow = msoFalse
                    .Emboss = msoFalse
                    .BaselineOffset = 0
                    .AutorotateNumbers = msoFalse
                    '.Color.SchemeColor = ppTitle
                End With

           End With
           .ActiveWindow.View.gotoslide (1)
           Sheets("Account Name").Select
           ActiveSheet.Range("A2").Select
        End With
       
        Length = Len(cellName)
        Length = Length - 10
        fileName = Mid(cellName, 10, Length)
        pathName = "My Local Drive path"
        saveLoc = pathName + loopName + "_" + fileName
        pptApp.ActivePresentation.SaveAs saveLoc
        pptApp.ActivePresentation.Saved = True
        pptApp.ActivePresentation.Close
        pptApp.Quit
       
    End Sub

    Monday, August 18, 2014 4:42 PM

All replies

  • Hi Anil,

    Based on the code, you are copying the chart as picture from Excel into PowerPoint. I created a test with Office 2013 and the code ran successfully:

    Sub CopyChartAsPicture()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    ws.ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap
      
    Dim pptApp As PowerPoint.Application
    Set pptApp = CreateObject("Powerpoint.Application")
    pptApp.Visible = msoCTrue
    
    Dim ppt As PowerPoint.Presentation
    Set ppt = pptApp.Presentations.Add
    ppt.Slides.AddSlide 1, ppt.SlideMaster.CustomLayouts(1)
    pptApp.ActiveWindow.View.Paste
    
    ppt.Close
    pptApp.Quit
    End Sub

    Dose it work for you? If yes, would you mind sharing the workbook to help us troubleshoot this issue? If not, I suggest that you repair Office to see whether the issue was resolved.

    Best regards

    Fei


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.


    Wednesday, August 20, 2014 5:55 AM
    Moderator