Solved: Using VBA to Insert Custom DocProperty in Footer

[Dr@gonfly]

Situation: I am working on 117 templates that require the insertion of a custom DocProperty field in each section footer but the section page numbers and Form numbers (plain text) are already present. I would link all the footers insert once and unlink but that would wipe out all of my form numbers and by law they must be there, and they must match. Some of the templates have 100 forms (endorsements, really, since I work for insurance). Here's the catch, we are working with a utility called ActiveDocs. From what it will let me see of the program, it is basically a proprietary VB script writer for the non-VBA inclined user. Mostly they market to lawyers, insurance, etc where programming skills in any form tend to be absent. Therefore, any solutions involving a word userform cannot be implemented. The program will not allow it. My other option (if I cannot find this solution) is to have four people manually insert the DocProperty into every section footer. I sure hope someone can help me!:bow:

I've read a couple posts and some have had pieces of what I am looking for but none of my combinations of the code seems to do what I want. Here's what I am trying to accomplish.
VBA that:

Opens each section footer
Leaves the current table (the page numbers are in a table) and lines of text (Form number), finding the very last paragraph marker
Enters another line
Inserts the customer DocProperty ("NYFTZ")
Loops through all the footers until the end of the document
Here's what the recorded macro looks like in case my description was not clear:
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
If Selection.HeaderFooter.IsHeader = True Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Else
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
End If
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"DOCPROPERTY NYFTZ ", PreserveFormatting:=True
End Sub

mdmackillop wrote an answer to another forum question which seems to address this issue in part:
Sub AddAuthorToFooter()
ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text _
= ActiveDocument.BuiltInDocumentProperties("Author")
End Sub

I also have this code that I originally used from Greg Maxey's site to delete an unwanted field, I use its shell to cycle through all the footers in the document:
Sub AddDocPropFooter()
Dim oField As Field
Dim oSection As Section
Dim oFooter As HeaderFooter
For Each oSection In ActiveDocument.Sections
For Each oFooter In oSection.Footers
If oFooter.Exists Then
For Each oField In oFooter.Range.Fields
If oField.Type = wdFieldFileName Then
oField.delete
End If
Next oField
End If
Next oFooter
Next oSection
End Sub

The problem is, no matter how hard I try to marry them into one cohesive routine, it just bugs at every turn!:banghead:

Any help would be so appreciated!:dunno

[Tinbendr]

Try this:


Sub AddDocPropFooter()
Dim oField As Field
Dim oSection As Section
Dim oFooter As HeaderFooter
For Each oSection In ActiveDocument.Sections
For Each oFooter In oSection.Footers
If oFooter.Exists Then
oFooter.Range.Collapse wdCollapseEnd
oFooter.Range.InsertAfter ActiveDocument.CustomDocumentProperties("NYFTZ")
End If
Next oFooter
Next oSection
End Sub

[fionabolt]

Or here is some code that I wrote for a similar conundrum. You may have to tweak it a bit.

Option Explicit
Sub AddCDPtoEachFooter()
Dim SS As String
Dim docName As String
Dim dp
Dim NothingInTheFooter As Boolean
For Each dp In ActiveDocument.CustomDocumentProperties
If dp.Name = "CDP" Then
SS = ActiveDocument.CustomDocumentProperties("CDP")
End If
Next dp
docName = ActiveDocument.Name

footersagain:
If Not FoundStoryRange(docName, wdEvenPagesFooterStory, SS) Then
NothingInTheFooter = True
Else: NothingInTheFooter = False
End If
If Not FoundStoryRange(docName, wdFirstPageFooterStory, SS) Then
Else: NothingInTheFooter = False
End If
If Not FoundStoryRange(docName, wdPrimaryFooterStory, SS) Then
Else: NothingInTheFooter = False
End If

If NothingInTheFooter = True Then
'there is nothing in the footer, need to have at least a carriage return so
'insert something to the footer so foundstoryrange works
ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text = vbCr
GoTo footersagain
End If

End Sub
Function FoundStoryRange(FN As String, FooterType, DocProp As String) As Boolean
Dim INX As Long
Dim rngStoryRange As Range
Dim rngInsertHere As Range
Dim NothingInTheFooter As Boolean
Dim rng As Word.Range 'working range
Dim pFooter As Word.Range
Dim posRng As Single
Dim SS 'working var
Dim VV 'working var
Dim oj As Object
Rem--set-up----------------------------------------------------------
FoundStoryRange = False
On Error GoTo errHandler
Rem--set the range as the storyrange
Set pFooter = ActiveDocument.StoryRanges(FooterType)
' SS = ActiveDocument.StoryRanges(wdPrimaryFooterStory).PageSetup.Orientation
Do
INX = INX + 1
Set rngInsertHere = pFooter
Set rng = pFooter
rngInsertHere.SetRange Start:=rngInsertHere.Start, End:=rngInsertHere.End
rng.SetRange Start:=rng.Start, End:=rng.End
If Len(rngInsertHere) > 1 Then 'the string contains something
SS = InStr(1, rngInsertHere, Chr(13)) 'position of the first car return
VV = Len(rngInsertHere) 'length of the string
If SS < VV Then
'there are two car returns, don;t add another
ElseIf SS = VV Then
'there is only one carr return, add another
rngInsertHere.InsertAfter Chr(13) 'insert a carriage return
End If
End If
rng.Collapse Direction:=wdCollapseEnd
ActiveDocument.Bookmarks.Add Name:="bkmname" & INX, Range:=rng 'add a bookmark here
' rng.SetRange Start:=rng.End + 2, End:=rng.End + 2 'move the range to the end of the range
rng.InsertAfter Chr(13) & DocProp
LEmptyFooter:
Set pFooter = pFooter.NextStoryRange 'move to the next story of the same footer type
Loop Until pFooter Is Nothing

FoundStoryRange = True

Exit Function
errHandler:
Select Case Err.Number
Case 5941 'there is no footer don't worry, move to the next one
Exit Function
' GoTo LEmptyFooter
Case Else
MsgBox "Error Number " & Err.Number & vbCr _
& "Source: " & vbCr & Err.Description, vbCritical, "VBA Error"
End Select
End Function

[fumei]

Careful with this:

If oFooter.Exists Then


Exists in this case only means if that footer type (DiffererentFirstPage, DifferentOddEven) is checked under Page Setup.

1. Primary will always return .Exists as True. It can NEVER be False.

2. Even if DiffererentFirstPage, DifferentOddEven return .Exists as False, the footers themselves still DO exist (they always exist), and may contain content.

Again, .Exists (in the context fo headerfooters) ONLY returns the state of that headerfooter under Page Setup.

If it is checked (ON) , then .Exists = True
If it is unchecked (OFF) then .Exists = False

The actual headerfooter objects always exist. Always. They can NOT be removed or deleted.

Dr@gonfly, Tinbendr's code should work, although as you seem to need a new paragraph, I would add that, as in:oFooter.Range.InsertAfter _
vbCrLf & ActiveDocument.CustomDocumentProperties("NYFTZ") I am not totally clear as to whether you are trying to get the DocProperty in the table, or outside the table.

[fumei]

fionabolt, interesting, but it seems a bit excessive. It is also not quite accurate.

You have NothingInFooter and this is where Word gets sneaky.

Say you make a brand new document. You do NOTHING at all to it. DifferentFirstPage is OFF (unchecked in Page Setup). If you run:

MsgBox Asc(ActiveDocument.Sections(1) _
.Footers(wdHeaderFooterFirstPage).Range.Text)

What do you get? 13

The ASCII character of the DifferentFirstPage footer range text- even though it does not ".Exist", and even though nothing has been put in it - is Chr(13).

[Dr@gonfly]

Fumei,
Sorry about the lateness of the response. I was trying to insert it as the last line of the footer, which would be after the table and the form number. So the Footer has a table, a line of text, and <hopefully> the document property field last. Thank you everyone for responding. I've just gotten in and will start testing the code. I will let everyone know what I find! Thank you so much for the help! :cloud9:

[Dr@gonfly]

Fumei,
Sorry about the lateness of the response. I was trying to insert it as the last line of the footer, which would be after the table and the form number. So the Footer has a table, a line of text, and <hopefully> the document property field last. Thank you everyone for responding. I've just gotten in and will start testing the code. I will let everyone know what I find! Thank you so much for the help! :cloud9:

I tested this using the modification suggested by Fumei and it adds the line for the field as desired (thank you Fumei) however, it doesn't insert the docproperty???? Perhaps I misunderstood the directions. Here's what I have:
Sub AddDocPropFooter()
Dim oField As Field
Dim oSection As Section
Dim oFooter As HeaderFooter
For Each oSection In ActiveDocument.Sections
For Each oFooter In oSection.Footers
If oFooter.Exists Then
oFooter.Range.Collapse wdCollapseEnd
oFooter.Range.InsertAfter vbCrLf & ActiveDocument.CustomDocumentProperties("NYFTZ")
End If
Next oFooter
Next oSection
End Sub

[Tinbendr]

I assume you're loading the value into the doc property... correct?

Add a test to see what that value is inside the routine.


Sub AddDocPropFooter()
Dim oField As Field
Dim oSection As Section
Dim oFooter As HeaderFooter
For Each oSection In ActiveDocument.Sections
For Each oFooter In oSection.Footers
If oFooter.Exists Then
oFooter.Range.Collapse wdCollapseEnd
'Add a test to see if NYFTZ actually contains your data
MsgBox ActiveDocument.CustomDocumentProperties("NYFTZ")
oFooter.Range.InsertAfter vbCrLf & ActiveDocument.CustomDocumentProperties("NYFTZ")
End If
Next oFooter
Next oSection
End Sub

[Dr@gonfly]

TinBendr,

The way the program is set up, the docproperty value is being supplied by the Add-In "ActiveDocs". However, ActiveDocs is only coded to be used within the main document story so they allow you to record "ActiveFields" (which are in my mind are locked down form fields) as "DocProperties". The information is pulled through an ODBC into the ActiveDocs user interface and populated using the "ActiveFields" (which when they are marked as "Document Property" populate in the DocProperty information).

We may be two ships passing in the night but when I read that code, it seems that you are looking for a value within the field, my problem is that when I try to toggle the field code in the footer of the field that I just inserted, there is no field? I need that field to be there in case there is a value that needs to be displayed. By setting the default to nothing, if there is no value, the filed remains blank and the final product shows nothing. Since the presence of the information is variable, I need this functionality. Once this template is loaded into the enterprise system, I will no longer be able to call macros, therefore, I need the field to be hard-coded into the footer.

Is this possible?

[Tinbendr]

OIC...

Try this.


Sub AddDocPropFooter()
Dim oField As Field
Dim oSection As Section
Dim oFooter As HeaderFooter
For Each oSection In ActiveDocument.Sections
For Each oFooter In oSection.Footers
If oFooter.Exists Then
oFooter.Range.Collapse wdCollapseEnd
ActiveDocument.Fields.Add Range:=oFooter.Range, Type:=wdFieldDocProperty, _
Text:=Chr(34) & "NYFTZ" & Chr(34), _
PreserveFormatting:=True
End If
Next oFooter
Next oSection
End Sub

[Dr@gonfly]

OIC...

Try this.


Sub AddDocPropFooter()
Dim oField As Field
Dim oSection As Section
Dim oFooter As HeaderFooter
For Each oSection In ActiveDocument.Sections
For Each oFooter In oSection.Footers
If oFooter.Exists Then
oFooter.Range.Collapse wdCollapseEnd
ActiveDocument.Fields.Add Range:=oFooter.Range, Type:=wdFieldDocProperty, _
Text:=Chr(34) & "NYFTZ" & Chr(34), _
PreserveFormatting:=True
End If
Next oFooter
Next oSection
End Sub


Question: I am looking at the result and the routine clears the footers of the numbering the text when you use it. I need to keep that information otherwise, I will have to manually re-enter all the form numbers in the section footers and the VBA doesn't help me at all

Question, the new field takes on the formatting of the "DRAFT" indicators (Screen shot) that are red and bolded. I am not sure if that is because they too, are DocProperties. Is there anyway to make sure that the field's properties are set to "Normal" I just need them to be black and Garamond, font 10 like the "Normal" style used in the body of the document.

Thank you so much! All four of us will be singing your praises from NY!

[fumei]

Please use the underscore character for long code lines.

Thanks.

Other comments/questions.

Why is a Field object declared, but never used?
Does your footer field need to be updated?

[Dr@gonfly]

Please use the underscore character for long code lines.

Thanks.

Other comments/questions.

Why is a Field object declared, but never used?
Does your footer field need to be updated?

The original bit that cycles through the footers was to find a FilePathName. I must have mistakenly left it in there. I can delete it.

Sorry about the underscore.:(

When you say updated, the information is going to populate in the template and the next step in enterprise will print the document to PDF. Each time a template is created, the information will be pulled through the template and fields. I won't need to update the field in the dot once there is an instance of it in each section. Does that make sense?

[Tinbendr]

Fixed the erasing the whole footer, but cannot get font/size to work out.

After inserting the field, I cannot determine how to get the field in a object. I'm sure it's simple, but it escapes me just now. :banghead:

Anyway, here's the code.


Sub AddDocPropFooter()
Dim oField As Field
Dim oSection As Section
Dim oFooter As HeaderFooter
Dim MyFt As CustomProperties
For Each oSection In ActiveDocument.Sections
For Each oFooter In oSection.Footers
oFooter.Range.Select
Selection.Collapse wdCollapseEnd
oFooter.Range.Fields.Add Range:=Selection.Range _
, Type:=wdFieldDocProperty, _
Text:=Chr(34) & "NYFTZ" & Chr(34), _
PreserveFormatting:=True
Next oFooter
Next oSection
End Sub

[Dr@gonfly]

Fixed the erasing the whole footer, but cannot get font/size to work out.

After inserting the field, I cannot determine how to get the field in a object. I'm sure it's simple, but it escapes me just now. :banghead:

Anyway, here's the code.


Sub AddDocPropFooter()
Dim oField As Field
Dim oSection As Section
Dim oFooter As HeaderFooter
Dim MyFt As CustomProperties
For Each oSection In ActiveDocument.Sections
For Each oFooter In oSection.Footers
oFooter.Range.Select
Selection.Collapse wdCollapseEnd
oFooter.Range.Fields.Add Range:=Selection.Range _
, Type:=wdFieldDocProperty, _
Text:=Chr(34) & "NYFTZ" & Chr(34), _
PreserveFormatting:=True
Next oFooter
Next oSection
End Sub


Thank you for your help, Tinbendr! I am going to try this out tomorrow. I was having trouble on the code for the font too... I am working on itm just a start.. I'll post it here if I can get it to work!:bug:

[Dr@gonfly]

I had an AHA moment because of Tinbendr's code. Here's what I've come up with:

Sub AddDocPropFooter()
Dim oField As Field
Dim oSection As Section
Dim oFooter As HeaderFooter
Dim MyFt As CustomProperties
For Each oSection In ActiveDocument.Sections
For Each oFooter In oSection.Footers
oFooter.Range.Select
Selection.Collapse wdCollapseEnd
oFooter.Range.InsertAfter vbCrLf
oFooter.Range.Select
Selection.Collapse wdCollapseEnd
oFooter.Range.Fields.Add Range:=Selection.Range _
, Type:=wdFieldDocProperty, _
Text:=Chr(34) & "NYFTZ" & Chr(34), _
PreserveFormatting:=True
Next oFooter
Next oSection
End Sub


It seems to work. I tested it and was successful. I never did address font and color but in this case the text is the correct font and color (where the new line is added) and because the new line inherits the attributes of the old line, it works for my purposes....

THANK YOU SO MUCH FROM ALL OF US!

[fumei]

Ahem......use Styles.

[Dr@gonfly]

Fumei,

In unlinked footers, how do you apply Styles? I couldn't figure out how to call the Styles in the macro.

If we had to go into each footer and apply a Style that would take considerable time and effort, versus, say having the Style applied as part of the macro. I think that even though my code works well, others might benefit from having the Style in the macro.

Did you have something specific in mind?:thumb

[fumei]

Styles are applied. I do not know what you mean how do you apply Styles?

While I do not like to use Selection...and you are using Selection...
For Each oFooter In oSection.Footers
oFooter.Range.Select
Selection.Collapse wdCollapseEnd
oFooter.Range.InsertAfter vbCrLf
oFooter.Range.Select
Selection.Collapse wdCollapseEnd
Selection.Style = "FooterStuffYadda"
oFooter.Range.Fields.Add Range:=Selection.Range _
, Type:=wdFieldDocProperty, _
Text:=Chr(34) & "NYFTZ" & Chr(34), _
PreserveFormatting:=True
Next oFooter
from that point the style will be FooterStuffYadda.....assuming you have made a FooterStuffYadda.

As far as I am concerned, there should not be a single scrap of text anywhere in a document that does not have an explicit style - NOT Normal - attached to it.

You can multiple styles within a footer, Word does not care. Styles are attached to paragraphs. So if you have one, or two, paragraphs (i.e. your table) with FooterStuffMainCrap style, and then the DocProperty with FooterStuffYadda style, Word will quite happily do exactly that.