提取Excel嵌入式OLE对象存本地时遇OLEObject类Object属性错误

我在Excel 365中制作了可接收文件附件的用户表单，通过以下代码将选中文件嵌入工作表：

'puts file list entries into array
If DE_Form.AttachedFiles_List.ListCount > 0 Then
    For i = 0 To DE_Form.AttachedFiles_List.ListCount - 1
        ReDim Preserve FileNameArray(0 To i)
        FileNameArray(i) = DE_Form.AttachedFiles_List.List(i)
    Next i
End If

'adds icons for attached files to dc worksheet
For i = 0 To UBound(FileNameArray)
    'choose an icon based on filename extension
    'get all after last "." in filename
    FNExtension = Right(FileNameArray(i), Len(FileNameArray(i)) - _
                InStrRev(FileNameArray(i), "."))
 
    'select icon based on filename extension
    Select Case UCase(FNExtension)
    Case Is = "TXT"
      iconToUse = "C:\Windows\system32\packager.dll"

    Case Is = "XLS", "XLSM", "XLSX"
      iconToUse = "C:\Windows\Installer\{91140000-0011-0000-0000-0000000FF1CE}\xlicons.exe"

    Case Is = "PDF"
      iconToUse = "C:\Windows\Installer\{AC76BA86-1033-F400-7761-000000000004}\_PDFFile.ico"

    Case Else
      'this is a generic icon
      iconToUse = "C:\Windows\system32\packager.dll"
    End Select
    
    dc.Cells(GetLastRow(dc), 32 + i).ColumnWidth = 10
    dc.Cells(5, 32 + i).value = "Attached File " & i + 1
    dc.Cells(5, 32 + i).WrapText = True
    
    dc.Cells(GetLastRow(dc), 32 + i).value = FileNameArray(i)
    
    Set j = dc.OLEObjects.Add(fileName:=FileNameArray(i), _
                                link:=False, _
                                DisplayAsIcon:=True, _
                                IconFileName:=iconToUse, _
                                IconIndex:=0, _
                                IconLabel:=FileNameArray(i))
    On Error Resume Next
    
    With j
        '.ShapeRange.LockAspectRatio = msoFalse
        .Top = dc.Cells(GetLastRow(dc), 32 + i).Top
        .Left = dc.Cells(GetLastRow(dc), 32 + i).Left
        .Width = dc.Cells(GetLastRow(dc), 32 + i).Width
        .Height = dc.Cells(GetLastRow(dc), 32 + i).Height
    End With
    
Next i

现尝试提取嵌入式文件保存到本地，并在Access数据库中记录文件信息，但无法保存。可通过Activate或.verb xlprimary打开对象，但不想用SendKeys，已尝试多种方法仍触发错误：Unable to get the Object property of the OLEObject class，错误出现在k.Object.SaveAs fpath行。提取代码如下：

Dim NewCon As DAO.Database
Dim rs As DAO.Recordset2, rsattach As DAO.Recordset2
Dim fn() As String, fpath As String
Dim nfle As Object

'finds file objects and sets insert statement
For i = 6 To GetLastRow(ldc)
    For j = 32 To ldc.Cells(i, Columns.Count).End(xlToLeft).Column
        For Each k In ldc.OLEObjects
            k.Activate
                
            Select Case k.name
            Case Right(k.name, 6) = "Button", Right(k.name, 4) = "Icon":
            
            Case Else:
            
            If k.Left = ldc.Cells(i, j).Left Then
            
            Set NewCon = OpenDatabase("\\MyAccessDB.accdb")
            Set rs = NewCon.OpenRecordset("AttachedFiles", dbOpenTable)
            
            rs.AddNew
            
            rs.Fields("ProgramID") = ldc.Cells(i, "a").value
            fn = Split(ldc.Cells(i, j).Text, "\")
            rs.Fields("filename") = fn(UBound(fn))
            k.name = fn(UBound(fn))
            
            fpath = "\\MyFolderLocation\" & _
                k.name
            
            k.Object.SaveAs fpath                'Error is here
            
            rs.Fields("FileLocation") = fpath
            rs.Fields("Modified On") = ldc.Cells(i, "ae").value
            
            End If
            End Select
        Next k
    Next j
Next i

解决方案 #

1. 问题根源 #

OLEObject.Object属性无法获取，通常是因为OLE对象未正确激活，或对应文件的服务器程序未提供自动化接口（如部分PDF阅读器、自定义格式文件）。此外，原代码循环嵌套过多，且每次循环都打开数据库，效率低下还可能引发资源占用问题。

2. 可行解决代码 #

方案一：利用OLE对象复制功能（适配多数支持OLE的文件）

Sub ExtractOLEFiles()
    Dim NewCon As DAO.Database
    Dim rs As DAO.Recordset
    Dim oleObj As OLEObject
    Dim fn() As String, fpath As String
    Dim shellObj As Object
    Dim tempPath As String
    
    '提前打开数据库，避免重复操作
    Set NewCon = OpenDatabase("\\MyAccessDB.accdb")
    Set rs = NewCon.OpenRecordset("AttachedFiles", dbOpenDynaset)
    Set shellObj = CreateObject("WScript.Shell")
    tempPath = shellObj.ExpandEnvironmentStrings("%TEMP%") & "\"
    
    For Each oleObj In ldc.OLEObjects
        '跳过按钮和图标对象
        If Right(oleObj.Name, 6) <> "Button" And Right(oleObj.Name, 4) <> "Icon" Then
            '获取目标文件名
            fn = Split(ldc.Cells(oleObj.TopLeftCell.Row, oleObj.TopLeftCell.Column).Text, "\")
            fpath = "\\MyFolderLocation\" & fn(UBound(fn))
            
            '复制OLE内容到临时目录，再移动到目标路径
            oleObj.Verb xlVerbCopy
            With CreateObject("Shell.Application").Namespace(tempPath)
                .Items.Paste
                '等待粘贴完成
                Do While .Items.Count = 0
                    DoEvents
                Loop
                '覆盖已存在文件
                On Error Resume Next
                Kill fpath
                On Error GoTo 0
                .MoveHere .Items(1), fpath
            End With
            
            '写入Access记录
            rs.AddNew
            rs!ProgramID = ldc.Cells(oleObj.TopLeftCell.Row, "A").Value
            rs!filename = fn(UBound(fn))
            rs!FileLocation = fpath
            rs!ModifiedOn = ldc.Cells(oleObj.TopLeftCell.Row, "AE").Value
            rs.Update
        End If
    Next oleObj
    
    '清理资源
    rs.Close
    NewCon.Close
    Set rs = Nothing
    Set NewCon = Nothing
    Set shellObj = Nothing
End Sub

方案二：读取OLE二进制数据（更稳定，适配所有嵌入式OLE）

Sub ExtractOLEBinary()
    Dim NewCon As DAO.Database
    Dim rs As DAO.Recordset
    Dim oleObj As OLEObject
    Dim fn() As String, fpath As String
    Dim stream As Object
    Dim oleData As Variant
    
    Set NewCon = OpenDatabase("\\MyAccessDB.accdb")
    Set rs = NewCon.OpenRecordset("AttachedFiles", dbOpenDynaset)
    Set stream = CreateObject("ADODB.Stream")
    
    For Each oleObj In ldc.OLEObjects
        If Right(oleObj.Name, 6) <> "Button" And Right(oleObj.Name, 4) <> "Icon" Then
            fn = Split(ldc.Cells(oleObj.TopLeftCell.Row, oleObj.TopLeftCell.Column).Text, "\")
            fpath = "\\MyFolderLocation\" & fn(UBound(fn))
            
            '读取OLE对象二进制数据并保存
            On Error Resume Next
            oleData = oleObj.Object
            If Err.Number = 0 Then
                stream.Type = 1 '二进制模式
                stream.Open
                stream.Write oleData
                '覆盖已存在文件
                stream.SaveToFile fpath, 2
                stream.Close
                
                '写入Access记录
                rs.AddNew
                rs!ProgramID = ldc.Cells(oleObj.TopLeftCell.Row, "A").Value
                rs!filename = fn(UBound(fn))
                rs!FileLocation = fpath
                rs!ModifiedOn = ldc.Cells(oleObj.TopLeftCell.Row, "AE").Value
                rs.Update
            End If
            On Error GoTo 0
        End If
    Next oleObj
    
    '清理资源
    rs.Close
    NewCon.Close
    Set rs = Nothing
    Set NewCon = Nothing
    Set stream = Nothing
End Sub

3. 额外优化建议 #

• 避免在循环内重复打开数据库，提前初始化一次即可
• 使用TopLeftCell定位OLE对象对应的单元格，比比较Left属性更可靠
• 增加错误处理逻辑，比如检查目标文件夹是否存在、文件是否已存在
• 对于PDF等特殊格式，优先使用二进制提取方案，避免依赖OLE服务器的自动化接口

内容的提问来源于stack exchange，提问作者Chris H.