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
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