Excel VBA Run-time error 2147188160 (80048240) Automation Error

Question

I am trying to create a ppt with text entries from excel placed in couple of columns.

Have googled a lot but not able to make any headway on Run-time error 2147188160 (80048240) Automation Error.

Found this link on micrsoft site http://support.microsoft.com/kb/155073 which says this is a bug in Office 2007. Any one can suggest any workarounds.

My code is as follows:

    Sub CreateSlides()
    Dim aData As String
    Dim newPPT As PowerPoint.Application
    Dim Actslide As PowerPoint.Slide
    Dim Actshape As PowerPoint.Shape

    Dim lngSlideHeight      As Long
    Dim lngSlideWidth       As Long

    Dim i, x, rowcount, slinum, slicount As Integer

    Dim Size As Integer

Set newPPT = New PowerPoint.Application
newPPT.Presentations.Add
newPPT.ActivePresentation.Slides.Add newPPT.ActivePresentation.Slides.Count + 1, ppLayoutBlank
newPPT.Visible = msoTrue

lngSlideHeight = newPPT.ActivePresentation.PageSetup.SlideHeight
lngSlideWidth = newPPT.ActivePresentation.PageSetup.SlideWidth

ActiveSheet.Cells(1, 1).Select
rowcount = ActiveSheet.UsedRange.Rows.Count

slinum = 1
x = 1

'create slides
For slinum = 1 To 2 * rowcount + 10
    Set Actslide = newPPT.ActivePresentation.Slides(slinum)
    newPPT.ActivePresentation.Slides.Add newPPT.ActivePresentation.Slides.Count + 1, ppLayoutBlank
Next slinum

'copy words
slinum = 1
x = 1
For x = 1 To rowcount

    ActiveSheet.Cells(x, 1).Select
    Selection.Copy
    newPPT.Visible = True

    newPPT.ActiveWindow.View.GotoSlide (slinum)
    newPPT.ActiveWindow.Panes(2).Activate
    Set Actslide = newPPT.ActivePresentation.Slides(slinum)
     newPPT.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault

    newPPT.ActiveWindow.Selection.ShapeRange.Top = (lngSlideHeight - newPPT.ActiveWindow.Selection.ShapeRange.Height) / 2
    newPPT.ActiveWindow.Selection.ShapeRange.Height = 400
    newPPT.ActiveWindow.Selection.ShapeRange.Left = 1
    newPPT.ActiveWindow.Selection.ShapeRange.Width = lngSlideWidth - 1
    newPPT.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
    newPPT.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Font.Size = 48

        If slinum Mod 9 = 0 Then
            slinum = slinum + 9
        End If

    slinum = slinum + 1
Next x

slicount = 2 * rowcount + 10
slinum = 10
x = 1
i = 1
For x = 1 To rowcount

    ActiveSheet.Cells(x, 2).Select
    Selection.Copy
    If i = 1 Then
        newPPT.Visible = True
        newPPT.ActiveWindow.Panes(2).Activate
        newPPT.ActiveWindow.View.GotoSlide (slinum + 2)
        Else
            If i = 2 Then
            newPPT.Visible = True
            newPPT.ActiveWindow.Panes(2).Activate
            newPPT.ActiveWindow.View.GotoSlide (slinum)
            Else
                If i = 3 Then
                newPPT.Visible = True
                newPPT.ActiveWindow.Panes(2).Activate
                newPPT.ActiveWindow.View.GotoSlide (slinum - 2)
                End If
            End If
    End If
    i = i + 1

    If i = 4 Then
        i = 1
    End If

    newPPT.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault
    newPPT.ActiveWindow.Selection.ShapeRange.Top = (lngSlideHeight - newPPT.ActiveWindow.Selection.ShapeRange.Height) / 2
    newPPT.ActiveWindow.Selection.ShapeRange.Height = 400
    newPPT.ActiveWindow.Selection.ShapeRange.Left = 1
    newPPT.ActiveWindow.Selection.ShapeRange.Width = lngSlideWidth - 1
    newPPT.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
    newPPT.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Font.Size = 28

        If slinum Mod 9 = 0 Then
            slinum = slinum + 9
        End If

        If slinum > slicount Then
            Exit For
        End If

    slinum = slinum + 1
Next x


End Sub

@PortlandRunner I did try out the solution from the link. If you see the code - newPPT.Visible = True - this has already been added at appropriate place - as is being suggested by the link. — Anant, Oct 15 '13 at 14:03
@pnuts Had checked this link before. And tried out that code as well. But it didnt work. In the link it is mentioned that this workaround may not work for Powerpoint 2007. (Unfortunately that is the version that I have) — Anant, Oct 15 '13 at 14:06
@PortlandRunner Am a VBA newbie. Am I making some kind of mistake in the syntax of the workaround suggested. — Anant, Oct 15 '13 at 14:18
The article you reference above is about PowerPoint 95 aka PowerPoint 7, NOT PowerPoint 2007. This goes back to before PowerPoint had VBA built in. I wouldn't pay too much attention to it. Two questions: have you added a reference to PowerPoint and on what line does the error occur? — Steve Rindsberg, Oct 15 '13 at 14:47
@SteveRindsberg 1. Have added the Powerpoint Powerpoint 12.0 Object Library. — Anant, Oct 15 '13 at 19:06
@SteveRindsberg 2. In terms of line, the error is not always occurring at the same line. For eg. In the last run of this code and as per my sample data - the second For loop should have run for 19 times. But the code was executed for only 10 times. And this number keeps changing for each new execution of the code. Have tried debug mode as well for getting the line number, but have the same result. — Anant, Oct 15 '13 at 19:09

score 1 · Accepted Answer · answered Oct 16 '13 at 15:21

This is more a set of comments than an answer, but the comment fields don't allow for any reasonable formatting. See comments in-line:

   Sub CreateSlides()
    Dim aData As String
    Dim newPPT As PowerPoint.Application
    Dim Actslide As PowerPoint.Slide
    Dim Actshape As PowerPoint.Shape

' SlideHeight and Width are Singles, not Longs
    Dim lngSlideHeight      As Long
    Dim lngSlideWidth       As Long

' Here, you've DIMmed all of the variables as variants, not integers:
    Dim i, x, rowcount, slinum, slicount As Integer
' You really want:
'   Dim i as Long, x as Long ....etc.
'   Note that most if not all of these should be longs, not integers
'   Generally, VBA will convert for you as needed, but once in a while it'll
'   turn round and bite you.  Better to use the correct data types in the first place.

    Dim Size As Integer

Set newPPT = New PowerPoint.Application
' I'd move this here rather than below:
newPPT.Visible = msoTrue

newPPT.Presentations.Add
newPPT.ActivePresentation.Slides.Add newPPT.ActivePresentation.Slides.Count + 1, ppLayoutBlank
' newPPT.Visible = msoTrue

lngSlideHeight = newPPT.ActivePresentation.PageSetup.SlideHeight
lngSlideWidth = newPPT.ActivePresentation.PageSetup.SlideWidth

ActiveSheet.Cells(1, 1).Select

' Check what UsedRange returns against what you THINK it's supposed to return.
' Sometimes it's not quite what you expect:
rowcount = ActiveSheet.UsedRange.Rows.Count

' No need for either of these; the For/Next syntax takes care of that
'slinum = 1
'x = 1

'create slides
For slinum = 1 To 2 * rowcount + 10
    Set Actslide = newPPT.ActivePresentation.Slides(slinum)
    newPPT.ActivePresentation.Slides.Add newPPT.ActivePresentation.Slides.Count + 1, ppLayoutBlank
Next slinum

'copy words
slinum = 1
x = 1
For x = 1 To rowcount

    ActiveSheet.Cells(x, 1).Select
    Selection.Copy
    newPPT.Visible = True

    newPPT.ActiveWindow.View.GotoSlide (slinum)
    newPPT.ActiveWindow.Panes(2).Activate
    Set Actslide = newPPT.ActivePresentation.Slides(slinum)
     newPPT.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault

    newPPT.ActiveWindow.Selection.ShapeRange.Top = (lngSlideHeight - newPPT.ActiveWindow.Selection.ShapeRange.Height) / 2
    newPPT.ActiveWindow.Selection.ShapeRange.Height = 400
    newPPT.ActiveWindow.Selection.ShapeRange.Left = 1
    newPPT.ActiveWindow.Selection.ShapeRange.Width = lngSlideWidth - 1
    newPPT.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
    newPPT.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Font.Size = 48

        If slinum Mod 9 = 0 Then
            slinum = slinum + 9
        End If

    slinum = slinum + 1
Next x

slicount = 2 * rowcount + 10
slinum = 10
x = 1
i = 1
For x = 1 To rowcount

    ActiveSheet.Cells(x, 2).Select
    Selection.Copy
    If i = 1 Then
        newPPT.Visible = True
        newPPT.ActiveWindow.Panes(2).Activate
        newPPT.ActiveWindow.View.GotoSlide (slinum + 2)
        Else
            If i = 2 Then
            newPPT.Visible = True
            newPPT.ActiveWindow.Panes(2).Activate
            newPPT.ActiveWindow.View.GotoSlide (slinum)
            Else
                If i = 3 Then
                newPPT.Visible = True
                newPPT.ActiveWindow.Panes(2).Activate
                newPPT.ActiveWindow.View.GotoSlide (slinum - 2)
                End If
            End If
    End If
    i = i + 1

    If i = 4 Then
        i = 1
    End If

    newPPT.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault
    newPPT.ActiveWindow.Selection.ShapeRange.Top = (lngSlideHeight - newPPT.ActiveWindow.Selection.ShapeRange.Height) / 2
    newPPT.ActiveWindow.Selection.ShapeRange.Height = 400
    newPPT.ActiveWindow.Selection.ShapeRange.Left = 1
    newPPT.ActiveWindow.Selection.ShapeRange.Width = lngSlideWidth - 1
    newPPT.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
    newPPT.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Font.Size = 28

        If slinum Mod 9 = 0 Then
            slinum = slinum + 9
        End If

        If slinum > slicount Then
            Exit For
        End If

    slinum = slinum + 1
Next x


End Sub

Excel VBA Run-time error 2147188160 (80048240) Automation Error

1 Answers1