I have an Excel VBA tool, that resides inside a PowerPoint Presentaion as an EmbeddedOLEObject.
Process work-flow:
- A user opens the PowerPoint.
- Then opens the Excel embedded object in it.
- Running the code in it updates data in the Excel file, and then exports it to the 1st slide of the PowerPoint it was opened from.
The problem starts when the user opens 2 of these PowerPoint presentations. If you open one Presnetation, let's call it "P1", then you open a second presentation "P2". Then you open the embedded Excel file in "P2", the excel gets stuck. When running in debug mode, it goes "crazy" opening numerous VBA windows (without giving an error message), at the following line:
Set objExcel = myShape.OLEFormat.Object
.
When running this process the other order, If first you open "P2", and then "P1", open the Embedded Excel file in "P2" it works well.
Anyone got a clue ?
Code
Option Explicit
Public Sub UpdatePowerPoint()
Dim ppProgram As Object
Dim ppPres As Object
Dim CurOpenPresentation As Object
Dim ppSlide As Object
Dim myShape As Object
Dim SlideNum As Integer
Dim objExcel As Object
Dim i As Long
On Error Resume Next
Set ppProgram = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If ppProgram Is Nothing Then
Set ppProgram = CreateObject("PowerPoint.Application")
Else
If ppProgram.Presentations.Count > 0 Then
' loop thorugh all open presentation, then loop through all slides
' check each object, check if you find an OLE Embedded object
For i = 1 To ppProgram.Presentations.Count
Set CurOpenPresentation = ppProgram.Presentations(i)
Set ppSlide = CurOpenPresentation.Slides(1) ' only check the first slide for Emb. Excel objects, otherwise not a One-Pager Presentation
For Each myShape In ppSlide.Shapes
Debug.Print myShape.Type & " | " & myShape.Name ' for DEBUG ONLY
If myShape.Type = 7 Then ' 7 = msoEmbeddedOLEObject
Dim objExcelwbName As String
' ***** ERROR in the Line below *******
Set objExcel = myShape.OLEFormat.Object
objExcelwbName = objExcel.CustomDocumentProperties.Parent.Name ' get's the workbook name of the Emb. Object
If objExcelwbName = ThisWorkbook.Name Then ' compare the name of the workbook the embedded object is in, with ThisWorkbook
Set ppPres = CurOpenPresentation
GoTo ExitPresFound
Else
Set objExcel = Nothing ' reset flag
End If
End If
Next myShape
NextPresentation:
Set CurOpenPresentation = Nothing ' clear presentation object
Next i
End If ' If ppProgram.Presentations.Count > 0 Then
End If
ExitPresFound:
If ppPres Is Nothing Then ' if One-Pager presentation was not found from all open presentations
MsgBox "Unable to Locate Presnetation, check if One-Pager Prsentation in Checked-Out (Read-Only Mode)"
End If
End Sub