Solved

# Header Macro Doesn't Insert Image into Sections

Posted on 2011-09-26
Medium Priority
878 Views
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
Question by:navid86
[X]
###### Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

• Help others & share knowledge
• Earn cash & points
• 18
• 16

LVL 76

Expert Comment

ID: 36600133
Yes it only works for Section  by design:

You need to step through each section
Sub LogoAdd()
'...
Dim sec as Section
'...
For each sec in ActiveDocument.Sections
'...

End With
Next hdr
Next sec
End Sub

0

LVL 2

Author Comment

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

LVL 76

Expert Comment

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

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 rng As Range
Dim strPicture As String
Dim sec As Section

strPicture = "\\SERVER\Logo.png"
For Each sec In ActiveDocument.Sections

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

0

LVL 76

Accepted Solution

GrahamSkan earned 2000 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 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
Debug.Print "hdr: " & hdr.Index
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

0

LVL 2

Author Comment

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

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

LVL 2

Author Comment

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

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

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 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, _
Debug.Print "hdr: " & hdr.Index
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
For Each sec In ActiveDocument.Sections
Debug.Print "sec: " & sec.Index, "FP: ", sec.PageSetup.DifferentFirstPageHeaderFooter, _
Debug.Print "hdr: " & hdr.Index
If sec.Index = 1 Then
Else
End If
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

0

LVL 2

Author Comment

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

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

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

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 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 wdPrimaryFooterStory
Case wdFirstPageFooterStory
Case wdEvenPagesFooterStory
Case Else
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

'range. Set up a new paragraph to overwrite before adding the canvas
'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
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

0

LVL 76

Expert Comment

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 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, _
Debug.Print "hdr: " & hdr.Index
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
For Each sec In ActiveDocument.Sections
Debug.Print "sec: " & sec.Index, "FP: ", sec.PageSetup.DifferentFirstPageHeaderFooter, _
Debug.Print "hdr: " & hdr.Index
If sec.Index = 1 Then
Else
End If
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

0

LVL 2

Author Comment

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):

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

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

Dim sh As Shape
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 & _
Writelog "hdr: " & hdr.Index
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
For Each sec In ActiveDocument.Sections
Writelog "sec: " & sec.Index & ", FP: " & sec.PageSetup.DifferentFirstPageHeaderFooter & _
Writelog "hdr: " & hdr.Index
If sec.Index = 1 Then
Else
End If
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

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 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 wdPrimaryFooterStory
Case wdFirstPageFooterStory
Case wdEvenPagesFooterStory
Case Else
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

'range. Set up a new paragraph to overwrite before adding the canvas
'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
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

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

0

LVL 2

Author Comment

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.

shp11283.log
0

LVL 76

Expert Comment

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 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 wdPrimaryFooterStory
Case wdFirstPageFooterStory
Case wdEvenPagesFooterStory
Case Else
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

'range. Set up a new paragraph to overwrite before adding the canvas
'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
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
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

0

LVL 76

Expert Comment

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?
0

LVL 2

Author Comment

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

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:

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 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 wdPrimaryFooterStory
Case wdFirstPageFooterStory
Case wdEvenPagesFooterStory
Case Else
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

'range. Set up a new paragraph to overwrite before adding the canvas
'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
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
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


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

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

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

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

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

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

LVL 2

Author Comment

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

ID: 36955457

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

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

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

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

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 rng As Range
Dim strPicture As String
Dim sec As Section

strPicture = "\\SERVER\FILE\logo.png"
For Each sec In ActiveDocument.Sections
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
If sec.Index = 1 Then
Else
End If
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

0

LVL 76

Expert Comment

ID: 36956543
Good news indeed, and good luck.
0

LVL 2

Author Closing Comment

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

## Featured Post

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

After seeing numerous questions for Dynamic Data Validation I notice that most have used Visual Basic to solve the problem. This suggestion is purely formula based and can be used in multiple rows.
New style of hardware planning for Microsoft Exchange server.
With the power of JIRA, there's an unlimited number of ways you can customize it, use it and benefit from it. With that in mind, there's bound to be things that I wasn't able to cover in this course. With this summary we'll look at some places to go…
Add bar graphs to Access queries using Unicode block characters. Graphs appear on every record in the color you want. Give life to numbers. Hopes this gives you ideas on visualizing your data in new ways ~ Create a calculated field in a query: …
###### Suggested Courses
Course of the Month14 days, 6 hours left to enroll