Solved

Header Macro Doesn't Insert Image into Sections

Posted on 2011-09-26
36
841 Views
Last Modified: 2013-11-27
Hello,

A while back we developed a macro to add an image to the header of a word document (linked question).  The macro has been working fine, but recently I have been running into an issue where it does not add the image after certain section brakes in Word.  But if I delete the section break and re-add it, then run the macro it will add the image to all pages of the Word document.  

I am generating my Word documents through another program, and when you generate a certain document it will add a section break between two pages.  This is where my macro fails, it will only insert the image into the header for the pages before the section break.  But, if I delete the section break and re-add it, the macro will work fine.  Other documents I generate through the program work fine, so I am confident it has nothing to do with the way the documents are getting generated.  

When the macro fails I do not get any errors, so the syntax is correct.  Please let me know if you need any more information.  I have added the macro and the function it calls below.

Thanks,
Navid
0
Comment
Question by:navid86
  • 18
  • 16
36 Comments
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36600133
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

Open in new window

0
 
LVL 2

Author Comment

by:navid86
ID: 36600144
Okay, that makes sense.  So just add another for loop to encompass the other loop?
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36600189
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)
0
 
LVL 2

Author Comment

by:navid86
ID: 36600298
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

Open in new window

0
 
LVL 76

Accepted Solution

by:
GrahamSkan earned 500 total points
ID: 36600983
Duh! The name isn't unique because it has already used for the previous section. Also I forgot that you need to test the LinkToPrevious property, or it will try more than one to put a picture into any header that is shared between sections. This will prevent picture duplication, and also ensure that the names are unique.

Incidentally, the name can be set in line 15, making the whole of the block 17 to 23 redundant. This new version includes it in the With block.

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
        Debug.Print "sec: " & sec.Index
        For Each hdr In sec.Headers
            Debug.Print "hdr: " & hdr.Index
            If hdr.LinkToPrevious = False 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)
                    .WrapFormat.AllowOverlap = True
                    .WrapFormat.Side = wdWrapNone
                    .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
                    .Left = 10
                    .RelativeVerticalPosition = wdRelativeVerticalPositionPage
                    .Top = 15
                End With
            End If
        Next hdr
    Next sec
End Sub

Open in new window

0
 
LVL 2

Author Comment

by:navid86
ID: 36601108
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
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36601538
I can't reproduce that. Which line does it fail on?
0
 
LVL 2

Author Comment

by:navid86
ID: 36602033
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.
0
 
LVL 2

Author Comment

by:navid86
ID: 36602047
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.
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36890756
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

Open in new window

0
 
LVL 2

Author Comment

by:navid86
ID: 36894217
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
0
 
LVL 2

Author Comment

by:navid86
ID: 36894245
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.  
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36894486
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.
0
 
LVL 2

Author Comment

by:navid86
ID: 36905448
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

Open in new window

0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36906525
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

Open in new window

0
 
LVL 2

Author Comment

by:navid86
ID: 36906781
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.
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36906986
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

Open in new window

0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 2

Author Comment

by:navid86
ID: 36942012
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
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36945693
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

Open in new window

0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36945720
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
0
 
LVL 2

Author Comment

by:navid86
ID: 36948802
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
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36949198
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

Open 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.
0
 
LVL 2

Author Comment

by:navid86
ID: 36949371
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
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36949869
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.
0
 
LVL 2

Author Comment

by:navid86
ID: 36950759
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
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36951318
Could you consider having the logo already in the templates for the mail merge main documents?
0
 
LVL 2

Author Comment

by:navid86
ID: 36955300
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).
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36955457
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?
0
 
LVL 2

Author Comment

by:navid86
ID: 36955605
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.  
0
 
LVL 2

Author Comment

by:navid86
ID: 36956048
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!
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36956344
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)
0
 
LVL 2

Assisted Solution

by:navid86
navid86 earned 0 total points
ID: 36956532
Well, good news it works without the function.  Below is the working code for the solution.  Now, I have to work on the macro to remove the logo.  I will post it on a new question if I need help with it.

As always, you have been a great help!  Thanks for all your help!
Sub LogoAdd()
    Dim sh As Shape
    Dim hdr As HeaderFooter
    Dim rng As Range
    Dim strPicture As String
    Dim sec As Section
    
    strPicture = "\\SERVER\FILE\logo.png"
    For Each sec In ActiveDocument.Sections
        For Each hdr In sec.Headers
            If hdr.LinkToPrevious = False Then
                For Each sh In hdr.Shapes
                    If sh.Type <> msoTextBox Then
                        sh.Delete
                    End If
                Next sh
            End If
        Next hdr
    Next sec
    
    For Each sec In ActiveDocument.Sections
        For Each hdr In sec.Headers
            Dim bUnlinked As Boolean
            Dim bLinked As Boolean
            If sec.Index = 1 Then
                bLinked = False
            Else
                bLinked = hdr.LinkToPrevious
            End If
            bUnlinked = Not bLinked
            If Not bLinked Then
                Set rng = hdr.Range
                rng.Collapse wdCollapseEnd
                Set sh = ActiveDocument.Shapes.AddPicture(strPicture, False, True, 0, 0, , , rng)
                With sh
                    .Name = "Logo" & sec.Index & "_" & CStr(hdr.Index)
                    .WrapFormat.AllowOverlap = True
                    .WrapFormat.Side = wdWrapNone
                    .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
                    .Left = 10
                    .RelativeVerticalPosition = wdRelativeVerticalPositionPage
                    .Top = 15
                End With
            End If
        Next hdr
    Next sec
End Sub

Open in new window

0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 36956543
Good news indeed, and good luck.
0
 
LVL 2

Author Closing Comment

by:navid86
ID: 36978201
My comment/solution was the final code that worked.  The code was developed by the experts solution.
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

If you’re thinking to yourself “That description sounds a lot like two people doing the work that one could accomplish,” you’re not alone.
Although it can be difficult to imagine, someday your child will have a career of his or her own. He or she will likely start a family, buy a home and start having their own children. So, while being a kid is still extremely important, it’s also …
In this fourth video of the Xpdf series, we discuss and demonstrate the PDFinfo utility, which retrieves the contents of a PDF's Info Dictionary, as well as some other information, including the page count. We show how to isolate the page count in a…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

757 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now