Find and replace image in word document header and maintain the original image size and position

Question

Recently company changed its name and logo, and we have in our section about 1600+ documents to change the company name and logo, i manage to construct the code to do the changes in the body of the document from different sources but failed to find and construct a code for the header to do the same what it did in the body, can some one help?

This is my current code without the header part which is working perfectly, i want to add to it the header part if possible.

Sub CommandButton1_Click()
    'Code cmpiled and constrcuted 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

Code for the Image Header

Sub CommandButton1_Click()
'Code cmpiled and constrcuted 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:=newS 
    hapeFile, 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

Answer 1

Please, try the next solution. It will iterate between all documents in a folder chosen by user and change the header elements (text and picture):

Sub UpdateHeader_mass_documents()
   Dim strFolderPath As String, FldrPicker As FileDialog, fileName As String, xDoc As Document
   Dim sFindStr As String, xReplaceStr As String, NewimagePath As String, boolOK As Boolean
   Dim i As Long, k As Long
   
   sFindStr = "test replacement"    'use here the real text to be replaced
   xReplaceStr = "already replaced" 'use here the real replacing text
   
   NewimagePath = "C:\full path to the picture to replace existing.jpg"

   'choose the folder keeping the documents to be updated:
   Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
   
   With FldrPicker
    .Title = "Select The folder containing document to update their header"
    .AllowMultiSelect = False
    If .Show <> -1 Then Exit Sub 'Check if user clicked cancel button
    strFolderPath = .SelectedItems(1) & "\"
  End With
  
  fileName = Dir(strFolderPath & "*.doc*")
  
  Application.ScreenUpdating = False
   Do While fileName <> "" 'iterate between all Word documents from folder
     k = k + 1 'total processed documents
     boolOK = False 'to check if the replacement has been done..,
     Set xDoc = Documents.Open(strFolderPath & fileName)
     boolOK = False 'to check if the replacement has been done...
     updateHeader xDoc, sFindStr, xReplaceStr, NewimagePath, boolOK
     If boolOK Then
         xDoc.Close True ' save it and close
         i = i + 1 'total updated documents
     Else
         Debug.Print "Problematic document: " & xDoc.Name
     End If
     fileName = Dir() 'get nume to the next iterated document
    Loop
  Application.ScreenUpdating = True
  
  MsgBox "Updated header of " & i & " from a toatal of " & k & " documents.", vbInformation, "Job Done"
End Sub

Sub updateHeader(xDoc As Document, sFindStr As String, xReplaceStr As String, NewimagePath As String, ByRef boolOK As Boolean)
  Dim originalImage As InlineShape, oSec As Section, rng As Range, sel As Selection
  Dim imageW As Double, imageH As Double
  
  Set sel = Application.Selection 'to reselect after headers selection...
  Set oSec = xDoc.Sections(1)
  Set rng = oSec.Headers(Word.WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
  rng.Select 'to select the picture to be reeplaced, for using it as reference,
             'since ContentControl does not work in header...
  
  '1. replace the existing text:
  With rng.Find
    .Text = sFindStr
    .MatchCase = False
    .MatchWholeWord = False
    .Replacement.Text = xReplaceStr
    .Execute Replace:=wdReplaceAll
  End With

  '2. replace existing picture:
  If rng.InlineShapes.count > 0 Then
    Set originalImage = rng.InlineShapes(1): ' valid in case of ONLY ONE INLINESHAPE here
  Else
    MsgBox "No any inline shape in """ & xDoc.Name & """ document header..." & vbCrLf & _
           "This document will not be saved/closed...": Exit Sub
  End If
  If originalImage.Type <> wdInlineShapePicture Then _
         MsgBox "No any picture in """ & xDoc.Name & """ document header..." & vbCrLf & _
                "This document will not be saved/closed...": Exit Sub

  originalImage.Select 'to create the reference for the new added picture

  With originalImage 'memorize the original image dimensions
    imageW = .width
    imageH = .height
  End With
  
   Dim newImg As InlineShape
    Set newImg = rng.InlineShapes.AddPicture(NewimagePath, False, True, Selection.Range) 'add the new picture in the selection range
    newImg.width = imageW: newImg.height = imageH 'update the newly added image dimensions
    originalImage.Delete   'delete the initially existing shape
    sel.Select: ActiveWindow.View.Type = wdPrintView
    boolOK = True
End Sub

Answer 2

Loop through all sections in document and locate the header with wdHeaderFooterPrimary.

Note: Update is needed if the logo is in a table.

Option Explicit

Sub ReplaceTextImageInHeader()
    Dim sec As Section
    Dim hdFtr As HeaderFooter
    Dim rng As Range, shp
    Dim newImageFilePath As String
    newImageFilePath = "d:\temp\logo.png"
    For Each sec In ActiveDocument.Sections
        If sec.Headers(wdHeaderFooterPrimary).Exists Then
            Set rng = sec.Headers(wdHeaderFooterPrimary).Range
            With rng.Find
                .Text = "AAA"
                .Replacement.Text = "BBB"
                .Execute Replace:=wdReplaceAll
            End With
            ' Loop through InlineShapes if needed
            Set shp = rng.InlineShapes(1)
            If shp.Type = wdInlineShapePicture Then
                shp.Delete
                Set shp = rng.InlineShapes.AddPicture(FileName:=newImageFilePath, _
                    LinkToFile:=False, SaveWithDocument:=True)
                shp.Width = 200
                shp.Height = 100
            End If
        End If
    Next sec
End Sub

Microsoft reference document:

Section.Headers property (Word)