求助：求高手写个代码，Word邮件合并插入带图片的文档，要按姓名存为单个文档

wintergirl

本人用邮件合并功能填写多名考生的报名表，带照片，需要每个考生存一个文档。现可以生成一个文档时照片显示正常，即所有考生都在一个文档中。用网上找的代码可以生成第人一个文档，但照片就不能正常显示，求高手帮我改改代码，实现邮件合并后每人的照片都能正常显示。先谢谢了！
Sub myMailMerge()
'主文档的类型为信函
'合并全部数据记录
'假设主文档已链接好数据源，可以进行正常的邮件合并
Dim myMerge As MailMerge, i As Integer, myname As String
Application.ScreenUpdating = False
Set myMerge = ActiveDocument.MailMerge
With myMerge.DataSource
    If .Parent.State = wdMainAndDataSource Then
        .ActiveRecord = wdFirstRecord
        For i = 1 To .RecordCount
            .FirstRecord = i
            .LastRecord = i
            .Parent.Destination = wdSendToNewDocument
            '取得数据源第1个和第2个字段（合并域）的当前数据字符串，用以命名文件
            myname = .DataFields(1).Value & .DataFields(2).Value
            .ActiveRecord = wdNextRecord
            .Parent.Execute  '每次合并一个数据记录
            With ActiveDocument
                .Content.Characters.Last.Previous.Delete  '删除分节符
                .SaveAs "D:\拆分的文件\" & myname & ".doc"  '假设生成的各文档保存于D盘拆分的文件目录下，此目录需先建立
                .Close  '关闭生成的文档（已保存）
            End With
        Next
    End If
End With
Application.ScreenUpdating = True
End Sub

182197315

Sub word邮件引用()
Dim xlApp
Dim 路径$, 文件$, arr()
路径 = ThisDocument.Path & "\"
文件 = Dir(路径 & "*.xls")
Set xlApp = CreateObject("Excel.application")                               '建立Excel对象变量xlApp
xlApp.Visible = True                                                    '打开excel程序
Set wb = xlApp.workbooks.Open(路径 & 文件)                          '打开同目录下的excel文件
For x = 1 To wb.Sheets.Count
    ReDim Preserve arr(x)
        arr(x) = wb.Sheets(x).Name
Next x
xlApp.ActiveWorkbook.Close SaveChanges:=False                       '关闭打开的excel不保存
xlApp.Quit
For x = 3 To UBound(arr)
    ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
    ActiveDocument.MailMerge.OpenDataSource Name:=路径 & 文件, SQLStatement:="SELECT * FROM [" & arr(x) & "$] "
    ActiveDocument.MailMerge.Execute Pause:=False
    ChangeFileOpenDirectory 路径
    ActiveDocument.SaveAs2 FileName:=arr(x)
    ActiveWindow.Close
Next x
End Sub

xyxcc177

我有插件可以做

wintergirl

182197315 发表于 2018-9-8 20:38
Sub word邮件引用()
Dim xlApp
Dim 路径$, 文件$, arr()

非常感谢老师的答复，我试过了，还是不能正常显示，提示“无法显示链接的图像，该文件可能被移动、重命名或删除，请验证该链接是否指向正确的文件和位置”。但实际照片不存在移动、重命名等问题！

wintergirl

xyxcc177 发表于 2018-9-8 22:20
我有插件可以做

什么插件可以分享一下吗？谢谢！

xyxcc177

wintergirl 发表于 2018-9-8 23:34
什么插件可以分享一下吗？谢谢！

没有安装文件，你把资料发来我给你做

wintergirl

xyxcc177 发表于 2018-9-9 06:38
没有安装文件，你把资料发来我给你做

非常感谢，我主要是想解决这类问题，因为数据量不大，我的已用手动将图片重新插入，弄好了。