如何用VBA直接从Access附件字段插入图片至Word文档

嘿，我完全懂你这种困扰——先把Access里的附件存成本地文件再插入Word，磁盘IO来回折腾确实拖慢效率，尤其是处理批量图片的时候。下面给你两种无需存文件直接插入的方案，亲测好用：

方案1：利用剪贴板传递二进制图片数据 #

这种方法通过读取Access附件的二进制数据，直接放到剪贴板再粘贴到Word，跳过文件存储步骤，效率提升明显。

Option Compare Database
Sub picloader_DirectInsert()
    Dim appWord As Word.Application
    Dim doc As Word.Document
    Dim rsParent As DAO.Recordset
    Dim rsAttachments As DAO.Recordset2
    Dim picData As Variant
    
    ' 获取或启动Word实例
    On Error Resume Next
    Set appWord = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set appWord = New Word.Application
        appWord.Visible = True ' 让Word可见，方便调试
    End If
    On Error GoTo 0
    
    ' 打开目标Word文档（这里是新建，也可以替换为已有文档路径）
    Set doc = appWord.Documents.Add ' 替换为：Documents.Open("C:\你的文档路径.docx")
    
    ' 打开Access中包含附件的记录集（替换为你的表名和筛选条件）
    Set rsParent = CurrentDb.OpenRecordset("SELECT * FROM 你的表名 WHERE 你的筛选条件")
    If Not rsParent.EOF Then
        ' 打开附件字段的子记录集
        Set rsAttachments = rsParent("你的附件字段名").Value
        If Not rsAttachments.EOF Then
            ' 提取图片的二进制数据
            picData = rsAttachments("FileData").Value
            
            ' 将二进制数据写入剪贴板
            Dim objClipboard As Object
            Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
            objClipboard.SetData picData, vbCFBitmap ' 若为JPG等格式，可尝试vbCFDIB或其他格式常量
            
            ' 在Word当前光标位置粘贴图片
            doc.Range.Paste
            
            rsAttachments.Close
        End If
        rsParent.Close
    End If
    
    ' 清理对象
    Set rsAttachments = Nothing
    Set rsParent = Nothing
    Set doc = Nothing
    Set appWord = Nothing
End Sub

注意事项： #

• 确保Access附件字段存储的是图片格式（BMP、JPG等），不同格式可能需要调整剪贴板的格式常量（比如vbCFDIB适合JPG）。
• 记得在VBA编辑器的「工具→引用」中勾选Microsoft Word xx.x Object Library。

方案2：使用ADODB流直接插入OLE对象 #

如果剪贴板方法遇到格式兼容问题，可以尝试用ADODB流读取二进制数据，直接插入Word的OLE对象，稳定性更强。

Option Compare Database
Sub picloader_StreamInsert()
    Dim appWord As Word.Application
    Dim doc As Word.Document
    Dim rsParent As DAO.Recordset
    Dim rsAttachments As DAO.Recordset2
    Dim stream As ADODB.Stream
    
    ' 获取或启动Word实例
    On Error Resume Next
    Set appWord = GetObject(, "Word.Application")
    If appWord Is Nothing Then
        Set appWord = New Word.Application
        appWord.Visible = True
    End If
    On Error GoTo 0
    
    ' 打开目标Word文档
    Set doc = appWord.Documents.Add
    
    ' 打开Access记录集
    Set rsParent = CurrentDb.OpenRecordset("SELECT * FROM 你的表名 WHERE 你的筛选条件")
    If Not rsParent.EOF Then
        Set rsAttachments = rsParent("你的附件字段名").Value
        If Not rsAttachments.EOF Then
            ' 初始化ADODB流
            Set stream = New ADODB.Stream
            stream.Type = adTypeBinary
            stream.Open
            stream.Write rsAttachments("FileData").Value
            stream.Position = 0
            
            ' 插入OLE图片对象
            doc.InlineShapes.AddOLEObject _
                ClassType:="Paint.Picture", _
                FileName:="", _
                LinkToFile:=False, _
                DisplayAsIcon:=False, _
                Data:=stream.Read
            
            stream.Close
            rsAttachments.Close
        End If
        rsParent.Close
    End If
    
    ' 清理对象
    Set stream = Nothing
    Set rsAttachments = Nothing
    Set rsParent = Nothing
    Set doc = Nothing
    Set appWord = Nothing
End Sub

注意事项： #

• 需要在VBA编辑器的「工具→引用」中额外勾选Microsoft ActiveX Data Objects xx.x Library。
• ClassType参数可根据图片格式调整，比如"Picture"或对应格式的ProgID。

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