批量替换Word页眉图片并保留原尺寸位置的VBA代码求助

需求背景 #

公司近期更换了名称与Logo，需批量处理1600余份Word文档的相关替换。现有VBA代码可完成正文的名称与Logo批量替换，但无法覆盖页眉区域的操作，需完善代码实现全文档范围的替换。

现有正文处理代码 #

Sub CommandButton1_Click()
    'Code compiled and constructed from different sources
    Dim xFileDialog As FileDialog, GetStr(1 To 100) As String '100 files is the maximum applying this code
    Dim xFindStr As String
    Dim xReplaceStr As String
    Dim xDoc As Document
    On Error Resume Next
     Set xFileDialog = Application.FileDialog(msoFileDialogFilePicker)
     With xFileDialog
    .Filters.Clear
    .Filters.Add "All WORD File ", "*.docx", 1
    .AllowMultiSelect = True
    i = 1
    If .Show = -1 Then
    For Each stiSelectedItem In .SelectedItems
    GetStr(i) = stiSelectedItem
    i = i + 1
    Next
    i = i - 1
    End If
    Application.ScreenUpdating = False
    xFindStr = InputBox("Find what:", "Kutools for Word", xFindStr)
    xReplaceStr = InputBox("Replace with:", "Kutools for Word", xReplaceStr)
    For j = 1 To i Step 1
    Set xDoc = Documents.Open(FileName:=GetStr(j), Visible:=True)
    Windows(GetStr(j)).Activate
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
    .Text = xFindStr 'Find What
    .Replacement.Text = xReplaceStr 'Replace With
    .Forward = True
    .Wrap = wdFindAsk
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = True
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Application.Run macroname:="NEWMACROS"
    ActiveWindow.View.SplitSpecial = wdPanePrimaryFooter
    Selection.Find.Execute Replace:=wdReplaceAll
    Application.Run macroname:="NEWMACROS"
    ActiveWindow.View.SplitSpecial = wdPanePrimaryHeader
    Selection.Find.Execute Replace:=wdReplaceAll
    Application.Run macroname:="NEWMACROS"

    'To Replace Image
    
    Dim originalImage As InlineShape
    Dim newImage As InlineShape
    
    Set originalImage = ActiveDocument.InlineShapes(1)
    
    Dim imageControl As ContentControl
    
    If originalImage.Range.ParentContentControl Is Nothing Then
    Set imageControl = ActiveDocument.ContentControls.Add(wdContentControlPicture,originalImage.Range)
    Else
        Set imageControl = originalImage.Range.ParentContentControl
    End If
    
    Dim imageW As Long
    Dim imageH As Long
    imageW = originalImage.Width
    imageH = originalImage.Height
    
    originalImage.Delete
    
    Dim imagePath As String
    imagePath = "C:\Users\1123\Desktop\New folder\1.png" ' New Image Location
    ActiveDocument.InlineShapes.AddPicture imagePath, False, True, imageControl.Range
    
    With imageControl.Range.InlineShapes(1)
    .Height = imageH
    .Width = imageW
    End With
    
    ' End of Replace Image
       
    
    'Continue Find & Replace Code
    ActiveDocument.Save
    ActiveWindow.Close
    Next
    Application.ScreenUpdating = True
    End With
    MsgBox "Operation end, please view", vbInformation
End Sub

尝试的页眉图片替换代码（未整合主流程） #

Sub CommandButton1_Click()
'Code compiled and constructed from different sources
    Dim xFileDialog As FileDialog, GetStr(1 To 100) As String '100 files is 
    the maximum applying this code
    Dim xFindStr As String
    Dim xReplaceStr As String
    Dim xdoc As Document
    On Error Resume Next
    Set xFileDialog = Application.FileDialog(msoFileDialogFilePicker)
    With xFileDialog
    .Filters.Clear
    .Filters.Add "All WORD File ", "*.docx", 1
    .AllowMultiSelect = True
    i = 1
    If .Show = -1 Then
    For Each stiSelectedItem In .SelectedItems
    GetStr(i) = stiSelectedItem
    i = i + 1
    Next
    i = i - 1
    End If
    Application.ScreenUpdating = False
    xFindStr = InputBox("Find what:", "Kutools for Word", xFindStr)
    xReplaceStr = InputBox("Replace with:", "Kutools for Word", 
    xReplaceStr)
    For j = 1 To i Step 1
    Set xdoc = Documents.Open(FileName:=GetStr(j), Visible:=True)
    
    Dim headerShape As Shape
    Dim newShapeFile As String
    Dim leftPos As Single
    Dim topPos As Single
    Dim width As Single
    Dim height As Single
    Dim section As section

    ' Set the path to the new shape file (e.g., an image or other object)
    newShapeFile = "C:\Users\q013031\Desktop\Where to see your JD on SAP Portal.jpg" ' Change to your new shape file path
        ' Loop through all sections in the document
    For Each section In xdoc.Sections
        ' Check if the section has a header
        If section.Headers(wdHeaderFooterPrimary).Exists Then
            ' Set the header shape in the primary header of the section
            On Error Resume Next
            Set headerShape = section.Headers(wdHeaderFooterPrimary).Shapes(1)
            On Error GoTo 0
            
            ' Check if a shape (image or other object) exists in the header
            
                
            If Not headerShape Is Nothing Then
    
                ' Get the size and position of the existing shape
                leftPos = headerShape.Left
                topPos = headerShape.Top
                width = headerShape.width
                height = headerShape.height
                
                ' Delete the existing shape
                headerShape.Delete
                
                ' Insert the new shape into the header while preserving 
 size and position
                Set headerShape = section.Headers(wdHeaderFooterPrimary).Shapes.AddPicture(FileName:=newShapeFile, LinkToFile:=False, SaveWithDocument:=True)
                
                ' Set the size and position of the new shape to match 
    the original
                headerShape.Left = leftPos
                headerShape.Top = topPos
                headerShape.width = width
                headerShape.height = height
            End If
        End If
    Next section

    ActiveDocument.Save
    ActiveWindow.Close
    Next
    Application.ScreenUpdating = True
    End With
    MsgBox "Operation end, please view", vbInformation
    MsgBox "Shapes in all headers replaced while preserving size and 
    position!", vbInformation
End Sub

完善后的完整VBA代码（覆盖正文+页眉） #

Sub BatchReplaceCompanyInfo()
    ' 批量替换Word文档的正文、页眉中的公司名称与Logo
    Dim xFileDialog As FileDialog, GetStr(1 To 100) As String
    Dim xFindStr As String, xReplaceStr As String
    Dim xDoc As Document, j As Integer, i As Integer
    Dim newLogoPath As String
    Dim section As Section, headerRange As Range
    
    ' 替换为你的新Logo路径
    newLogoPath = "C:\Users\1123\Desktop\New folder\1.png"
    
    On Error Resume Next
    Set xFileDialog = Application.FileDialog(msoFileDialogFilePicker)
    With xFileDialog
        .Filters.Clear
        .Filters.Add "所有Word文档", "*.docx", 1
        .AllowMultiSelect = True
        i = 1
        If .Show = -1 Then
            For Each stiSelectedItem In .SelectedItems
                GetStr(i) = stiSelectedItem
                i = i + 1
            Next
            i = i - 1
        End If
        Application.ScreenUpdating = False
        
        ' 获取替换文本
        xFindStr = InputBox("请输入旧公司名称:", "批量替换", xFindStr)
        xReplaceStr = InputBox("请输入新公司名称:", "批量替换", xReplaceStr)
        
        For j = 1 To i Step 1
            Set xDoc = Documents.Open(FileName:=GetStr(j), Visible:=True)
            
            ' --- 1. 正文文本替换 ---
            With xDoc.Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = xFindStr
                .Replacement.Text = xReplaceStr
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchByte = True
                .Execute Replace:=wdReplaceAll
            End With
            
            ' --- 2. 页眉文本替换 ---
            For Each section In xDoc.Sections
                If section.Headers(wdHeaderFooterPrimary).Exists Then
                    Set headerRange = section.Headers(wdHeaderFooterPrimary).Range
                    With headerRange.Find
                        .ClearFormatting
                        .Replacement.ClearFormatting
                        .Text = xFindStr
                        .Replacement.Text = xReplaceStr
                        .Forward = True
                        .Wrap = wdFindContinue
                        .Format = False
                        .MatchCase = False
                        .MatchWholeWord = False
                        .MatchByte = True
                        .Execute Replace:=wdReplaceAll
                    End With
                End If
            Next section
            
            ' --- 3. 正文Logo替换 ---
            ReplaceInlineShape xDoc, newLogoPath, xDoc.Content
            
            ' --- 4. 页眉Logo替换 ---
            For Each section In xDoc.Sections
                If section.Headers(wdHeaderFooterPrimary).Exists Then
                    ReplaceInlineShape xDoc, newLogoPath, section.Headers(wdHeaderFooterPrimary).Range
                    ReplaceShapeInRange section.Headers(wdHeaderFooterPrimary).Range, newLogoPath
                End If
            Next section
            
            ' 保存关闭文档
            xDoc.Save
            xDoc.Close
        Next j
        
        Application.ScreenUpdating = True
        MsgBox "批量替换完成，请查看结果！", vbInformation
    End With
End Sub

' 替换指定范围内的嵌入式图片（InlineShape）
Private Sub ReplaceInlineShape(targetDoc As Document, newImgPath As String, targetRange As Range)
    Dim originalImg As InlineShape
    Dim imgWidth As Long, imgHeight As Long
    Dim imgControl As ContentControl
    
    For Each originalImg In targetRange.InlineShapes
        imgWidth = originalImg.Width
        imgHeight = originalImg.Height
        
        ' 处理内容控件
        If originalImg.Range.ParentContentControl Is Nothing Then
            Set imgControl = targetDoc.ContentControls.Add(wdContentControlPicture, originalImg.Range)
        Else
            Set imgControl = originalImg.Range.ParentContentControl
        End If
        
        originalImg.Delete
        targetDoc.InlineShapes.AddPicture newImgPath, False, True, imgControl.Range
        
        ' 恢复原尺寸
        With imgControl.Range.InlineShapes(1)
            .Width = imgWidth
            .Height = imgHeight
        End With
    Next originalImg
End Sub

' 替换指定范围内的浮动图片（Shape）
Private Sub ReplaceShapeInRange(targetRange As Range, newImgPath As String)
    Dim targetShape As Shape
    Dim leftPos As Single, topPos As Single
    Dim imgWidth As Single, imgHeight As Single
    
    For Each targetShape In targetRange.ShapeRange
        leftPos = targetShape.Left
        topPos = targetShape.Top
        imgWidth = targetShape.Width
        imgHeight = targetShape.Height
        
        targetShape.Delete
        Set targetShape = targetRange.ShapeRange.AddPicture(newImgPath, False, True, leftPos, topPos, imgWidth, imgHeight)
    Next targetShape
End Sub

核心修改说明 #

1. 文本替换优化：

   • 放弃Selection对象，直接操作文档/页眉的Range，避免视图切换的不稳定问题
   • 遍历所有文档节的页眉，适配多节文档场景

2. Logo替换覆盖页眉：

   • 拆分出两个辅助函数，分别处理嵌入式图片和浮动图片，兼容不同插入方式的Logo
   • 保留原图片的尺寸和位置，保证替换后的格式一致性
   • 同时处理正文和页眉区域的Logo

3. 代码结构优化：

   • 移除冗余的NEWMACROS调用（原代码未定义该宏）
   • 统一使用文档对象操作，避免ActiveDocument/ActiveWindow的不可靠性
   • 拆分重复逻辑为辅助函数，提升代码可读性和维护性

内容的提问来源于stack exchange，提问作者moutaz fakhouri