Replace an image with a different image and align text boxes in Word using VBA

Question

I've been trying to replace the title image on a large number of word documents using a recorded macro and replace the footer image. However, when I run the macro on a new document, it doesn't replace the images and deletes the text from the text box. It doesn't touch the footer image at all. I've used basic recorded macros in the past but not to replace images or images in the footer. A friend mentioned that VBA might be needed to insert the image, but I'm less than a novice in that language.

Sub BrandingUpdateV2()
'
' BrandingUpdateV2 Macro
'
'
    ActiveDocument.Shapes.Range(Array("Text Box 2")).Select
    Selection.TypeBackspace
    Selection.MoveDown Unit:=wdLine, Count:=4
    Selection.MoveDown Unit:=wdLine, Count:=13
    Selection.MoveUp Unit:=wdLine, Count:=3
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    Selection.MoveDown Unit:=wdLine, Count:=42
    Selection.MoveUp Unit:=wdLine, Count:=10
    Selection.MoveDown Unit:=wdLine, Count:=1
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    Selection.HeaderFooter.Shapes.Range(Array("Group 50")).Select
    Selection.HeaderFooter.Shapes.Range(Array("Slide Number Placeholder 11" _
        )).Select
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

Do one step at a time and record. Example is just record deleting the image you want, stop and then check the recording. that will be easier than going for the win right away. It's like dating. — pgSystemTester
The macro recorder is notoriously non-helpful when it comes to accessing specific headers and footers - unfortunately. As to doing anything with the pictures: all the code you show us does is select them. There's lots of code samples for accessing the content of headers and footers. Search for something like ActiveDocument.sections(1).Headers(wdHeaderFooterPrimary) to turn some up. — Cindy Meister
Once you get "comfortable" with how to address a header/footer then you can consider working with pictures (Shapes) - but I can tell you that replacing a Shape is not a simple matter. It involves deleting the current one, inserting a new one and re-applying all the properties (position, size, etc.) There is no equivalent to the UI "Change picture" command in VBA. — Cindy Meister

macropod macropod · Accepted Answer · 2018-07-28T11:43:32

Assuming the images are formatted in-line and are located in the header & footer, respectively, following code should do the job for all documents in the selected folder - just add the paths & names for the images in the 'FileName:=""' variables.

Sub UpdateImages()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, sWdth As Single
Dim wdDoc As Document, wdHdFt As HeaderFooter, wdRng As Range, wdIshp As InlineShape
strDocNm = ActiveDocument.FullName
strFolder = GetFolder: If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      With .Sections(1)
        For Each wdHdFt In .Headers
          With wdHdFt
            If .Exists Then
              With .Range
                If .InlineShapes.Count > 0 Then
                  Set wdRng = .InlineShapes(1).Range
                  With .InlineShapes(1)
                    sWdth = .Width
                    .Delete
                  End With
                  Set wdIshp = .InlineShapes.AddPicture(Range:=wdRng, FileName:="")
                  With wdIshp
                    .LockAspectRatio = True
                    .Width = sWdth
                  End With
                End If
              End With
            End If
          End With
        Next
        For Each wdHdFt In .Footers
          With wdHdFt
            If .Exists Then
              With .Range
                If .InlineShapes.Count > 0 Then
                  Set wdRng = .InlineShapes(1).Range
                  With .InlineShapes(1)
                    sWdth = .Width
                    .Delete
                  End With
                  Set wdIshp = .InlineShapes.AddPicture(Range:=wdRng, FileName:="")
                  With wdIshp
                    .LockAspectRatio = True
                    .Width = sWdth
                  End With
                End If
              End With
            End If
          End With
        Next
      End With
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

As you can see, even addressing header & footers is itself not straightforward (a Section can have three of each) and, as Cindy said, there is no VBA equivalent of the UI's 'Change picture' button.

Replace an image with a different image and align text boxes in Word using VBA

1 Answers