Trying to Extract Embedded OLEs

[Raphelle Guy]

Hi, I am having trouble with this Word vba script. The idea is to have embedded OLEs inside a Word document (.pdf, .pptx and .docx). I only want to find the .docx files and extract those. What is happening is every OLE, is being opened and then the script stops when it opens a .pdf or .pptx. I want to bypass those OLEs and just open the .docx OLEs. What am I doing wrong? Thanks in advance.

Sub ExtractEmbeddedDocObjects()
'
Dim i As Integer
Dim doc As Document
Set doc = ActiveDocument

EmbeddedItems = 0
If doc.InlineShapes.Count > 0 Then
For i = 1 To doc.InlineShapes.Count
If doc.InlineShapes(i).Type = wdInlineShapeEmbeddedOLEObject Then
If doc.InlineShapes(i).OLEFormat.Application = "Microsoft Word" Then
EmbeddedItems = EmbeddedItems + 1
End If
End If
Next i
End If

If doc.InlineShapes.Count > 0 And EmbeddedItems > 0 Then
DeletedShapes = 0
i = 1
Do While DeletedShapes < EmbeddedItems
If doc.InlineShapes(i - DeletedShapes).Type = wdInlineShapeEmbeddedOLEObject Then
If doc.InlineShapes(i - DeletedShapes).OLEFormat.Application = "Microsoft Word" Then
Debug.Print doc.InlineShapes(i - DeletedShapes).OLEFormat.Application
With doc.InlineShapes(i - DeletedShapes)
.Select
End With
Selection.InlineShapes(1).OLEFormat.DoVerb VerbIndex:=1
Selection.WholeStory
Selection.Copy
ActiveDocument.Close
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.PasteAndFormat (wdFormatOriginalFormatting)
DeletedShapes = DeletedShapes + 1
Selection.MoveRight Unit:=wdCharacter, Count:=2
End If
End If
i = i + 1
'
End Sub