VBA: Runtime SaveAs Error when Saving an Embedded Excel Workbook

[Domenic]

I have a macro that opens each embedded Excel and Word file within the workbook, saves it in a folder, closes it, and then deletes it.

For the embedded Word files, there's no problem. However, for the embedded Excel files, I get the following run time error...

Runtime error: "1004"

SaveAs method of Workbook class failed

If I step through the code, I get no error. And, if the embedded Excel file is selected before saving it, there's also no error.
Does anyone know why it's necessary to the select the embedded Excel file before saving it?

Here's the code, with the required line that selects the embedded Excel file in red...

Option Explicit

Sub SaveAndDeleteEmbeddedWordAndExcelFiles()

    Dim ws As Worksheet
    Dim oOleObj As OLEObject
    Dim oDoc As Object
    Dim sDestFolder As String
    Dim sDocType As String
    Dim lCnt As Long
    
    If ActiveWorkbook Is Nothing Then Exit Sub
    
    On Error GoTo ErrHandler
    
    sDestFolder = ActiveWorkbook.Path
    
    If Len(sDestFolder) > 0 Then
        sDestFolder = sDestFolder & "\"
    Else
        sDestFolder = Application.DefaultFilePath & "\"
    End If
    
    lCnt = 0
    For Each ws In ActiveWorkbook.Worksheets
        For Each oOleObj In ws.OLEObjects
            If oOleObj.OLEType = xlOLEEmbed Then
                sDocType = oOleObj.progID
                sDocType = Left(sDocType, InStr(sDocType, ".") - 1)
                If sDocType = "Word" Then
                    oOleObj.Verb xlVerbPrimary
                    Set oDoc = oOleObj.Object
                    oDoc.SaveAs Filename:=sDestFolder & oDoc.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss") & ".docx", FileFormat:=12
                    oDoc.Close savechanges:=False
                    oOleObj.Delete
                    lCnt = lCnt + 1
                ElseIf sDocType = "Excel" Then
                    [COLOR="#FF0000"]oOleObj.Select[/COLOR]
                    oOleObj.Verb xlVerbPrimary
                    Set oDoc = oOleObj.Object
                    oDoc.SaveAs Filename:=sDestFolder & oDoc.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss") & ".xlsx", FileFormat:=51
                    oDoc.Close savechanges:=False
                    oOleObj.Delete
                    lCnt = lCnt + 1
                End If
            End If
        Next oOleObj
    Next ws
    
    MsgBox lCnt & " embedded objects were saved and deleted!", vbExclamation
    
ExitTheSub:
    
    Set ws = Nothing
    Set oOleObj = Nothing
    Set oDoc = Nothing
    
    Exit Sub
    
ErrHandler:
    MsgBox "Unable to save and delete embedded files.", vbCritical
    Resume ExitTheSub
    
End Sub

Thanks!

 

[Domenic]

Anyone know why it's necessary to select an embedded Excel file before being able to save it?

In case anyone is interested in trying the code, I've added a necessary line that activates each worksheet as it loops through each worksheet within the workbook, since it appears that it's necessary to select an embedded file before saving it...

Option Explicit

Sub SaveAndDeleteEmbeddedWordAndExcelFiles()

    Dim wsActive As Worksheet
    Dim ws As Worksheet
    Dim oOleObj As OLEObject
    Dim oDoc As Object
    Dim sDestFolder As String
    Dim sDocType As String
    Dim lCnt As Long
    
    If ActiveWorkbook Is Nothing Then Exit Sub
    
    On Error GoTo ErrHandler
    
    Application.ScreenUpdating = False
    
    sDestFolder = ActiveWorkbook.Path
    
    If Len(sDestFolder) > 0 Then
        sDestFolder = sDestFolder & "\"
    Else
        sDestFolder = Application.DefaultFilePath & "\"
    End If
    
    Set wsActive = ActiveSheet
    
    lCnt = 0
    For Each ws In ActiveWorkbook.Worksheets
        ws.Activate
        For Each oOleObj In ws.OLEObjects
            If oOleObj.OLEType = xlOLEEmbed Then
                sDocType = oOleObj.progID
                sDocType = Left(sDocType, InStr(sDocType, ".") - 1)
                If sDocType = "Word" Then
                    oOleObj.Select
                    oOleObj.Verb xlVerbPrimary
                    Set oDoc = oOleObj.Object
                    oDoc.SaveAs Filename:=sDestFolder & oDoc.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss") & ".docx", FileFormat:=12
                    oDoc.Close savechanges:=False
                    oOleObj.Delete
                    lCnt = lCnt + 1
                ElseIf sDocType = "Excel" Then
                    oOleObj.Select
                    oOleObj.Verb xlVerbPrimary
                    Set oDoc = oOleObj.Object
                    oDoc.SaveAs Filename:=sDestFolder & oDoc.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss") & ".xlsx", FileFormat:=51
                    oDoc.Close savechanges:=False
                    oOleObj.Delete
                    lCnt = lCnt + 1
                End If
            End If
        Next oOleObj
    Next ws
    
    wsActive.Activate
    
    Application.ScreenUpdating = True
    
    MsgBox lCnt & " embedded objects were saved and deleted!", vbExclamation
    
ExitTheSub:
    
    Set wsActive = Nothing
    Set ws = Nothing
    Set oOleObj = Nothing
    Set oDoc = Nothing
    
    Exit Sub
    
ErrHandler:
    MsgBox "Unable to save and delete embedded files.", vbCritical
    Resume ExitTheSub
    
End Sub