Run time error -2147417851 (80010105) Automation error The server threw an exception
Hi,
I am running the code below in Excel VBA. The main idea of the code is to read some info from excel and create a power point file.
I appreciate your help, thanks
Sub Macro1()
Dim XLApp As Excel.Application
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim Title(10) As Variant, Connector(10) As String, Chart_Names(10) As Variant, i As Integer
Set PPApp = CreateObject("Powerpoint.Application")
Set PPPres = PPApp.Presentations.Add
For i = 1 To 8
Title(i) = Worksheets("Sheet1").Cells(4 + i, 19)
Chart_Names(i) = Worksheets("Sheet1").Cells(4 + i, 20)
Connector(i) = Worksheets("Sheet1").Cells(4 + i, 21)
Next i
For i = 1 To 8
If (i < 4 Or i = 5) Then
Set PPSlide = PPPres.Slides.Add(i, ppLayoutTitleOnly)
PPSlide.Select
' Reference active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideInde x)
'Add a Tittle
PPSlide.Shapes.Title.TextFrame.TextRange.Text = Title(i)
Worksheets("Sheet1").ChartObjects(Chart_Names(i)). Select
' Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
' Paste chart
PPSlide.Shapes.Paste.Select
With PPApp.ActiveWindow.Selection.ShapeRange
.Height = 275 ' resize
.Width = 425 ' resize
.Top = 120 ' reposition
.Left = 140 ' reposition
End With
Set XLApp = GetObject(, "Excel.Application")
XLApp.Range(Connector(i)).Select
XLApp.Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
PPSlide.Shapes.Paste.Select
With PPApp.ActiveWindow.Selection.ShapeRange
' .Height = 275 ' resize
' .Width = 425 ' resize
.Top = 415 ' reposition
.Left = 197 ' reposition
End With
Else
Set PPSlide = PPPres.Slides.Add(i, ppLayoutTitleOnly)
PPSlide.Select
' Reference active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideInde x)
Set XLApp = GetObject(, "Excel.Application")
XLApp.Range(Chart_Names(i)).Select
XLApp.Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
PPSlide.Shapes.Paste.Select
With PPApp.ActiveWindow.Selection.ShapeRange
.Height = 275 ' resize
.Width = 425 ' resize
.Top = 120 ' reposition
.Left = 140 ' reposition
End With
Set XLApp = GetObject(, "Excel.Application")
XLApp.Range(Connector(i)).Select
XLApp.Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
PPSlide.Shapes.Paste.Select
If i = 6 Then
With PPApp.ActiveWindow.Selection.ShapeRange
.Height = 275 ' resize
.Width = 425 ' resize
.Top = 315 ' reposition
.Left = 146 ' reposition
End With
Else
If i = 7 Or i = 8 Then
With PPApp.ActiveWindow.Selection.ShapeRange
.Height = 1 ' resize
.Width = 1 ' resize
.Top = 1 ' reposition
.Left = 1 ' reposition
End With
End If
End If
End If
Next
With PPPres
.SaveAs "C:\Users\DG93796\Documents\MyPreso.ppt"
.Close
End With
PPApp.Quit
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
'End If
End Sub
|