[i]
https://wwgo.lanzouo.com/iHkTE2z6uicj
密码:52pj
ennnnnn，大概就这样吧，下班了！~
[Asm] 纯文本查看 复制代码Sub ReplaceBackgroundsWithImages()
Dim doc As Document
Dim folderPath As String, imageFolder As String
Dim fileName As String, imageName As String
Dim fileList As Variant, imageList As Variant
Dim i As Integer, pageCount As Integer
Dim section As Section
[i]
[Asm] 纯文本查看 复制代码Sub BatchReplaceBackgroundImage()
Dim folderPath As String
Dim fileName As String
Dim doc As Document
Dim imgPath As String
Dim header As HeaderFooter
Dim img As InlineShape
' 获取用户输入的文件夹路径
folderPath = InputBox("请输入包含Word文档的文件夹路径：", "选择文件夹")
If folderPath = "" Then Exit Sub
' 确保文件夹路径以反斜杠结尾
If Right(folderPath, 1) "\" Then folderPath = folderPath & "\"
' 获取用户输入的图片路径
imgPath = InputBox("请输入背景图片的完整路径：", "选择图片")
If imgPath = "" Then Exit Sub
' 遍历文件夹中的所有Word文档
Do While fileName ""
' 打开文档
Set doc = Documents.Open(folderPath & fileName)
' 遍历所有节
For Each section In doc.Sections
' 获取节的首页页眉
Set header = section.Headers(wdHeaderFooterPrimary)
' 清除页眉中的所有内容
header.Range.Text = ""
' 插入图片到页眉
Set img = header.Range.InlineShapes.AddPicture(imgPath)
' 调整图片大小以适应页面宽度
With img
.LockAspectRatio = msoTrue ' 锁定纵横比
.Width = doc.PageSetup.PageWidth - doc.PageSetup.LeftMargin - doc.PageSetup.RightMargin
End With
Next section
' 保存并关闭文档
doc.Save
doc.Close
' 获取下一个Word文档
fileName = Dir
Loop
MsgBox "批量更换背景图片完成！", vbInformation
End Sub
搞完才发现，好像理解错你的意思了，你需要的是一对一的更换图片，那最起码需要有一文档，对应一个文件夹的图片，而且图片需要按照插入顺序，做好，如果要自动化可能还要文档名和文件夹同名，方便自动插入
