wordvba批量处理图片

‘壹’ 如何用vba取得一个word文件中的所有的图片

提供网上示例代码供参考（此代码的思路是遍历 word 文档中的 Shapes ，缩放到原始图片尺寸，再转粘贴到 Excel 中，借用 Excel 的 ChartObjects 提供的导出功能实现图片原样导出）：

Subtest()
Rem工具--引用--勾选MicrosoftExcelx.xObjectLibrary..
DimmyshapeAsObject,ExcelAppAsNewExcel.Application
DimExcelAsWorkbook,i%,z%
SetExcel=ExcelApp.Workbooks.Add
.InlineShapes
Ifmyshape.Type=3Then
i=i+1
myshape.Select
Setmyshape=myshape.ConvertToShape
Rem以下代码将图片以原始比例展示
Withmyshape
.ScaleHeight1,True,msoScaleFromMiddle
.ScaleWidth1,True,msoScaleFromMiddle
EndWith
Selection.Copy
WithExcel.ActiveSheet.ChartObjects.Add(0,0,myshape.Width,myshape.Height).Chart
.Paste
.ExportActiveDocument.Path&""&i&".png"
.Parent.Delete
EndWith
EndIf
Next
Excel.CloseFalse
ExcelApp.Quit
EndSub

‘贰’ word中使用vba按照现在图片的顺序，用新的图片把旧图片全部替换，图片名称统一由规定的

解题思路很重要，下面给出替换图片的关键代码：

Sub替换活动文档中的第一张图片()
ActiveDocument.InlineShapes(1).Select
Selection.InlineShapes.AddPicture"[要替换的图片的完整路径]"
EndSub

PS：实际使用中可以将要替换的新图片按照 Word 文档中的图片出现的顺序进行编号（如1.jpg、2.jpg、3.jpg...）并放入一个文件夹中，然后将上述代码放入循环语句中并稍作修改，通过遍历 Word 文档中的 InlineShapes 对象同时传递图片的完整路径即可实现全部替换！

‘叁’ vba批量替换word中图片

可以用下面的代码试一下：（注意，操作前，需要做好备份）
’把图片统一成一种格式。（也可以统一转成浮动的格式，代码稍做修改即可）
For Each ishape In ActiveDocument.Shapes
ishape.ConvertToInlineShape
Next ishape
For i = 1 To ActiveDocument.InlineShapes.Count - 1
ActiveDocument.InlineShapes(i).Select
Selection.InlineShapes.AddPicture "c\" & i & ".jpg", linktofile:=False, savewithdocument:=True
Next

‘肆’ 关于图片批量导入word中并在图片上方附加文件名的VBA代码编辑

Sub 批量插入图片()
Dim myfile As FileDialog
Set myfile = Application.FileDialog(msoFileDialogFilePicker)
With myfile
.InitialFileName = "E:\工作文件" ‘这里输入你要插入图片的目标文件夹
If .Show = -1 Then
For Each Fn In .SelectedItems
Selection.Text = Basename(Fn) '这两句移到这里
Selection.EndKey
If Selection.Start = ActiveDocument.Content.End - 1 Then '如光标在文末
Selection.TypeParagraph '在文末添加一空段
Else
Selection.MoveDown
End If
Set MyPic = Selection.InlineShapes.AddPicture(FileName:=Fn, SaveWithDocument:=True) '按比例调整相片尺寸
WidthNum = MyPic.Width
c = 6 '在此处修改相片宽,单位厘米
MyPic.Width = c * 28.35
MyPic.Height = (c * 28.35 / WidthNum) * MyPic.Height
If Selection.Start = ActiveDocument.Content.End - 1 Then '如光标在文末
Selection.TypeParagraph '在文末添加一空段
Else
Selection.MoveDown
End If
Next Fn
Else
End If
End With
Set myfile = Nothing
End Sub
Function Basename(FullPath) '取得文件名
Dim x, y
Dim tmpstring
tmpstring = FullPath
x = Len(FullPath)
For y = x To 1 Step -1
If Mid(FullPath, y, 1) = "\" Or _
Mid(FullPath, y, 1) = ":" Or _
Mid(FullPath, y, 1) = "/" Then
tmpstring = Mid(FullPath, y + 1)
Exit For
End If
Next
Basename = Left(tmpstring, Len(tmpstring) - 4)
End Function
执行此代码后，弹出的选择对话框， 全选目标文件夹下的所有图片文件之后，点击确定。然后静静的等待电脑完成处理工作，次数word会进入无响应状态。图片越多，无响应的时间越长。

‘伍’ 求助：如何通过VBA批量选中word文档里的嵌入型图片或表格

提供示例代码供参考：

SubBatEditPic()
DimShapesCountAsInteger
DimiAsInteger
ShapesCount=ActiveDocument.InlineShapes.Count
Fori=1ToShapesCount
WithActiveDocument.InlineShapes(i)
'修改图片边框
With.Borders(wdBorderTop)
.LineStyle=wdLineStyleSingle
.LineWidth=wdLineWidth050pt
EndWith
With.Borders(wdBorderBottom)
.LineStyle=wdLineStyleSingle
.LineWidth=wdLineWidth050pt
EndWith
With.Borders(wdBorderLeft)
.LineStyle=wdLineStyleSingle
.LineWidth=wdLineWidth050pt
EndWith
With.Borders(wdBorderRight)
.LineStyle=wdLineStyleSingle
.LineWidth=wdLineWidth050pt
EndWith
EndWith
Nexti
EndSub

‘陆’ 寻找WORD VBA高手解决WORD批量插入图片程序的问题

Selection.Text = Basename(Fn) '这两句移到这里
Selection.EndKey

这两句移一下位置，其它不变。

Sub 批量插入图片()
Dim myfile As FileDialog
Set myfile = Application.FileDialog(msoFileDialogFilePicker)
With myfile
.InitialFileName = "D:\111"
If .Show = -1 Then
For Each Fn In .SelectedItems
Selection.Text = Basename(Fn) '这两句移到这里
Selection.EndKey
Set mypic = Selection.InlineShapes.AddPicture(FileName:=Fn, SaveWithDocument:=True)
'按比例调整相片尺寸
WidthNum = mypic.Width
c = 18 '在此处修改相片宽,单位厘米
mypic.Width = c * 28.35
mypic.Height = (c * 28.35 / WidthNum) * mypic.Height
If Selection.Start = ActiveDocument.Content.End - 1 Then '如光标在文末
Selection.TypeParagraph '在文末添加一空段
Else
Selection.MoveDown
End If
If Selection.Start = ActiveDocument.Content.End - 1 Then '如光标在文末
Selection.TypeParagraph '在文末添加一空段
Else
Selection.MoveDown
End If
Next Fn
Else
End If
End With
Set myfile = Nothing
End Sub
Function Basename(FullPath) '取得文件名
Dim x, y
Dim tmpstring
tmpstring = FullPath
x = Len(FullPath)
For y = x To 1 Step -1
If Mid(FullPath, y, 1) = "\" Or _
Mid(FullPath, y, 1) = ":" Or _
Mid(FullPath, y, 1) = "/" Then
tmpstring = Mid(FullPath, y + 1)
Exit For
End If
Next
Basename = Left(tmpstring, Len(tmpstring) - 4)
End Function

‘柒’ 怎么把word里所有图片一次性锐化

步骤如下：

1.打开word后，选中一张图片；

3.这样一次性选中所有图片后即可点击完成锐化。