利用EXCELVBA批量修改文件名以及自动插图到

利用E X C E L V B A批量修改文件名以及自动插

图到

集团标准化办公室：[VV986T-J682P28-JP266L8-68PNN]

前段时间，因编写报告，需要把成果图片修改名字后，将图以及相应的名字插入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

For i = 1 To 'InlineShapes类型图片

H =

W =

HIV = W / H

H = 325

W = HIV * H

If W >= 415 Then W = 415

H = W / HIV

End If

= H

= W

Next i

这个需要1积分这个免费