Replace Image in Document Header (Multiple Documents)

[DekHog]

Hi all....

Our company name has changed, this means that some 3000-odd documents (maintenance routines) with the old company image in the header require replacing!

Each header is a table with the image in the top left cell, and text (which isn't changing) in the remaining cells and rows of the header - is there any way to select a folder containing all the documents and run code to replace the (jpg) image in them all?

TIA

[gmaxey]

In basic form:


Sub ChangePic()
Dim oFile
oFile = Dir("C:\Users\Maxey\Desktop\BatchFolder\*.doc*") 'Change this path to reflect your batch folder path.
Do While oFile <> ""
Application.Documents.Open oFile
With ActiveDocument.StoryRanges(wdPrimaryHeaderStory)
.GoTo what:=wdGoToGraphic, Count:=1
.Delete
.InlineShapes.AddPicture FileName:="D:\Replacement Pic.jpg" 'Change this file path and name to reflect your new picture path and name.
End With
If ActiveDocument.Saved = False Then ActiveDocument.Save
ActiveDocument.Close
oFile = Dir
Loop
End Sub

[DekHog]

Thanks so much, I'll try this tomorrow.....

[gmaxey]

Be sure to try it on a small sample batch of files first.

[DekHog]

OK, decided to try a small batch with an easy folder path..... it pretty much bombs on the line Application.Documents.Open oFile - quick Google search and the MS article on the error didn't really help?

16769

It knows the file is there as it states the name in the error......

16770


I wish I understood this stuff better, but I'm now STUCK! :yes

[gmayor]

It doesn't find it because you need to supply the path as well as the name to Application.documents.open. The following will work subject to provisos
1. that the image is in the primary header of the first section.
2. That the image to be replaced is the first image in that header
3. That the image to be replaced is inserted in line.

If any of these are not true for your documents, then provide the missing details:

Option Explicit

Sub ChangePic()
Dim strFile As String
Dim oRng As Range
Dim oShape As InlineShape
Const strPath As String = "C:\PMRHeader\PMR\"
Const strNewImage As String = "C:\PMRHeader\Repso1.jpg"
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 & "*.doc*")
Do While strFile <> ""
Application.Documents.Open strPath & strFile
If ActiveDocument.StoryRanges(wdPrimaryHeaderStory).InlineShapes.Count > 0 Then
Set oRng = ActiveDocument.StoryRanges(wdPrimaryHeaderStory).InlineShapes(1).Range
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

[DekHog]

Probably closer..... it goes through the motions, flickers as it appears to be doing each document, but nothing in the header actually changes when I look at them..... your three points above. 1 & 2 are definitely a 'yes', but what exactly does 'in line' mean in 3? Thanks again.....

The header looks like this....

16771

[gmayor]

By default Word inserts images 'in line' with the text, but they can be inserted with various wrap options, which require different processing. However as you have a table in the header that makes things easier


Option Explicit

Sub ChangePic()
Dim strFile As String
Dim oRng As Range
Dim oShape As InlineShape
Const strPath As String = "C:\PMRHeader\PMR\"
Const strNewImage As String = "C:\PMRHeader\Repso1.jpg"
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 & "*.doc*")
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
If that doesn't work for you, post a document sample.

[gmaxey]

Graham is correct of course concerning path and name. However something weird happened yesterday because the code as posted ran twice without error.

[DekHog]

It works!! :) ....... but removes the page border? :(

16772

16773

[gmaxey]

Can you attached one of these documents and your new graphic file?

[DekHog]

Yup, here's one of the original files plus the graphic..... thanks.

16776

[gmaxey]

Ok, the following processes the file you attached:


Sub ChangePic()
Dim strFile As String
Dim oRng As Range
Const strPath As String = "C:\Users\Maxey\Desktop\AAA\" '"C:\PMRHeader\PMR\"
Const strNewImage As String = "D:\Replacement Pic.jpg" '"C:\PMRHeader\Repso1.jpg"

strFile = Dir$(strPath & "*.doc")
Do While strFile <> ""
Application.Documents.Open strPath & strFile
If ActiveDocument.StoryRanges(wdPrimaryHeaderStory).ShapeRange.Count = 2 Then
Set oRng = ActiveDocument.StoryRanges(wdPrimaryHeaderStory).ShapeRange.Item(2).Anchor
ActiveDocument.StoryRanges(wdPrimaryHeaderStory).ShapeRange.Item(2).Delete
oRng.InlineShapes.AddPicture strNewImage
If ActiveDocument.Saved = False Then ActiveDocument.Save
End If
ActiveDocument.Close
strFile = Dir$
Loop
lbl_Exit:
Exit Sub
End Sub

[DekHog]

Greg, thanks..... I'm just about to hit the road home but will try this first thing in the morning when back in the office and update the thread.... :bow:

[DekHog]

Works perfect, thanks. A huge thanks to Greg and Graham for their assistance...... I'm in awe of people who can do this stuff; I tried for quite a long time to get my head around it, but I had to admit defeat and came to the conclusion my brain just isn't 'wired' for coding of any kind..... probably too old (or not enough brain cells) to start it..... :bow::bow:

[gmaxey]

For the set of documents where the image to be replaced is inline, use:


strFile = Dir$(strPath & "*.doc")
Do While strFile <> ""
Application.Documents.Open strPath & strFile
If ActiveDocument.StoryRanges(wdPrimaryHeaderStory).InlineShapes.Count = 1 Then
Set oRng = ActiveDocument.StoryRanges(wdPrimaryHeaderStory).InlineShapes(1).Range
ActiveDocument.StoryRanges(wdPrimaryHeaderStory).InlineShapes(1).Delete
oRng.InlineShapes.AddPicture strNewImage
If ActiveDocument.Saved = False Then ActiveDocument.Save
End If
ActiveDocument.Close
strFile = Dir$
Loop

[SamT]

@ theHydra

Your question has been moved to http://www.vbaexpress.com/forum/showthread.php?62360-Replace-Image-in-Document-Header

And this thread has been closed