Change header Image in Multiple docs without resize

Hi i have gotten close to solving this issue by looking through the forum with the below but it resizes the image randomly. I had been going through the images one by one and clicking replace which left the image at the same size as the original. All help much appreciated. Thanks

Sub ChangePic()
Dim strFile As String
Dim oRng As Range
Dim oShape As InlineShape
Const strPath As String = "C:\Users\sample\sample\sample"
Const strNewImage As String = "C:\Users\sample\Pictures\Pic1.png"
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(strPath) Then
MsgBox "The document folder '" & strPath & "' is not available."
GoTo lbl_Exit
End If
If Not fso.FileExists(strNewImage) Then
MsgBox "Unable to locate the image file '" & strNewImage & "'"
GoTo lbl_Exit
End If
strFile = Dir$(strPath & "*.docx*")
Do While strFile <> ""
Application.Documents.Open strPath & strFile
If ActiveDocument.StoryRanges(wdPrimaryHeaderStory).Tables.Count > 0 Then
Set oRng = ActiveDocument.StoryRanges(wdPrimaryHeaderStory).Tables(1).Range.Cells(1).R ange
oRng.End = oRng.End - 1
oRng.Text = ""
oRng.InlineShapes.AddPicture FileName:=strNewImage
If ActiveDocument.Saved = False Then ActiveDocument.Save
End If
ActiveDocument.Close
strFile = Dir$
Loop
lbl_Exit:
Exit Sub
End Sub

The problem probably relates to table resizing. Try adding

Code:

---

ActiveDocument.StoryRanges(wdPrimaryHeaderStory).Tables(1).AutoFitBehavior wdAutoFitFixed

---

before

Code:

---

Set oRng = ActiveDocument.StoryRanges(wdPrimaryHeaderStory).Tables(1).Range.Cells(1).Range

---

Thank you that has sorted the issue. You've saved me a tonne of work!