万能的水友，word文档如何大批量文件换图片

雨滴先生

https://wwxb.lanzoul.com/iSsDX2z60f9i
（部分文件参考）

现在有几百份相同文件，清晰度不够，需要更换更高清的背景文件，格式不变内容不变（jpg图片格式）

但是学生日常图片已经整理好放进word里面了，要保持学生照片不变（圈起来的部分）仅更换背景

有什么更好的办法吗？

ChaosSPY1946021

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
    
    ' 设置文件夹路径（修改为你的路径）
    folderPath = "C:\Documents\"  ' 文档文件夹
    imageFolder = "C:\Backgrounds\" ' 图片文件夹
    
    ' 获取文档列表
    fileName = Dir(folderPath & "*.docx")
    fileList = Array()
    Do While fileName <> ""
        ReDim Preserve fileList(UBound(fileList) + 1)
        fileList(UBound(fileList)) = fileName
        fileName = Dir()
    Loop
    
    ' 获取图片列表（按文件名排序）
    imageName = Dir(imageFolder & "*.jpg")
    imageList = Array()
    Do While imageName <> ""
        ReDim Preserve imageList(UBound(imageList) + 1)
        imageList(UBound(imageList)) = imageName
        imageName = Dir()
    Loop
    
    ' 检查图片数量是否足够
    If UBound(imageList) < 11 Then
        MsgBox "图片不足12张，请检查文件夹！"
        Exit Sub
    End If
    
    ' 遍历每个文档
    For i = LBound(fileList) To UBound(fileList)
        Set doc = Documents.Open(folderPath & fileList(i))
        
        ' 遍历文档的每一节（假设每节对应一页）
        For Each section In doc.Sections
            ' 替换页眉/页脚背景（根据实际需求调整）
            With section.Headers(wdHeaderFooterPrimary).Range
                .Fill.Visible = msoTrue
                .Fill.UserPicture (imageFolder & imageList((i - 1) Mod 12 + 1)) ' 循环使用12张图片
            End With
        Next section
        
        ' 保存并关闭文档
        doc.Save
        doc.Close
    Next i
    
    MsgBox "背景图片替换完成！"
End Sub

ChaosSPY1946021

[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文档
    fileName = Dir(folderPath & "*.docx")
    
    ' 遍历文件夹中的所有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

搞完才发现，好像理解错你的意思了，你需要的是一对一的更换图片，那最起码需要有一文档，对应一个文件夹的图片，而且图片需要按照插入顺序，做好，如果要自动化可能还要文档名和文件夹同名，方便自动插入

雨滴先生

ChaosSPY1946021 发表于 2025-6-20 16:47
[mw_shl_code=asm,true]Sub BatchReplaceBackgroundImage()
    Dim folderPath As String
    Dim fil ...

https://wwxb.lanzoul.com/iU2mo2z6rvgd
密码:9857

这个是高清版的背景，我不大会用诶？ 我没有提示选择文件夹的选项，而且宏按照步骤运行不了呢？

雨滴先生

ChaosSPY1946021 发表于 2025-6-20 16:47
[mw_shl_code=asm,true]Sub BatchReplaceBackgroundImage()
    Dim folderPath As String
    Dim fil ...

大神我很需要你！ 我用的是wps 是不是要换其他版本的？

ChaosSPY1946021

雨滴先生 发表于 2025-6-20 17:18
大神我很需要你！ 我用的是wps 是不是要换其他版本的？

原则上应该不用，只要你能启动vbs就行，至于匹配度的问题，问问ai就能解决，这个不是什么很难的项目，直接替换背景，不涉及图片大小变化之类的东西