PictureToWord

1.查找文件夹中符合图片格式的文件，返回其名字

Dim fs, f, f1, fc, s
Dim arr As String
Set fs = CreateObject("Scripting.FileSystemObject")
Address = ThisWorkbook.FullName
Address = Left(Address, InStrRev(Address, "\", Len(Address))) '获得当前工作表所在文件夹路径

Set f = fs.GetFolder(Address)
Set fc = f.Files

i = 2
For Each f1 In fc '遍历文件
If FileIspicture(f1.Name) Then ' 引用了自定义函数 FileIspicture 判断是否为需要查找的文件格式

phname = f1.Name '获取文件名
houzhui = Right(phname, Len(phname) - InStrRev(phname, ".", Len(phname)) + 1)
Sheet1.Cells(i, 1) = Left(phname, InStrRev(phname, ".", Len(phname)) - 1)
Sheet1.Cells(i, 2) = houzhui
i = i + 1
End If
Next

2.修改文件名称

Sub changename()
Dim Address As String
Address = ThisWorkbook.FullName
Address = Left(Address, InStrRev(Address, "\", Len(Address)))
n = Sheet1.Cells(Rows.Count, 1).End(xlUp).row
For i = 2 To n '修改名称
pname = Sheet1.Cells(i, 1) & Sheet1.Cells(i, 2)
textname = Sheet1.Cells(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 Word.Application
Dim Address As String
myName = "picture.doc" '新建的word名称
Address = ThisWorkbook.FullName
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(, "Word.Application")
appWD.Documents.Close SaveChanges:=wdDoNotSaveChanges
appWD.Quit

Set appWD = CreateObject("Word.Application") '连接word

appWD.Documents.Add
appWD.ActiveDocument.SaveAs filename:=mydoc
appWD.Visible = True

n = Sheet1.Cells(Rows.Count, 1).End(xlUp).row '获取工作表有效部分的最大行数

For i = 2 To n '插入图片
pname = Sheet1.Cells(i, 1) & Sheet1.Cells(i, 2)
textname = Sheet1.Cells(i, 3)
appWD.Selection.InlineShapes.AddPicture filename:=Address & pname, LinkToFile:= _
False, SaveWithDocument:=True
appWD.Selection.TypeParagraph
appWD.Selection.TypeText Text:=textname
appWD.Selection.TypeParagraph
houzhui = Right(pname, Len(pname) - InStrRev(pname, ".", Len(pname)) + 1)

Next i

'居中，修改字体大小为10，字体加粗
appWD.Selection.WholeStory
appWD.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
appWD.Selection.Font.Size = 10
appWD.Selection.Font.Name = "宋体"
appWD.Selection.Font.Bold = wdToggle

4.修改图片大小，使每页正好两张图

Dim picwidth
Dim picheight

For i = 1 To appWD.ActiveDocument.InlineShapes.Count 'InlineShapes类型图片
H = appWD.ActiveDocument.InlineShapes(i).Height
W = appWD.ActiveDocument.InlineShapes(i).Width
HIV = W / H
H = 325
W = HIV * H
If W >= 415 Then
W = 415
H = W / HIV
End If
appWD.ActiveDocument.InlineShapes(i).Height = H
appWD.ActiveDocument.InlineShapes(i).Width = W
Next i