前段时间，因编写报告，需要把成果图片修改名字后，将图以及相应的名字插入word文档中。

一次报告，至少200张图，花了数个小时才弄完工作，同时难免出现差错。

之后就一直寻找捷径，基于excel vba以前有一点基础，现将整理出来的代码分享给大家。

可以去下载我编好的excel 小程序，里面有详细代码，地址在最下方。

欢迎直接试用下，给个反馈建议.
1.查找文件夹中符合图片格式的文件，返回其名字
Dim fs, f, f1, fc, s
Dim arr As String
Set fs = CreateObject("")
Address =
Address = Left(Address, InStrRev(Address, "\", Len(Address))) '获得当前工作表所在文件夹路径
Set f = (Address)
Set fc =
i = 2
For Each f1 In fc '遍历文件
If FileIspicture Then ' 引用了自定义函数 FileIspicture 判断是否为需要查找的文件格式
phname = '获取文件名
houzhui = Right(phname, Len(phname) - InStrRev(phname, ".",
Len(phname)) + 1)
(i, 1) = Left(phname, InStrRev(phname, ".", Len(phname)) - 1) (i, 2) = houzhui
i = i + 1
End If
Next
2.修改文件名称
Sub changename()
Dim Address As String
Address =
Address = Left(Address, InStrRev(Address, "\", Len(Address)))
n = , 1).End(xlUp).row
For i = 2 To n '修改名称
pname = (i, 1) & (i, 2)
textname = (i, 3)
houzhui = Right(pname, Len(pname) - InStrRev(pname, ".", Len(pname)) + 1) '获取后缀
Name Address & pname As Address & textname & houzhui
Next i
MsgBox "名称已改"
End Sub
3.批量插图到word
Dim appWD As
Dim Address As String
myName = "" '新建的word名称
Address =
Address = Left(Address, InStrRev(Address, "\", Len(Address))) mydoc = Address & myName
On Error Resume Next '错误处理
Kill (mydoc)
On Error GoTo 0
On Error Resume Next
Set appWD = GetObject(, "")
SaveChanges:=wdDoNotSaveChanges
Set appWD = CreateObject("") '连接word
filename:=mydoc
= True
n = , 1).End(xlUp).row '获取工作表有效部分的最大行数
For i = 2 To n '插入图片
pname = (i, 1) & (i, 2)
textname = (i, 3)
filename:=Address & pname, LinkToFile:= _
False, SaveWithDocument:=True
Text:=textname
houzhui = Right(pname, Len(pname) - InStrRev(pname, ".", Len(pname)) + 1)
Next i
'居中，修改字体大小为10，字体加粗
= wdAlignParagraphCenter
= 10
= "宋体"
= wdToggle
4.修改图片大小，使每页正好两张图
Dim picwidth
Dim picheight
PictureToWord CSDN下载地址这个需要1积分PictureToWord RaySource下载地址这个免费。