如何在通过vb向word中批量插入图片

[loorj]

从钉钉上导出的EXECL数据，图片只有网络地址，并且几张图片地址合并在一个单元格，我想把图片都自动导出来，写了如下代码，但只能导出一张图片就报错了
Sub tetx()
Dim i As Integer, flag As Boolean, fm
Dim bb, zmin, tpdz

Set my = ActiveWorkbook
Application.ScreenUpdating = False '屏幕刷新关闭
Application.DisplayAlerts = False '信息警告关闭
flag = False
Do While Not flag '对话框打开已有 Excel 文件
fm = Application.GetOpenFilename(fileFilter:="\Excel files (*.xls),*.xls,All files (*.*),*.*")
If fm <> False Then
Workbooks.Open fm
Set bb = ActiveWorkbook
flag = True
End If
Loop
bb.Activate
'对合并的图片地址分列
zf = Mid(bb.Sheets(1).Range("a:ay").Find("图片地址").Address, 2, 1)
Columns(zf & ":" & zf).Select
Selection.TextToColumns Destination:=Range(zf & "1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), _
TrailingMinusNumbers:=True
ar = Sheets(1).UsedRange

For i = 1 To UBound(ar, 2)
If ar(1, i) = "站名：" Then zmin = i
If ar(1, i) = "图片地址" Then tpdz = i
Next
For i = 2 To UBound(ar, 2)
wjm = ar(i, zmin)
tp1 = ar(i, tpdz)
tp2 = ar(i, tpdz + 1)
tp3 = ar(i, tpdz + 2)

'新建WORD文档
Dim WordApp As Word.Application
Set WordApp = New Word.Application
WordApp.Visible = True
WordApp.Documents.Add
Set CurrentDoc = WordApp.Documents(1)
WordApp.Selection.Fields.Add Range:=CurrentDoc.Paragraphs(1).Range, Type:=wdFieldEmpty, TEXT:="INCLUDEPICTURE " & tp1 & " ", PreserveFormatting:=True
WordApp.Selection.Fields.Add Range:=CurrentDoc.Paragraphs(2).Range, Type:=wdFieldEmpty, TEXT:="INCLUDEPICTURE " & tp3 & " ", PreserveFormatting:=True'运行到这一行时显示运行错误5941，集合所要求的成员不存在
WordApp.Selection.Fields.Add Range:=CurrentDoc.Paragraphs(3).Range, Type:=wdFieldEmpty, TEXT:="INCLUDEPICTURE " & tp3 & " ", PreserveFormatting:=True
CurrentDoc.SaveAs ThisWorkbook.Path & "\" & wjm & ".doc"
CurrentDoc.Close

WordApp.Quit

Set WordApp = Nothing
Next

End Sub

求大侠指点

[loorj]

没人顶我自己顶一顶，请教高手啊

[jack_sparrow_52]

没有附件吗？

[thamos8960]

学习一下，我也遇到过，求解。