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?

Capture1.JPG

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

Capture2.JPG


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

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

Capture.JPG

[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).Range
            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?

Capture.JPG

Capture1.JPG

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

Files.zip

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

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

[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/show...ocument-Header

And this thread has been closed