之前写过一篇如如何把Excel数据按格式输出至Word，有很多朋友提到了可以使用邮件合并功能。确实，简单的输出，完全没必要使用VBA，毕竟这个重器并不那么友好。后来有朋友提出了，需要把图片按格式输出至Word，于是才有了今天这个文章。
我们先来看看具体的需求场景。以工程建设为例，某些工程验收时候都需要附验收图片，如下图这种，就需要把图片输出至指定的位置。
第一、建立模板
这里比较关键的是图片部分，文字替换部分很简单。对于图片，在需要插入图片的位置插入一个模板图片，调整好相应尺寸。该模板图片无实际作用，仅仅只是为了获取定位而已。
二、制作数据表
三、归集引用图片
这一步主要是把图片全部放在指定的路径下，并按规则进行命名。以上面数据表为例，我们按照点位标号来命名。在此命名规则为：未封装照片前缀为A、封装后照片前缀为B、验收人现场照片前缀为C，然后使用前缀+点位编号来标识图片对应，如下图。
四、核心代码
Private Sub MakeDoc_Click()
On Error GoTo Err_cmdExportToWord_Click
Dim objApp As Object 'Word.Application
Dim objDoc As Object 'Word.Document
Dim strTemplates As String '模板文件路径名
Dim strFileName As String '将数据导出到此文件
Dim i As Integer
Dim employNo As String
Dim employlocation As String
Dim employdate As String
Dim left_a, top_a, width_a, height_a, left_b, top_b, width_b, height_b, left_c, top_c, width_c, height_c As Double
i = ActiveCell.Row
employNo = Cells(i, 1)
employaddress = Cells(i, 2)
employdate = Cells(i, 3)
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Add "word文件", "*.doc;*.docx", 1
.AllowMultiSelect = False
If .Show Then strTemplates = .SelectedItems(1) Else Exit Sub
End With
'通过文件对话框生成另存为文件名
With Application.FileDialog(msoFileDialogSaveAs)
.InitialFileName = employNo
If .Show Then strFileName = .SelectedItems(1) Else Exit Sub
End With
'文件名必须包括“.doc”的文件扩展名，如没有则自动加上
If Not strFileName Like "*.doc" Then strFileName = strFileName & ".doc"
'如果文件已存在，则删除已有文件
If Dir(strFileName) <> "" Then Kill strFileName
'打开模板文件
Set objApp = CreateObject("Word.Application")
objApp.Visible = True
Set objDoc = objApp.Documents.Open(strTemplates, , False)
Application.ScreenUpdating = False
For Each IShapes In ActiveDocument.InlineShapes '把ishape形状转化成inlineshape对象，否则无法编辑
IShapes.ConvertToShape
Next
'获取模板图形形状所在位置和尺寸，以便后面调用，此部分代码，根据自己喜好，酌情使用或不使用。
With ActiveDocument.Shapes(1)
left_a = .Left + 15
width_a = .Width
top_a = .Top + 210
height_a = .Height
.Visible = msoFalse
End With
With ActiveDocument.Shapes(2)
left_b = ActiveDocument.Shapes(1).Left + ActiveDocument.Shapes(1).Width + 30
width_b = .Width
top_b = .Top + 210
height_b = .Height
.Visible = msoFalse
End With
With ActiveDocument.Shapes(3)
left_c = .Left + 20
width_c = .Width
top_c = .Top + 425
height_c = .Height
.Visible = msoFalse
End With
'把图片全部加载到文档中
ActiveDocument.Shapes.AddPicture Filename:=ThisWorkbook.Path & "图片" & "A" & employNo & ".jpg", _
linktofile:=False, SaveWithDocument:=True
ActiveDocument.Shapes.AddPicture Filename:=ThisWorkbook.Path & "图片" & "B" & employNo & ".jpg", _
linktofile:=False, SaveWithDocument:=True
ActiveDocument.Shapes.AddPicture Filename:=ThisWorkbook.Path & "图片" & "C" & employNo & ".jpg", _
linktofile:=False, SaveWithDocument:=True
'调整加载后的图片尺寸和位置
With ActiveDocument.Shapes(4)
.Width = width_a
.Height = height_a
.Top = top_a
.Left = left_a
End With
With ActiveDocument.Shapes(5)
.Width = width_b
.Height = height_b
.Top = top_b
.Left = left_b
End With
With ActiveDocument.Shapes(6)
.Width = width_c
.Height = height_c
.Top = top_c
.Left = left_c
End With
'开始替换模板预置变量文本
With objApp.Application.Selection
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
With .Find
.Text = "{$点位编号}"
.Replacement.Text = employNo
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$安装位置}"
.Replacement.Text = employaddress
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$日期}"
.Replacement.Text = employdate
End With
.Find.Execute Replace:=wdReplaceAll
End With
'将写入数据的模板另存为文档文件
objDoc.SaveAs strFileName, FileFormat:=12
objDoc.Saved = True
MsgBox "报告生成完毕！", vbYes + vbExclamation
Application.ScreenUpdating = True
Exit_cmdExportToWord_Click:
If Not objDoc Is Nothing Then objApp.Visible = True
Set objApp = Nothing
Set objDoc = Nothing
Set objTable = Nothing
Exit Sub
Err_cmdExportToWord_Click:
MsgBox Err.Description, vbCritical, "出错"
Resume Exit_cmdExportToWord_Click
End Sub
特别需要说明的是，本办法中采用了预置图片来定位图片的输出位置，实际使用中可以抛弃该办法，转而直接加载图片，然后再逐一设置图片格式和位置。
