Sphinx404
07-16-2018, 09:41 AM
I am having a problem that I've been trying to figure out for 4 days now and I have no idea what is going on. I've triple checked everything and I cannot for the life of me figure out why I'm getting the run-time 1004 error. I don't know where else to turn.
the following code:
Sub SCOM_Charts1()
ActiveSheet.Shapes.Range(Array("Object 4")).Select
Selection.Verb Verb:=3
If Not Application.CalculationState = xlDone Then DoEvents
Application.CalculateUntilAsyncQueriesDone
Dim acslide As Slide
Dim myPresentation As Object, mySlide As Object, PowerPointApp As Object, shp As Object
Dim MySlideArray As Variant, MyChartArray As Variant, X As Long, ns%
Application.ScreenUpdating = False
On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Err.Clear
If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, action aborted."
Exit Sub
End If
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, action aborted."
Exit Sub
End If
On Error GoTo 0
PowerPointApp.ActiveWindow.Panes(2).Activate
Set myPresentation = PowerPointApp.ActivePresentation
MySlideArray = Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)
MyChartArray = Array(Sheet2.ChartObjects("Assy1"), Sheet2.ChartObjects("Assy2"), Sheet2.ChartObjects("Assy4"), Sheet2.ChartObjects("Assy7"), Sheet2.ChartObjects("Assy8"), Sheet1.ChartObjects("Velocity2"), _
Sheet1.ChartObjects("Velocity1"), Sheet1.ChartObjects("Velocity4"), Sheet1.ChartObjects("Velocity3"), Sheet4.ChartObjects("Free1"), Sheet4.ChartObjects("Free2"), Sheet4.ChartObjects("Free3"), _
Sheet4.ChartObjects("Free4"), Sheet5.ChartObjects("Assigned1"), Sheet3.ChartObjects("RTY1"))
For X = LBound(MySlideArray) To UBound(MySlideArray)
MyChartArray(X).Copy - ERRORS OUT HERE
DoEvents
Set acslide = myPresentation.Slides(MySlideArray(X))
ns = acslide.Shapes.Count
Set shp = acslide.Shapes.PasteSpecial
JustDoIt ns + 1
On Error Resume Next
shp.LinkFormat.BreakLink
On Error GoTo 0
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ThisWorkbook.Activate
MsgBox "Export to PowerPoint complete. Note: **All slides will be lost when this workbook is closed.**"
End Sub
Sub JustDoIt(I%)
Dim pptcht1 As PowerPoint.Shape, cnt%
On Error Resume Next
cnt = 0
Do
DoEvents
Set pptcht1 = acslide.Shapes(I)
If Not pptcht1 Is Nothing Then Exit Do
cnt = cnt + 1
If cnt > 100 Then Exit Do
Loop
Debug.Print cnt
On Error GoTo 0
End Sub
Craps out after it copies either slide #2 and sometimes #3.
I just don't understand it. Why oh why! For the love of Santa Claus, please help me!
the following code:
Sub SCOM_Charts1()
ActiveSheet.Shapes.Range(Array("Object 4")).Select
Selection.Verb Verb:=3
If Not Application.CalculationState = xlDone Then DoEvents
Application.CalculateUntilAsyncQueriesDone
Dim acslide As Slide
Dim myPresentation As Object, mySlide As Object, PowerPointApp As Object, shp As Object
Dim MySlideArray As Variant, MyChartArray As Variant, X As Long, ns%
Application.ScreenUpdating = False
On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Err.Clear
If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, action aborted."
Exit Sub
End If
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, action aborted."
Exit Sub
End If
On Error GoTo 0
PowerPointApp.ActiveWindow.Panes(2).Activate
Set myPresentation = PowerPointApp.ActivePresentation
MySlideArray = Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)
MyChartArray = Array(Sheet2.ChartObjects("Assy1"), Sheet2.ChartObjects("Assy2"), Sheet2.ChartObjects("Assy4"), Sheet2.ChartObjects("Assy7"), Sheet2.ChartObjects("Assy8"), Sheet1.ChartObjects("Velocity2"), _
Sheet1.ChartObjects("Velocity1"), Sheet1.ChartObjects("Velocity4"), Sheet1.ChartObjects("Velocity3"), Sheet4.ChartObjects("Free1"), Sheet4.ChartObjects("Free2"), Sheet4.ChartObjects("Free3"), _
Sheet4.ChartObjects("Free4"), Sheet5.ChartObjects("Assigned1"), Sheet3.ChartObjects("RTY1"))
For X = LBound(MySlideArray) To UBound(MySlideArray)
MyChartArray(X).Copy - ERRORS OUT HERE
DoEvents
Set acslide = myPresentation.Slides(MySlideArray(X))
ns = acslide.Shapes.Count
Set shp = acslide.Shapes.PasteSpecial
JustDoIt ns + 1
On Error Resume Next
shp.LinkFormat.BreakLink
On Error GoTo 0
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ThisWorkbook.Activate
MsgBox "Export to PowerPoint complete. Note: **All slides will be lost when this workbook is closed.**"
End Sub
Sub JustDoIt(I%)
Dim pptcht1 As PowerPoint.Shape, cnt%
On Error Resume Next
cnt = 0
Do
DoEvents
Set pptcht1 = acslide.Shapes(I)
If Not pptcht1 Is Nothing Then Exit Do
cnt = cnt + 1
If cnt > 100 Then Exit Do
Loop
Debug.Print cnt
On Error GoTo 0
End Sub
Craps out after it copies either slide #2 and sometimes #3.
I just don't understand it. Why oh why! For the love of Santa Claus, please help me!