Much ado about Office

16 October 2009

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
Advertisements

11 Comments »

  1. Thanks a lot for this workaround! I had the same problem with watermarks (texteffect). Now I was able to fix it.

    Comment by JJ — 17 November 2011 @ 00:17 | Reply

    • I just have seen your post from 20 October 2009. That’s perfect for me! Thanks a lot!

      Comment by JJ — 17 November 2011 @ 23:06 | Reply

  2. Doskonały wpis, czytałem go z uśmiechem na ustach

    Comment by tutaj — 19 September 2014 @ 16:49 | Reply

  3. I just stumbled over your post….
    I am having a problems with word 2016…

    I have a doc with linked sections.

    I have code that adds a shape to the section 1 footer, but it does not get show on subsequent sections even thouhg they are linked

    Set shp = activedocument.sections(1).Footers(wdHeaderFooterPrimary)..Shapes.AddShape(msoShapeRectangle, 0, 0, CentimetersToPoints(7 * 2.54), CentimetersToPoints(10 * 2.54))

    If I insert something else like text or a picture they correctly appear in all section footers.

    Set shp = activedocument.sections(1).Footers(wdHeaderFooterPrimary).Shapes.Addpicture(“C:\Dropbox\Kls\Architecture\PF2\Graphics\Bitmaps\geocaching.png”)
    is fine

    I’m adding a shape (because I want a shaded background object)

    I note that if I manually add a shape to the footer in section 1, it correctly is shown in all sections linked.

    I’ll carrry on digging…… but any suggestions great recieved.

    Comment by Kevin Lee Smith — 20 May 2017 @ 01:20 | Reply

    • I am also having this problem! Any fixes?

      Comment by calfeehagesfeldMike Hagesfeld — 9 November 2018 @ 07:35 | Reply

      • I just ran a quick test in Word 2016 and it’s working for my simple test doc. I’ll share sample code in a following comment.

        All I can think of is that there might be additional sections in there throwing the document out or the sections are of a different type.

        I’ve noticed that VBA doesn’t seem to affect headers and footers that aren’t shown in the document. For example if you’ve got a continuous section break which does not have link to previous checked. Trying to update this section to link to previous in VBA doesn’t seem to work unless you first show the section (eg by changing it to next page break). I actually struggle with this a lot in long documents that are switching between one and two columns.

        Perhaps the only other thing I can think of is there appears to be a difference between .Sections(n).Footer(type).Shapes and .Sections(n).Footer(type).Range.ShapeRange where the first actually refers to all shapes in all footers and the latter refers to just the shapes in the footer of the one section.

        Comment by snoopen — 9 November 2018 @ 15:07

      • Option Explicit
        
        Sub AddShapeToEachSectionType()
            
            Dim shp_odd As Shape
            Dim shp_first As Shape
            Dim shp_even As Shape
            
            Dim intIndex As Integer
            intIndex = 1
            
            Set shp_odd = ActiveDocument.Sections(intIndex).Footers(wdHeaderFooterPrimary).Shapes.AddShape(msoShapeRectangle, 10, 10, 300, 300)
            Set shp_first = ActiveDocument.Sections(intIndex).Footers(wdHeaderFooterFirstPage).Shapes.AddShape(msoShapeRectangle, 30, 30, 300, 300)
            Set shp_even = ActiveDocument.Sections(intIndex).Footers(wdHeaderFooterEvenPages).Shapes.AddShape(msoShapeRectangle, 20, 20, 300, 300)
            
            shp_odd.TextFrame.TextRange.Text = "Odd"
            shp_first.TextFrame.TextRange.Text = "First"
            shp_even.TextFrame.TextRange.Text = "Even"
            
        End Sub
        
        Sub CheckAllSectionsAreLinked()
            
            Dim objSection As Section
            Dim objHeadFoot As HeaderFooter
            Dim astrSectionType() As String
            
            astrSectionType = Split(",odd/primary,first,even", ",")
            
            For Each objSection In ActiveDocument.Sections
                If objSection.Index = 1 Then
                Else
                    For Each objHeadFoot In objSection.Headers
                        If objHeadFoot.LinkToPrevious = False Then
                            Debug.Print "Section " &amp; objSection.Index &amp; "'s " &amp; astrSectionType(objHeadFoot.Index) &amp; " header is not linked to previous"
                        End If
                    Next
                    For Each objHeadFoot In objSection.Footers
                        If objHeadFoot.LinkToPrevious = False Then
                            Debug.Print "Section " &amp; objSection.Index &amp; "'s " &amp; astrSectionType(objHeadFoot.Index) &amp; " footer is not linked to previous"
                        End If
                    Next
                End If
            Next
            
        End Sub
        

        Comment by snoopen — 9 November 2018 @ 15:21

      • Snoopen – Thanks so much! So in running these tests, I realized the issue was not with the shape not showing, per se (i.e. when I run it by itself it’s fine) but something ishappening in that I am adding a table to the range and this is somehow hiding the shape. My VBA is…rusty? subpar? So I didn’t know if you could easily spot the issue with my code:

        I add the lines to each footer:

        Sub AddLineToFooter(ByVal curFooter As HeaderFooter)
        Dim LineShape As Shape
        Set LineShape = curFooter.shapes.AddShape(msoLine, InchesToPoints(5.03), InchesToPoints(10.5), InchesToPoints(4.29), 0, curFooter.Range)

        LineShape.Line.ForeColor.RGB = RGB(53, 106, 74)
        LineShape.Line.Weight = 0.75
        LineShape.Name = CALFEE_ITEM_NAME
        End Sub

        This works

        Comment by calfeehagesfeldMike Hagesfeld — 10 November 2018 @ 02:35

      • (sorry, accidental post and can’t delete the prior one)
        So after I add the line to the footer, I then add the table to each footer:
        Dim tbl As Table
        Set tbl = CurDoc.Tables.Add(curFooter.Range, 1, 1)
        tbl.LeftPadding = 0
        tbl.RightPadding = 0
        tbl.Rows.RelativeVerticalPosition = wdRelativeVerticalPositionPage
        tbl.Rows.VerticalPosition = InchesToPoints(10.6)
        tbl.Rows.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
        tbl.Rows.HorizontalPosition = InchesToPoints(5.03)
        tbl.Cell(1, 1).Range.Text = “Cleveland” + ChrW(8195) + “|” + ChrW(8195) + “Columbus” + ChrW(8195) + “|” + ChrW(8195) + “Cincinnati” + ChrW(8195) + “|” + ChrW(8195) + “Washington, D.C.”

        Somehow, this is hiding the line (the Shapes collection still shows it exists, so it doesn’t seem to remove the line shape).

        Any ideas would be much appreciated (apologies I don’t know how to format code in this environment)

        Comment by calfeehagesfeldMike Hagesfeld — 10 November 2018 @ 02:39

  4. OK, fixed it. Figured out before I added the table I had to do a rng.Collapse wdCollapseEnd

    Thanks again for your feedback.

    Comment by calfeehagesfeldMike Hagesfeld — 10 November 2018 @ 03:27 | Reply

    • Glad to hear you got it figured out!

      Word and Ranges can be difficult to work with at first but gets easier as you go.

      Comment by snoopen — 16 November 2018 @ 10:27 | Reply


RSS feed for comments on this post. TrackBack URI

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google+ photo

You are commenting using your Google+ account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

Create a free website or blog at WordPress.com.

%d bloggers like this: