Add the document property of Subject to a table in a footer

[Legal Learning]

The table is already in the footer and the built in document property of
Subject needs to be inserted into this 1 row 3 column table in every footer
regardless of how many sections there are in the document. The field needs
to be in the 1st column.

I have the code working to delete anything in that row/column but can not
get it to add without errors.

 

[Jean-Guy Marcil]

Legal Learning was telling us:
Legal Learning nous racontait que :

The table is already in the footer and the built in document property
of Subject needs to be inserted into this 1 row 3 column table in
every footer regardless of how many sections there are in the
document. The field needs to be in the 1st column.

I have the code working to delete anything in that row/column but can
not get it to add without errors.

What errors do you get?

Post the relevant code.

--

Salut!
_______________________________________
Jean-Guy Marcil - Word MVP
(e-mail address removed)
Word MVP site: http://www.word.mvps.org

 

[Legal Learning]

Here is the code. Thanks for your help!

Sub AddFileName()

Dim sSubject As String
Dim pRange As Word.Range

For Each pRange In ActiveDocument.StoryRanges
Do Until (pRange Is Nothing)
Select Case pRange.StoryType
Case wdFirstPageFooterStory, _
wdPrimaryFooterStory, wdEvenPagesFooterStory
On Error Resume Next
pRange.Tables(1).Cell(1, 1).Range.Fields.Add Range:=Selection.Range,
Type:=wdFieldSubject
On Error GoTo 0
Case Else
'Do nothing
End Select
Set pRange = pRange.NextStoryRange
Loop
Next


End Sub

 

[Jean-Guy Marcil]

Legal Learning was telling us:
Legal Learning nous racontait que :

Here is the code. Thanks for your help!

Sub AddFileName()

Dim sSubject As String
Dim pRange As Word.Range

For Each pRange In ActiveDocument.StoryRanges
Do Until (pRange Is Nothing)
Select Case pRange.StoryType
Case wdFirstPageFooterStory, _
wdPrimaryFooterStory, wdEvenPagesFooterStory
On Error Resume Next
pRange.Tables(1).Cell(1, 1).Range.Fields.Add
Range:=Selection.Range, Type:=wdFieldSubject
On Error GoTo 0
Case Else
'Do nothing
End Select
Set pRange = pRange.NextStoryRange
Loop
Next


End Sub

You still did not mention the error you got... But from looking at your
code, I guess it has to do with the following line:

pRange.Tables(1).Cell(1, 1).Range.Fields.Add Range:=Selection.Range,
Type:=wdFieldSubject

The code will add the field at the range represented by the current
selection, not in the first cell of the table as desired.
See the following code for a correction.

'_______________________________________
Sub AddFileName()

Dim sSubject As String
Dim pRange As Word.Range
Dim rgeCell As Range

For Each pRange In ActiveDocument.StoryRanges
Do Until (pRange Is Nothing)
Select Case pRange.StoryType
Case wdFirstPageFooterStory, _
wdPrimaryFooterStory, wdEvenPagesFooterStory
On Error Resume Next
Set rgeCell = pRange.Tables(1).Cell(1, 1).Range
rgeCell.Collapse wdCollapseStart
rgeCell.Fields.Add Range:=rgeCell, Type:=wdFieldSubject
On Error GoTo 0
Case Else
'Do nothing
End Select
Set pRange = pRange.NextStoryRange
Loop
Next

End Sub
'_______________________________________

Why the
On Error Resume Next
line?

It is always better to code for predictable errors than to have a Band-Aid
that will let everything go.
I guess it has to do with the fact that some footers may not have a table.
If this is the case, try this instead:

'_______________________________________
Sub AddFileName()

Dim sSubject As String
Dim pRange As Word.Range
Dim rgeCell As Range

For Each pRange In ActiveDocument.StoryRanges
Do Until (pRange Is Nothing)
Select Case pRange.StoryType
Case wdFirstPageFooterStory, _
wdPrimaryFooterStory, wdEvenPagesFooterStory
If pRange.Tables.Count > 0 Then
Set rgeCell = pRange.Tables(1).Cell(1, 1).Range
rgeCell.Collapse wdCollapseStart
rgeCell.Fields.Add Range:=rgeCell, Type:=wdFieldSubject
End If
Case Else
'Do nothing
End Select
Set pRange = pRange.NextStoryRange
Loop
Next

End Sub
'_______________________________________

--

Salut!
_______________________________________
Jean-Guy Marcil - Word MVP
(e-mail address removed)
Word MVP site: http://www.word.mvps.org

 

[Legal Learning]

Perfect! You rock. Thanks so much.
--
CLG

Legal Learning was telling us:
Legal Learning nous racontait que :


You still did not mention the error you got... But from looking at your
code, I guess it has to do with the following line:

pRange.Tables(1).Cell(1, 1).Range.Fields.Add Range:=Selection.Range,
Type:=wdFieldSubject

The code will add the field at the range represented by the current
selection, not in the first cell of the table as desired.
See the following code for a correction.

'_______________________________________
Sub AddFileName()

Dim sSubject As String
Dim pRange As Word.Range
Dim rgeCell As Range

For Each pRange In ActiveDocument.StoryRanges
Do Until (pRange Is Nothing)
Select Case pRange.StoryType
Case wdFirstPageFooterStory, _
wdPrimaryFooterStory, wdEvenPagesFooterStory
On Error Resume Next
Set rgeCell = pRange.Tables(1).Cell(1, 1).Range
rgeCell.Collapse wdCollapseStart
rgeCell.Fields.Add Range:=rgeCell, Type:=wdFieldSubject
On Error GoTo 0
Case Else
'Do nothing
End Select
Set pRange = pRange.NextStoryRange
Loop
Next

End Sub
'_______________________________________

Why the
On Error Resume Next
line?

It is always better to code for predictable errors than to have a Band-Aid
that will let everything go.
I guess it has to do with the fact that some footers may not have a table.
If this is the case, try this instead:

'_______________________________________
Sub AddFileName()

Dim sSubject As String
Dim pRange As Word.Range
Dim rgeCell As Range

For Each pRange In ActiveDocument.StoryRanges
Do Until (pRange Is Nothing)
Select Case pRange.StoryType
Case wdFirstPageFooterStory, _
wdPrimaryFooterStory, wdEvenPagesFooterStory
If pRange.Tables.Count > 0 Then
Set rgeCell = pRange.Tables(1).Cell(1, 1).Range
rgeCell.Collapse wdCollapseStart
rgeCell.Fields.Add Range:=rgeCell, Type:=wdFieldSubject
End If
Case Else
'Do nothing
End Select
Set pRange = pRange.NextStoryRange
Loop
Next

End Sub
'_______________________________________

--

Salut!
_______________________________________
Jean-Guy Marcil - Word MVP
(e-mail address removed)
Word MVP site: http://www.word.mvps.org