Header Macro Doesn't Insert Image into Sections

Yes it only works for Section  by design:

   For Each hdr In ActiveDocument.Sections(1).Headers

You need to step through each section

Sub LogoAdd()
'...
Dim sec as Section
'...
For each sec in ActiveDocument.Sections
   For Each hdr In sec.Headers
'...

        End With
    Next hdr
Next sec
End Sub

Select allOpen in new window

Okay, that makes sense.  So just add another for loop to encompass the other loop?

Yes. That's the idea.

Incidentally, the empty Do loop at lines 17 and 18 looks unnecessary

            Do While sh.Name = "Logo" & CStr(hdr.Index)
            Loop

(even if it was written by myself for the related question)

Ok.  I have added the for loop and commented out lines 17 and 18 like you suggested.  I ran the macro on a document with different sections, and it gave me a Run-time error '70' Permission denied error.  However, it inserted the image on all pages of the Word document, except for the page right after the section break.  So there is one page in the middle of the document that has the section break, and thats the only page that does not have the image in the header.

Here is my code:

Sub LogoAdd()
    Dim sh As Shape
    Dim hdr As HeaderFooter
    Dim rng As Range
    Dim strPicture As String
    Dim sec As Section
    
    strPicture = "\\SERVER\Logo.png"
    For Each sec In ActiveDocument.Sections
        For Each hdr In sec.Headers
    
            Set rng = hdr.Range
            rng.Collapse wdCollapseEnd
            Set sh = ShapesAddPicture(strPicture, False, True, 0, 0, , , rng)
            sh.Name = "Logo"
        
            If sh.Name = "Logo" Then
                'Do While sh.Name = "Logo" & CStr(hdr.Index)
                'Loop
                sh.Name = "Logo" & CStr(hdr.Index)
            Else
                sh.Name = "Logo"
            End If
        
            With sh
                .WrapFormat.AllowOverlap = True
                .WrapFormat.Side = wdWrapNone
                .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
                .Left = 10
                .RelativeVerticalPosition = wdRelativeVerticalPositionPage
                .Top = 15
            End With
        Next hdr
    Next sec
End Sub

Select allOpen in new window

Okay, great thanks!  I am still getting an error when running it on a document with multiple sections, the error I am getting is:

Run-time error '-2147024809 (80070057)'
The Index into the specified collection is out of bounds.

Any thoughts?

Thanks

I can't reproduce that. Which line does it fail on?

It won't give me an option to debug so I can see what line it is.  However, it is still inserting the image in all the headers no matter how many sections the document has.  I think that error is coming up because it is inserting the image into the first page header twice.  So when I run the macro I can see it inserting the image onto every page, then it comes back to the first page and re-adds the same image on top of the other, then error message comes up.  

So in short its putting the same image onto the first page twice, putting the images on top of each other.

When I try to run the macro in Word 2007 on a document, it gives me a slightly different error than Word 2003.  The 2007 error is:

Run-time error '5':
Invalid procedure call or argument.

It is strange that the errors don't put VBA into break mode.

However here is some enhanced code that also has some extra debug statements. If if fails can you copy the text from the immediate window and paste it here, please?

Sub LogoAdd()
    Dim sh As Shape
    Dim hdr As HeaderFooter
    Dim rng As Range
    Dim strPicture As String
    Dim sec As Section
    
    strPicture = "\\SERVER\Logo.png"
    Debug.Print "Deleting *************"
    For Each sec In ActiveDocument.Sections
        Debug.Print "sec: " & sec.Index, "FP: ", sec.PageSetup.DifferentFirstPageHeaderFooter, _
                    "OE: " & sec.PageSetup.OddAndEvenPagesHeaderFooter
        For Each hdr In sec.Headers
            Debug.Print "hdr: " & hdr.Index
            If hdr.LinkToPrevious = False Then
                Debug.Print "shapes: " & hdr.Shapes.Count
                Do While hdr.Shapes.Count > 0
                    With hdr.Shapes(1)
                         Debug.Print "Deleting: " & .Name
                        .Delete
                    End With
                Loop
            End If
        Next hdr
    Next sec
    Debug.Print "Adding ***************"
    For Each sec In ActiveDocument.Sections
        Debug.Print "sec: " & sec.Index, "FP: ", sec.PageSetup.DifferentFirstPageHeaderFooter, _
                    "OE: " & sec.PageSetup.OddAndEvenPagesHeaderFooter
        For Each hdr In sec.Headers
            Debug.Print "hdr: " & hdr.Index
            Dim bUnlinked As Boolean
            Dim bLinked As Boolean
            Debug.Print "LTP: " & hdr.LinkToPrevious
            If sec.Index = 1 Then
                bLinked = False
            Else
                bLinked = hdr.LinkToPrevious
            End If
            Debug.Print "bLinked: " & bLinked
            bUnlinked = Not bLinked
            If Not bLinked Then
                Set rng = hdr.Range
                rng.Collapse wdCollapseEnd
                Set sh = ShapesAddPicture(strPicture, False, True, 0, 0, , , rng)
                With sh
                    .Name = "Logo" & sec.Index & "_" & CStr(hdr.Index)
                    Debug.Print "Name: " & .Name
                    .WrapFormat.AllowOverlap = True
                    .WrapFormat.Side = wdWrapNone
                    .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
                    .Left = 10
                    .RelativeVerticalPosition = wdRelativeVerticalPositionPage
                    .Top = 15
                End With
            End If
        Next hdr
    Next sec
End Sub

Select allOpen in new window

Hi GrahamSkan,

Thanks for your response and help.  Unfortunately, I am still getting the same errors and the image being inserted into the first page header twice (on top of each other).  Again, the errors are varying based if I am using word 2003 or word 2007.  I have the error message images attached to this post.

Please let me know if you need anything else.

Thanks!
error-word-2003.png
error-word-2007.png

The macro is also removing the text box in the header of the document.  Before we made the changes in this forum thread it would keep the text box in the header of the document.  

Ah. The text box removal is explainable. To make sure that I have a clean document to work with in the tests, I delete all the shapes, including text boxes. This routine will be deleted once we have sorted out the problem'

However, what I really need is line on which the error occurs. Because you report that the code does not enter the break mode, we can't identify the error line, so we will need to see text in the VBA immediate window.

Okay.  I found the line it is failing on and its in the Function ShapesAddPicture:

.CanvasItems.AddPicture strPicture, False, True, 0, 0, 10, 10

The reason the debug was not working earlier was because I was running the macro out of a .dot file in the startup folder of Microsoft Office (read only folder).  

Let me know if that helps or if you need anymore info.

Thanks!

Function ShapesAddPicture(strPicture As String, Optional LinkToFile As Variant = False, _
  Optional SaveWithDocument As Variant = True, Optional Left As Variant = Nothing, _
  Optional Top As Variant = Nothing, Optional width As Variant = Nothing, _
  Optional Height As Variant = Nothing, Optional Anchor As Range) As Shape

    Dim lngSection As Long
    Dim objHeaderFooter As HeaderFooter
    Dim objSeekView As WdSeekView
    Dim rngSelection As Range
    Dim slgWidth As Single

    'FileName = Application.Options.DefaultFilePath(wdUserOptionsPath) & _
      "\..\..\All Users\Documents\My Pictures\Sample Pictures\Blue hills.jpg"

    'Validate parameters
    If Anchor Is Nothing Then Set Anchor = Selection.Paragraphs(1).Range
    lngSection = Anchor.Sections(1).Index

    Select Case Anchor.StoryType
        Case wdPrimaryHeaderStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Headers(wdHeaderFooterPrimary)
        Case wdFirstPageHeaderStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Headers(wdHeaderFooterFirstPage)
        Case wdEvenPagesHeaderStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Headers(wdHeaderFooterEvenPages)
        Case wdPrimaryFooterStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Footers(wdHeaderFooterPrimary)
        Case wdFirstPageFooterStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Footers(wdHeaderFooterFirstPage)
        Case wdEvenPagesFooterStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Footers(wdHeaderFooterEvenPages)
        Case Else
            Set ShapesAddPicture = ActiveDocument.Shapes.AddPicture(strPicture, LinkToFile, _
              SaveWithDocument, Left, Top, width, Height, Anchor)
            'Not in a header, function not needed.
            Exit Function
    End Select

    If IsNumeric(Left) <> True Then Left = 0
    If IsNumeric(Top) <> True Then Top = 0
    If IsNumeric(width) <> True Then Set width = Nothing
    If IsNumeric(Height) <> True Then Set Height = Nothing

    'Make process invisible to user
    Application.ScreenUpdating = False
    'Store seekview and selection as we will change this
    Set rngSelection = Selection.Range
    objSeekView = ActiveWindow.ActivePane.View.SeekView

    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader

    With objHeaderFooter
        'AddCanvas, unlike other methods such as AddShape, overwrites the anchor
        'range. Set up a new paragraph to overwrite before adding the canvas
        objHeaderFooter.Range.InsertParagraphBefore '<----
        With .Shapes.AddCanvas(0, 0, 10, 10, objHeaderFooter.Range.Paragraphs.First.Range) '<----
            'Note that for some reason the OPTIONAL parameters in this function
            'are NOT optional. Omitting them will cause an error.
            'Sicne we do not know the dimensions of our image, just insert at
            'any size and then use Scale to revert the image to the correct size.
            'Further scaling can be done afterwards after aspect ratio is locked.
            .CanvasItems.AddPicture strPicture, False, True, 0, 0, 10, 10
            .CanvasItems(1).LockAspectRatio = msoFalse
            .CanvasItems(1).ScaleHeight 1, msoTrue
            .CanvasItems(1).ScaleWidth 1, msoTrue
            'Size the Picture per parameters passed, if none, then ensure Picture
            'does not exceed width of the margins.
            If Not width Is Nothing And Not Height Is Nothing Then
                .width = width
                .Height = Height
            ElseIf Not width Is Nothing Then
                .CanvasItems(1).LockAspectRatio = msoTrue
                .width = width
            ElseIf Not Height Is Nothing Then
                .CanvasItems(1).LockAspectRatio = msoTrue
                .Height = Height
            Else
                .CanvasItems(1).LockAspectRatio = msoTrue
                slgWidth = _
                  ActiveDocument.Sections(lngSection).PageSetup.PageWidth - _
                  ActiveDocument.Sections(lngSection).PageSetup.LeftMargin - _
                  ActiveDocument.Sections(lngSection).PageSetup.RightMargin - _
                  Anchor.ParagraphFormat.LeftIndent - _
                  Anchor.ParagraphFormat.RightIndent
                If .CanvasItems(1).width > slgWidth Then
                    .CanvasItems(1).width = slgWidth
                End If
            End If

            'This is a mandatory step, without selecting the shape, the ungroup
            'method will throw the shapes in the canvas to the first section!
            .Select
            .Ungroup
            Set ShapesAddPicture = objHeaderFooter.Range.ShapeRange(1)
        End With
    End With

    'Now we're done, restore the users previous seekview, selection and
    'enable screen updating again.
    ActiveWindow.ActivePane.View.SeekView = objSeekView
    rngSelection.Select
    Application.ScreenUpdating = True

End Function

Select allOpen in new window

And is it still the 'The index into the specified error is out of bounds' error?

I would still like to see the Debug.Print output, so we can see how far through the document is gets.

The modified macro below avoids deleting text boxes.

Sub LogoAdd()
    Dim sh As Shape
    Dim hdr As HeaderFooter
    Dim rng As Range
    Dim strPicture As String
    Dim sec As Section
    
    strPicture = "I:\Allwork\ee\27324191\nreca_logo_4.png"
    Debug.Print "Deleting *************"
    For Each sec In ActiveDocument.Sections
        Debug.Print "sec: " & sec.Index, "FP: ", sec.PageSetup.DifferentFirstPageHeaderFooter, _
                    "OE: " & sec.PageSetup.OddAndEvenPagesHeaderFooter
        For Each hdr In sec.Headers
            Debug.Print "hdr: " & hdr.Index
            If hdr.LinkToPrevious = False Then
                Debug.Print "shapes: " & hdr.Shapes.Count
                For Each sh In hdr.Shapes
                    If sh.Type <> msoTextBox Then
                        Debug.Print "Deleting: " & sh.Name
                        sh.Delete
                    End If
                Next sh
            End If
        Next hdr
    Next sec
    Debug.Print "Adding ***************"
    For Each sec In ActiveDocument.Sections
        Debug.Print "sec: " & sec.Index, "FP: ", sec.PageSetup.DifferentFirstPageHeaderFooter, _
                    "OE: " & sec.PageSetup.OddAndEvenPagesHeaderFooter
        For Each hdr In sec.Headers
            Debug.Print "hdr: " & hdr.Index
            Dim bUnlinked As Boolean
            Dim bLinked As Boolean
            Debug.Print "LTP: " & hdr.LinkToPrevious
            If sec.Index = 1 Then
                bLinked = False
            Else
                bLinked = hdr.LinkToPrevious
            End If
            Debug.Print "bLinked: " & bLinked
            bUnlinked = Not bLinked
            If Not bLinked Then
                Set rng = hdr.Range
                rng.Collapse wdCollapseEnd
                Set sh = ShapesAddPicture(strPicture, False, True, 0, 0, , , rng)
                With sh
                    .Name = "Logo" & sec.Index & "_" & CStr(hdr.Index)
                    Debug.Print "Name: " & .Name
                    .WrapFormat.AllowOverlap = True
                    .WrapFormat.Side = wdWrapNone
                    .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
                    .Left = 10
                    .RelativeVerticalPosition = wdRelativeVerticalPositionPage
                    .Top = 15
                End With
            End If
        Next hdr
    Next sec
End Sub

Select allOpen in new window

For some reason I can not get any of the debug.print statements to print anything out on the screen.  Do you have any idea why?  But, I think I have found out what is going wrong, but not exactly sure why.  So here is the environment I am executing the macro in.  

I am using Word 2003 and have the macro saved in a global template in the startup directory for Word.  I cannot reproduce the errors I mentioned earlier if I start Word 2003 and create a new document, the macro works fine, no matter how many sections or pages.  However, if I generate a Word document through the program we are using and run the macro (without saving the document first) I run into an error, but if I save the document then run the macro it works fine.

When I used the macro in my related solution, it works fine with documents generated through our program, it just doesnt apply to all sections.  So I am confident that it is not the way our program is generating the word documents, something changed between the original macro (related solution) and the latest one we have above that is causing the error to occur.

Furthermore (sorry for the long post), I have tried running the macro from the generated document directly and not the global template and still get the same error, but this time the debug is on a different line in the Function ShapesAddPicture (see below):

Set ShapesAddPicture = objHeaderFooter.Range.ShapeRange(1)

Do you have any ideas of what might be causing that error, since the original macro (related solution) works fine with all documents?

Thanks.

I have converted the Debug statements to write text into a log file. The file will be in the default Word documents folder and will have a name like 'shp11276.log'

Can you post the log file after running the code? If it doesn't give an immediate answer, we my have to put some more log points in.

It 01:00 here, so I'm going to bed now & won't be able to reply for seven or eight hours.

Option Explicit

Sub LogoAdd()
    Dim sh As Shape
    Dim hdr As HeaderFooter
    Dim rng As Range
    Dim strPicture As String
    Dim sec As Section
    
    strPicture = "I:\Allwork\ee\27324191\nreca_logo_4.png"
    Writelog "Deleting *************"
    For Each sec In ActiveDocument.Sections
        Writelog "sec: " & sec.Index & ", FP: " & sec.PageSetup.DifferentFirstPageHeaderFooter & _
                    ", OE: " & sec.PageSetup.OddAndEvenPagesHeaderFooter
        For Each hdr In sec.Headers
            Writelog "hdr: " & hdr.Index
            If hdr.LinkToPrevious = False Then
                Writelog "shapes: " & hdr.Shapes.Count
                For Each sh In hdr.Shapes
                    If sh.Type <> msoTextBox Then
                        Writelog "Deleting: " & sh.Name
                        sh.Delete
                    End If
                Next sh
            End If
        Next hdr
    Next sec
    Writelog "Adding ***************"
    For Each sec In ActiveDocument.Sections
        Writelog "sec: " & sec.Index & ", FP: " & sec.PageSetup.DifferentFirstPageHeaderFooter & _
                    ", OE: " & sec.PageSetup.OddAndEvenPagesHeaderFooter
        For Each hdr In sec.Headers
            Writelog "hdr: " & hdr.Index
            Dim bUnlinked As Boolean
            Dim bLinked As Boolean
            Writelog "LTP: " & hdr.LinkToPrevious
            If sec.Index = 1 Then
                bLinked = False
            Else
                bLinked = hdr.LinkToPrevious
            End If
            Writelog "bLinked: " & bLinked
            bUnlinked = Not bLinked
            If Not bLinked Then
                Set rng = hdr.Range
                rng.Collapse wdCollapseEnd
                Set sh = ShapesAddPicture(strPicture, False, True, 0, 0, , , rng)
                With sh
                    .Name = "Logo" & sec.Index & "_" & CStr(hdr.Index)
                    Writelog "Name: " & .Name
                    .WrapFormat.AllowOverlap = True
                    .WrapFormat.Side = wdWrapNone
                    .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
                    .Left = 10
                    .RelativeVerticalPosition = wdRelativeVerticalPositionPage
                    .Top = 15
                End With
            End If
        Next hdr
    Next sec
End Sub

Function ShapesAddPicture(FileName As String, Optional LinkToFile As Variant = False, _
  Optional SaveWithDocument As Variant = True, Optional Left As Variant = Nothing, _
  Optional Top As Variant = Nothing, Optional Width As Variant = Nothing, _
  Optional Height As Variant = Nothing, Optional Anchor As Range) As Shape

    Dim lngSection As Long
    Dim objHeaderFooter As HeaderFooter
    Dim objSeekView As WdSeekView
    Dim rngSelection As Range
    Dim slgWidth As Single

    'FileName = Application.Options.DefaultFilePath(wdUserOptionsPath) & _
      "\..\..\All Users\Documents\My Pictures\Sample Pictures\Blue hills.jpg"

    'Validate parameters
    Writelog "ShapesAddPicture. FileName = " & FileName
    If Anchor Is Nothing Then Set Anchor = Selection.Paragraphs(1).Range
    lngSection = Anchor.Sections(1).Index
    Writelog "ShapesAddPicture. Anchor.StoryType = " & Anchor.StoryType
    Select Case Anchor.StoryType
        Case wdPrimaryHeaderStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Headers(wdHeaderFooterPrimary)
        Case wdFirstPageHeaderStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Headers(wdHeaderFooterFirstPage)
        Case wdEvenPagesHeaderStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Headers(wdHeaderFooterEvenPages)
        Case wdPrimaryFooterStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Footers(wdHeaderFooterPrimary)
        Case wdFirstPageFooterStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Footers(wdHeaderFooterFirstPage)
        Case wdEvenPagesFooterStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Footers(wdHeaderFooterEvenPages)
        Case Else
            Set ShapesAddPicture = ActiveDocument.Shapes.AddPicture(FileName, LinkToFile, _
              SaveWithDocument, Left, Top, Width, Height, Anchor)
            'Not in a header, function not needed.
            Exit Function
    End Select

    If IsNumeric(Left) <> True Then Left = 0
    If IsNumeric(Top) <> True Then Top = 0
    If IsNumeric(Width) <> True Then Set Width = Nothing
    If IsNumeric(Height) <> True Then Set Height = Nothing

    'Make process invisible to user
    Application.ScreenUpdating = False
    'Store seekview and selection as we will change this
    Set rngSelection = Selection.Range
    objSeekView = ActiveWindow.ActivePane.View.SeekView

    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader

    With objHeaderFooter
        'AddCanvas, unlike other methods such as AddShape, overwrites the anchor
        'range. Set up a new paragraph to overwrite before adding the canvas
        objHeaderFooter.Range.InsertParagraphBefore '<----
        Writelog "ShapesAddPicture. Adding canvas"
        With .Shapes.AddCanvas(0, 0, 10, 10, objHeaderFooter.Range.Paragraphs.First.Range) '<----
            'Note that for some reason the OPTIONAL parameters in this function
            'are NOT optional. Omitting them will cause an error.
            'Sicne we do not know the dimensions of our image, just insert at
            'any size and then use Scale to revert the image to the correct size.
            'Further scaling can be done afterwards after aspect ratio is locked.
            Writelog "ShapesAddPicture. Adding picture"
            .CanvasItems.AddPicture FileName, False, True, 0, 0, 10, 10
            .CanvasItems(1).LockAspectRatio = msoFalse
            .CanvasItems(1).ScaleHeight 1, msoTrue
            .CanvasItems(1).ScaleWidth 1, msoTrue
            'Size the Picture per parameters passed, if none, then ensure Picture
            'does not exceed width of the margins.
            If Not Width Is Nothing And Not Height Is Nothing Then
                .Width = Width
                .Height = Height
            ElseIf Not Width Is Nothing Then
                .CanvasItems(1).LockAspectRatio = msoTrue
                .Width = Width
            ElseIf Not Height Is Nothing Then
                .CanvasItems(1).LockAspectRatio = msoTrue
                .Height = Height
            Else
                .CanvasItems(1).LockAspectRatio = msoTrue
                slgWidth = _
                  ActiveDocument.Sections(lngSection).PageSetup.PageWidth - _
                  ActiveDocument.Sections(lngSection).PageSetup.LeftMargin - _
                  ActiveDocument.Sections(lngSection).PageSetup.RightMargin - _
                  Anchor.ParagraphFormat.LeftIndent - _
                  Anchor.ParagraphFormat.RightIndent
                If .CanvasItems(1).Width > slgWidth Then
                    .CanvasItems(1).Width = slgWidth
                End If
            End If

            'This is a mandatory step, without selecting the shape, the ungroup
            'method will throw the shapes in the canvas to the first section!
            .Select
            .Ungroup
            Set ShapesAddPicture = objHeaderFooter.Range.ShapeRange(1)
        End With
    End With

    'Now we're done, restore the users previous seekview, selection and
    'enable screen updating again.
    ActiveWindow.ActivePane.View.SeekView = objSeekView
    rngSelection.Select
    Application.ScreenUpdating = True
    Writelog "ShapesAddPicture. Ending"
End Function

Sub Writelog(strText As String)
    Dim f As Integer
    Dim strFile As String
    
    strText = Format(Now, "hh:nn:ss") & " " & strText
    Debug.Print strText
    f = FreeFile
    strFile = Options.DefaultFilePath(wdDocumentsPath) & "\shp" & Format(Now, "yy") & Format(Now, "y") & ".log"
    Open strFile For Append As #f
        Print #f, strText
    Close #f
End Sub

Select allOpen in new window

I apologize for the delay in getting back to you.  I have attached the log file as you requested.  Let me know if you need anything else.

Thanks for all your help!
shp11283.log

It seems to be failing inside the 'ShapesAddPicture' function when working on the First Page header of the last (fourth) section. However, I still can't reproduce the problem., so I've put a couple of extra log points in the function.

Can you do the same again, please?

Function ShapesAddPicture(FileName As String, Optional LinkToFile As Variant = False, _
  Optional SaveWithDocument As Variant = True, Optional Left As Variant = Nothing, _
  Optional Top As Variant = Nothing, Optional Width As Variant = Nothing, _
  Optional Height As Variant = Nothing, Optional Anchor As Range) As Shape

    Dim lngSection As Long
    Dim objHeaderFooter As HeaderFooter
    Dim objSeekView As WdSeekView
    Dim rngSelection As Range
    Dim slgWidth As Single

    'FileName = Application.Options.DefaultFilePath(wdUserOptionsPath) & _
      "\..\..\All Users\Documents\My Pictures\Sample Pictures\Blue hills.jpg"

    'Validate parameters
    Writelog "ShapesAddPicture. FileName = " & FileName
    If Anchor Is Nothing Then Set Anchor = Selection.Paragraphs(1).Range
    lngSection = Anchor.Sections(1).Index
    Writelog "ShapesAddPicture. Anchor.StoryType = " & Anchor.StoryType
    Select Case Anchor.StoryType
        Case wdPrimaryHeaderStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Headers(wdHeaderFooterPrimary)
        Case wdFirstPageHeaderStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Headers(wdHeaderFooterFirstPage)
        Case wdEvenPagesHeaderStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Headers(wdHeaderFooterEvenPages)
        Case wdPrimaryFooterStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Footers(wdHeaderFooterPrimary)
        Case wdFirstPageFooterStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Footers(wdHeaderFooterFirstPage)
        Case wdEvenPagesFooterStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Footers(wdHeaderFooterEvenPages)
        Case Else
            Set ShapesAddPicture = ActiveDocument.Shapes.AddPicture(FileName, LinkToFile, _
              SaveWithDocument, Left, Top, Width, Height, Anchor)
            'Not in a header, function not needed.
            Exit Function
    End Select

    If IsNumeric(Left) <> True Then Left = 0
    If IsNumeric(Top) <> True Then Top = 0
    If IsNumeric(Width) <> True Then Set Width = Nothing
    If IsNumeric(Height) <> True Then Set Height = Nothing

    'Make process invisible to user
    Application.ScreenUpdating = False
    'Store seekview and selection as we will change this
    Set rngSelection = Selection.Range
    objSeekView = ActiveWindow.ActivePane.View.SeekView

    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader

    With objHeaderFooter
        'AddCanvas, unlike other methods such as AddShape, overwrites the anchor
        'range. Set up a new paragraph to overwrite before adding the canvas
        objHeaderFooter.Range.InsertParagraphBefore '<----
        Writelog "ShapesAddPicture. Adding canvas"
        With .Shapes.AddCanvas(0, 0, 10, 10, objHeaderFooter.Range.Paragraphs.First.Range) '<----
            'Note that for some reason the OPTIONAL parameters in this function
            'are NOT optional. Omitting them will cause an error.
            'Sicne we do not know the dimensions of our image, just insert at
            'any size and then use Scale to revert the image to the correct size.
            'Further scaling can be done afterwards after aspect ratio is locked.
            Writelog "ShapesAddPicture. Adding picture"
            .CanvasItems.AddPicture FileName, False, True, 0, 0, 10, 10
            .CanvasItems(1).LockAspectRatio = msoFalse
            .CanvasItems(1).ScaleHeight 1, msoTrue
            .CanvasItems(1).ScaleWidth 1, msoTrue
            'Size the Picture per parameters passed, if none, then ensure Picture
            'does not exceed width of the margins.
            If Not Width Is Nothing And Not Height Is Nothing Then
                .Width = Width
                .Height = Height
            ElseIf Not Width Is Nothing Then
                .CanvasItems(1).LockAspectRatio = msoTrue
                .Width = Width
            ElseIf Not Height Is Nothing Then
                .CanvasItems(1).LockAspectRatio = msoTrue
                .Height = Height
            Else
                .CanvasItems(1).LockAspectRatio = msoTrue
                slgWidth = _
                  ActiveDocument.Sections(lngSection).PageSetup.PageWidth - _
                  ActiveDocument.Sections(lngSection).PageSetup.LeftMargin - _
                  ActiveDocument.Sections(lngSection).PageSetup.RightMargin - _
                  Anchor.ParagraphFormat.LeftIndent - _
                  Anchor.ParagraphFormat.RightIndent
                If .CanvasItems(1).Width > slgWidth Then
                    .CanvasItems(1).Width = slgWidth
                End If
            End If
            Writelog "ShapesAddPicture. Width & Height Set"
            'This is a mandatory step, without selecting the shape, the ungroup
            'method will throw the shapes in the canvas to the first section!
            .Select
            .Ungroup
            Set ShapesAddPicture = objHeaderFooter.Range.ShapeRange(1)
            Writelog "ShapesAddPicture. Return object set"
        End With
    End With

    'Now we're done, restore the users previous seekview, selection and
    'enable screen updating again.
    ActiveWindow.ActivePane.View.SeekView = objSeekView
    rngSelection.Select
    Application.ScreenUpdating = True
    Writelog "ShapesAddPicture. Ending"
End Function

Select allOpen in new window

Also this is my test document. Can you see if it fails on this for you? If not, can you post a document that it does fail on?
HeaderLogo.docx

Okay thanks. I have attached the log file.  I tried your document and it works fine.  Its strange, once I generate the document through our program and run the macro without saving the document to my desktop it fails with the error.  BUT, once I save the document to my desktop, close out of it, open it from my desktop and run the macro it works fine.  

So I really wish I could send you a document that gives the error, but if I send it to you I am 100% positive it will work for you, since I would have to save to my desktop or another folder to give it to you. I even tried giving you a sample document, but once I save it to my desktop and re-open it in Word it doesnt give me the error anymore.  So at this point I really have no clue what the problem is.  

I ran the macro multiple times, so in the log file you will see the macro running on the document saved on the desktop also.  So, it should show when the macro fails and when it works.
shp11284.log

There are four runs in the file. The only difference that I can see is that the number of sections is different. They all terminate early.

We are down to about three instructions. Form the 2003 symptom, I would suspect this instruction:

Set ShapesAddPicture = objHeaderFooter.Range.ShapeRange(1)

To certain, there are a couple more logpoints here:

 

Function ShapesAddPicture(FileName As String, Optional LinkToFile As Variant = False, _
  Optional SaveWithDocument As Variant = True, Optional Left As Variant = Nothing, _
  Optional Top As Variant = Nothing, Optional Width As Variant = Nothing, _
  Optional Height As Variant = Nothing, Optional Anchor As Range) As Shape

    Dim lngSection As Long
    Dim objHeaderFooter As HeaderFooter
    Dim objSeekView As WdSeekView
    Dim rngSelection As Range
    Dim slgWidth As Single

    'FileName = Application.Options.DefaultFilePath(wdUserOptionsPath) & _
      "\..\..\All Users\Documents\My Pictures\Sample Pictures\Blue hills.jpg"

    'Validate parameters
    Writelog "ShapesAddPicture. FileName = " & FileName
    If Anchor Is Nothing Then Set Anchor = Selection.Paragraphs(1).Range
    lngSection = Anchor.Sections(1).Index
    Writelog "ShapesAddPicture. Anchor.StoryType = " & Anchor.StoryType
    Select Case Anchor.StoryType
        Case wdPrimaryHeaderStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Headers(wdHeaderFooterPrimary)
        Case wdFirstPageHeaderStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Headers(wdHeaderFooterFirstPage)
        Case wdEvenPagesHeaderStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Headers(wdHeaderFooterEvenPages)
        Case wdPrimaryFooterStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Footers(wdHeaderFooterPrimary)
        Case wdFirstPageFooterStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Footers(wdHeaderFooterFirstPage)
        Case wdEvenPagesFooterStory
            Set objHeaderFooter = ActiveDocument.Sections(lngSection). _
              Footers(wdHeaderFooterEvenPages)
        Case Else
            Set ShapesAddPicture = ActiveDocument.Shapes.AddPicture(FileName, LinkToFile, _
              SaveWithDocument, Left, Top, Width, Height, Anchor)
            'Not in a header, function not needed.
            Exit Function
    End Select

    If IsNumeric(Left) <> True Then Left = 0
    If IsNumeric(Top) <> True Then Top = 0
    If IsNumeric(Width) <> True Then Set Width = Nothing
    If IsNumeric(Height) <> True Then Set Height = Nothing

    'Make process invisible to user
    Application.ScreenUpdating = False
    'Store seekview and selection as we will change this
    Set rngSelection = Selection.Range
    objSeekView = ActiveWindow.ActivePane.View.SeekView

    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader

    With objHeaderFooter
        'AddCanvas, unlike other methods such as AddShape, overwrites the anchor
        'range. Set up a new paragraph to overwrite before adding the canvas
        objHeaderFooter.Range.InsertParagraphBefore '<----
        Writelog "ShapesAddPicture. Adding canvas"
        With .Shapes.AddCanvas(0, 0, 10, 10, objHeaderFooter.Range.Paragraphs.First.Range) '<----
            'Note that for some reason the OPTIONAL parameters in this function
            'are NOT optional. Omitting them will cause an error.
            'Sicne we do not know the dimensions of our image, just insert at
            'any size and then use Scale to revert the image to the correct size.
            'Further scaling can be done afterwards after aspect ratio is locked.
            Writelog "ShapesAddPicture. Adding picture"
            .CanvasItems.AddPicture FileName, False, True, 0, 0, 10, 10
            .CanvasItems(1).LockAspectRatio = msoFalse
            .CanvasItems(1).ScaleHeight 1, msoTrue
            .CanvasItems(1).ScaleWidth 1, msoTrue
            'Size the Picture per parameters passed, if none, then ensure Picture
            'does not exceed width of the margins.
            If Not Width Is Nothing And Not Height Is Nothing Then
                .Width = Width
                .Height = Height
            ElseIf Not Width Is Nothing Then
                .CanvasItems(1).LockAspectRatio = msoTrue
                .Width = Width
            ElseIf Not Height Is Nothing Then
                .CanvasItems(1).LockAspectRatio = msoTrue
                .Height = Height
            Else
                .CanvasItems(1).LockAspectRatio = msoTrue
                slgWidth = _
                  ActiveDocument.Sections(lngSection).PageSetup.PageWidth - _
                  ActiveDocument.Sections(lngSection).PageSetup.LeftMargin - _
                  ActiveDocument.Sections(lngSection).PageSetup.RightMargin - _
                  Anchor.ParagraphFormat.LeftIndent - _
                  Anchor.ParagraphFormat.RightIndent
                If .CanvasItems(1).Width > slgWidth Then
                    .CanvasItems(1).Width = slgWidth
                End If
            End If
            Writelog "ShapesAddPicture. Width & Height Set"
            'This is a mandatory step, without selecting the shape, the ungroup
            'method will throw the shapes in the canvas to the first section!
            .Select
            Writelog "ShapesAddPicture. .Select done"
            .Ungroup
            Writelog "ShapesAddPicture. .Ungroup done"
            Set ShapesAddPicture = objHeaderFooter.Range.ShapeRange(1)
            Writelog "ShapesAddPicture. Return object set"
        End With
    End With

    'Now we're done, restore the users previous seekview, selection and
    'enable screen updating again.
    ActiveWindow.ActivePane.View.SeekView = objSeekView
    rngSelection.Select
    Application.ScreenUpdating = True
    Writelog "ShapesAddPicture. Ending"
End Function

Select allOpen in new window

If it works OK after saving, a workaround would be create code to save and close the file, and then re-open it.

Okay.  Here is the log file.  I would really like to avoid the workaround you suggested and keep it as a last resort.  In the meantime I am also running tests on the macro and trying to figure out why it works when you save the doc on your desktop.

Thanks again for all your help and patience.  
shp11284.log

We seem to be nearing a dead end, but here is one more log point:

            Writelog "ShapesAddPicture. .Ungroup done"
            Writelog "ShapesAddPicture. ShapeRange Count " & objHeaderFooter.Range.ShapeRange.Count '< new log point
            Set ShapesAddPicture = objHeaderFooter.Range.ShapeRange(1)
            Writelog "ShapesAddPicture. Return object set"

I think we should remember that the ShapesAddPicture itself is a get around for a bug, so perhaps we shouldn't be too surprised if we have run up against another one.

Is the code to create  the document complex? If not, if might be worth posting in here.

Okay.  So maybe we should try not using the ShapesAddPicture function to see if we run into another bug, just to check.  

There is no code to generate the Word documents, they are generated through a case management program by basically using pre-defined Word Templates.  The pre-defined templates have merge parameters in them, so all the program does is do a mail merge by putting information regarding a case into the Word document the user has specified to generate.  

Is there anyway you can post the code for the LogoAdd macro that does not use the ShapesAddPicture Function?  I just want to see if it works for the heck of it.  In the meantime I will add the additional log point to the function.

Thanks

Could you consider having the logo already in the templates for the mail merge main documents?

Yeah, I have considered that, but can't do it for certain reasons.  Do you think we can try it without the ShapesAddLogo Function one more time just to see.  If that doesn't work than I will think of something else and close this question (give you full credit of course).

The ShapseAddPicture is a replacement for Shapes.AddPicture, so this line:

                Set sh = ShapesAddPicture(strPicture, False, True, 0, 0, , , rng)

needs to be changed to this:


                Set sh = Shapes.AddPicture(strPicture, False, True, 0, 0, , , rng)

Are there differences between the first page header and the other (prime) page headers, and are there differences between in the headers between sections?

No differences in terms of the logo being inserted.  Both headers have text boxes in them, the text boxes have different text in them of course, but the structure is the same.  No differences in the headers between sections either.  

I get a compile error when I make the change to not use ShapesAddPicture Function.  Not sure exactly what I am missing or doing wrong, any chance you can post the whole working macro code for LogoAdd?

Thanks a lot!

Sorry. I didn't notice that the ShapesAddPicture function assumes the ActeveDocument. We have to add it in.

Set sh = ActiveDocument.Shapes.AddPicture(strPicture, False, True, 0, 0, , , rng)

Good news indeed, and good luck.

My comment/solution was the final code that worked.  The code was developed by the experts solution.