Word 2007 VBA – Bug using .Shapes in Section Headers

Intro to the problem

When using .Shapes in the Header to add certain objects such as a Picture the object will only ever appear in the first section when the following sections are not linked. This happens regardless of how you specify the anchor. Fortunately there is a method to get around this flaw which I believe is also present in 2003.

Following is a list of what is and isn’t affected and two workarounds; a short workaround that can be incorporated into a simple code base, and a long workaround which can replace the .AddPicture method altogether.

Software version used:

• Microsoft Office Word 2007 (12.0.6504.5000) SP2 MSO (12.0.6425.1000)

Applies to:

• AddChart
• AddPicture
• AddTextEffect

Not tested:

• AddOLEControl

Not affected:

• AddCallout
• AddCanvas
• AddCurve
• AddLabel
• AddLine
• AddOLEObject
• AddPolyline
• AddShape
• AddTextbox

Requirements for this example:

• A document with at least 2 sections, without Different First Page or Different Odd and Even or Link to Previous checked
• An image to insert (don’t forget to change the path in the example if need be)

Code to illustrate the error

Option Explicit

Sub BugInShapesAddPicture()

    Dim lngSection As Long
    Dim strImagePath As String

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

    With ActiveDocument.Sections(lngSection).Headers(wdHeaderFooterPrimary)
        .Shapes.AddShape msoShapeRegularPentagon, 10, 10, 100, 100, .Range
        .Shapes.AddPicture FileName:=strImagePath, Anchor:=.Range
    End With

End Sub

Result:

What should happen is that the picture will incorrectly appear in the first section header, and the pentagon will correctly appear in the second section header.

Short workaround code

Option Explicit

Sub BugFixForShapesAddPicture()

    Dim lngSection As Long
    Dim strImagePath As String
    Dim objSeekView As WdSeekView
    Dim rngSelection As Range

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

    '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 ActiveDocument.Sections(lngSection).Headers(wdHeaderFooterPrimary)
        'AddCanvas, unlike other methods such as AddShape, overwrites the anchor range
        'Set up a new paragraph to overwrite before adding the canvas
        .Range.InsertParagraphBefore
        With .Shapes.AddCanvas(0, 0, 10, 10, .Range.Paragraphs.First.Range)
            'Note that for some reason the OPTIONAL paramaters 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 strImagePath, False, True, 0, 0, 10, 10
            .CanvasItems(1).LockAspectRatio = msoFalse
            .CanvasItems(1).ScaleHeight 1, msoTrue
            .CanvasItems(1).ScaleWidth 1, msoTrue
            .CanvasItems(1).LockAspectRatio = msoTrue
            '.CanvasItems(1).Width = 527.3
            '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
        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 Sub

As you can see the workaround is a little involved and as you will see below the replacement function is even more involved! Luckily this bug has been fixed in the Office 2010 tech preview I’m trialing at the moment.

I’ve only tested this in the Word 2007 version specified above, however it should work equally as well in Word 2003.

Long workaround replacement function

Option Explicit

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
    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(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
        Anchor.InsertParagraphBefore
        With .Shapes.AddCanvas(0, 0, 10, 10, Anchor.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 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

End Function