Selecting a WordArt AutoText

[Roderick O'Regan]

I've got an AutoText entry labelled DRAFT which was created in
WordArt.

I need to place this in the document throught all the header stories.
The procedure I've got does this adequately but it seems to place it
in the wrong place - for me, at least. My procedure to delete each
DRAFT works perfectly.

Then I got the idea if it was selected it could be moved to where I
want to set it. The code between the **** illustrated what I've tried
to do. However, without any results

This is the code:
Application.ScreenUpdating = False
'Fix the skipped blank Header/Footer problem
xJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
'Iterate through all story types in the current document
For Each xStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
On Error Resume Next
Select Case xStory.StoryType
Case wdEvenPagesHeaderStory, wdFirstPageHeaderStory,
wdPrimaryHeaderStory
'first deletes the DRAFT in the headers to prevent layering
'if user presses DRAFT a second time
If xStory.ShapeRange.Count > 0 Then
For Each xShp In rngStory.ShapeRange
'calls the Delete DRAFT procedure
DeleteDraft
Next
End If
'now puts DRAFT in each header
Set xRange = xStory
xRange.Collapse Direction:=wdCollapseStart
ActiveDocument.AttachedTemplate.AutoTextEntries("Draft").Insert _
Where:=xRange, RichText:=True
************************************
For Each xShp In rngStory.ShapeRange
If xShp.Type = msoTextEffect Then
xShp.RelativeHorizontalPosition =
wdRelativeHorizontalPositionPage
xShp.RelativeVerticalPosition =
wdRelativeVerticalPositionPage
xShp.Left = CentimetersToPoints(6)
xShp.Top = CentimetersToPoints(13)
End If
***********************************
Next
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set xStory = xStory.NextStoryRange
Loop Until xStory Is Nothing
Next
'go back to the top of the document
ActiveDocument.Bookmarks("\StartofDoc").Select

Application.ScreenUpdating = True

Can anyone help with this challenge I've got, please?

Roderick

 

[Russ]

Roderick,
Another idea to kick around is that linktoprevious is true by default.
If you want the autotext on all pages to begin with, just place it in a
table, whose borders are hidden to 'anchor' it in the first header or
footer.

 

[Roderick O'Regan]

Thanks for the idea Russ.

In this case it is not that easy as there are different headers and
footers and there are new sections with landscape pages added.

In this situation there is already a table in the headers which has to
be manipulated to stretch across the new page.

What I cannot understand is why this piece of code quite successfully
finds the WordArt shape:
For Each xShp In rngStory.ShapeRange'Delete the shape code goes here
....then deletes it. I would have thought, therefore, that this next
snippet would have the same effect but placing it where I want:

 

[Russ]

Roderick,
Are using Option Explicit?
I don't see where rngStory is declared.
You Set xRange = xStory, but don't use it to find and move your object.

I've got an AutoText entry labelled DRAFT which was created in
WordArt.

I need to place this in the document throught all the header stories.
The procedure I've got does this adequately but it seems to place it
in the wrong place - for me, at least. My procedure to delete each
DRAFT works perfectly.

Then I got the idea if it was selected it could be moved to where I
want to set it. The code between the **** illustrated what I've tried
to do. However, without any results

This is the code:
Application.ScreenUpdating = False
'Fix the skipped blank Header/Footer problem
xJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
'Iterate through all story types in the current document
For Each xStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
On Error Resume Next
Select Case xStory.StoryType
Case wdEvenPagesHeaderStory, wdFirstPageHeaderStory,
wdPrimaryHeaderStory
'first deletes the DRAFT in the headers to prevent layering
'if user presses DRAFT a second time
If xStory.ShapeRange.Count > 0 Then
For Each xShp In rngStory.ShapeRange

rngStory? Not declared.

 

[Roderick O'Regan]

I've given up chasing my tail on this one and now taking a different
tack.
i'm going to go down the Sections route amd say something like:
Go to the top of the document
Look at the first section's header
iterate through all the shapes in the first section and see if there
is a WordArtShape.
If there is then move it
Go to the next section's header
Repeat the search for shapes
Iterate through all sections.

My first effort in writing the procedure is set out below but when I
run it, it goes into an endless loop.

Dim oShp As Shape
Dim rngSection As Word.Section

ActiveDocument.Bookmarks("\StartofDoc").Select

'Iterate through each section in the current document
For Each rngSection In ActiveDocument.Range.Sections
Do
On Error Resume Next
For Each oShp In rngSection.Headers(1)
If oShp.Type = msoTextEffect Then
If ActiveDocument.PageSetup.Orientation =
wdOrientPortrait Then
With oShp
.RelativeHorizontalPosition =
wdRelativeHorizontalPositionPage
.Left = CentimetersToPoints(2)
.RelativeVerticalPosition =
wdRelativeVerticalPositionPage
.Top = CentimetersToPoints(11)
End With
Else
With oShp
.RelativeHorizontalPosition =
wdRelativeHorizontalPositionPage
.Left = CentimetersToPoints(5)
.RelativeVerticalPosition =
wdRelativeVerticalPositionPage
.Top = CentimetersToPoints(9)
End With
End If
End If
Next
Loop Until rngSection Is Nothing
Next


Roderick

 

[Russ]

Looks like you go to first section and loop until rngsection is nothing,
which it never is nothing, because the next-rngsection code is out side the
loop-until-nothing code and it never gets a chance to move to next section.

 

[Russ]

There's an old saying for programmers:
The computer tries to do what you tell it to do, not necessarily what you
intended it to do.

You are already telling it to go through each section with the for each
code. You probably don't need the loop until sections nothing.