如何通过Excel VBA从Access附件字段提取jpg/png图片插入Excel工作表

问题根源说明 #

• 原代码直接读取附件字段值赋值给单元格，逻辑完全不成立：Access附件类型字段是复合结构，存储了文件名、文件属性、二进制内容等多组信息，无法直接读取为文本或直接写入流
• ADODB.Stream.Write报3001错误的核心原因：传入的参数是附件字段对象本身，而非附件内存储的图片原始二进制数据
• 原SQL语句逻辑错误：WHERE条件用附件字段匹配数值，无法正确命中记录，需替换为表的主键字段过滤

前置准备 #

打开VBA编辑器，进入「工具-引用」，勾选以下两个库：

• Microsoft ActiveX Data Objects x.x Library（x.x为你设备上的最高版本即可）
• Microsoft DAO x.x Object Library

完整可运行代码 #

Sub InsertPicFromAccessDB()
    Dim con As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim attachmentField As DAO.Field2
    Dim stream As ADODB.stream
    Dim tempFilePath As String
    
    ' 临时文件路径，存放在系统临时文件夹
    tempFilePath = Environ("TEMP") & "\temp_pic_insert.png"
    
    ' 初始化连接、记录集、流对象
    Set con = New ADODB.Connection
    Set rs = New ADODB.Recordset
    Set stream = New ADODB.stream
    
    ' 连接Access，请自行替换ConStrAccess为你的实际连接字符串
    con.ConnectionString = ConStrAccess
    con.Open
    
    ' 注意：此处SQL的WHERE条件请替换为你表的主键字段过滤，比如 WHERE 产品ID=2163150
    With rs
        .ActiveConnection = con
        .Source = "SELECT ProdutoFoto FROM tblProduto WHERE 你的主键字段=2163150;"
        .LockType = adLockOptimistic
        .CursorType = adOpenKeyset
        .Open
    End With
    
    ' 读取附件字段的二进制内容
    Set attachmentField = rs.Fields("ProdutoFoto").Value
    With stream
        .Type = adTypeBinary ' 必须设置为二进制类型，否则Write会报错
        .Open
        .Write attachmentField.FileData ' 传入附件的二进制数据，避免3001错误
        .SaveToFile tempFilePath, adSaveCreateOverWrite
        .Close
    End With
    
    ' 将临时图片插入Excel工作表指定位置
    shStockNovo.Shapes.AddPicture _
        Filename:=tempFilePath, _
        LinkToFile:=msoFalse, _
        SaveWithDocument:=msoTrue, _
        Left:=shStockNovo.Range("A57").Left, _
        Top:=shStockNovo.Range("A57").Top, _
        Width:=shStockNovo.Range("A57").Width, _
        Height:=shStockNovo.Range("A57").Height
    
    ' 清理资源
    Kill tempFilePath ' 删除临时文件
    rs.Close
    con.Close
    Set stream = Nothing
    Set rs = Nothing
    Set con = Nothing
    Set attachmentField = Nothing
End Sub

关键逻辑说明 #

• 必须通过DAO.Field2类型读取附件字段，调用FileData属性才能拿到图片的原始二进制流
• ADODB.Stream调用Write方法前必须先设置Type = adTypeBinary，否则会触发参数类型不匹配的3001错误
• 先导出为本地临时文件再插入Excel，兼容所有Access支持的图片格式，不会出现格式解析失败的问题

内容的提问来源于stack exchange，提问作者Corneliu