TheAntiGates
02-26-2005, 04:20 PM
I acknowledge great lameness in the [normal.dot] code below and would appreciate y'all giving it a try - if only to tell me that it's totally demented and a more sane solution is available.
Sorry for the width. I truly worked hard to squeeze it for this post. Also note that the HTM VBA parser inserted 2 or 3 blank spaces in the middle of several keywords in the code:p Sub pmFooterInsertCurrentDocument()
'Inserts a footer in each section in active document, including the complete path.
Dim iMsgboxResponse As Integer, iBeenPromptedCount As Integer
Dim bAlwaysOverwrite As Boolean,fFoo As Single,i As Integer,sstr As String
'This is no rant. Removing the Gates vars. causes this to fail. Help?
Dim rngKILLGates As Range,GatesSUCKS1 As Field,GatesSUCKS2 As Field,GatesSUCKS3 As Field
iBeenPromptedCount = 0: bAlwaysOverwrite = False
CARR_RET = Chr(10) ' & Chr(13) unnecessary
With ActiveDocument.PageSetup
'with "points" (1/72 inch?), footer always takes .2" margin, so consider its excess;
'Bottom margin should leave .4" to fit our 2-line-footer, for typical font anyway
fFoo = .FooterDistance - Application.InchesToPoints(0.2)
If .BottomMargin - IIf(fFoo > 0, fFoo, 0) < Application.InchesToPoints(0.4) Then
MsgBox "Note-tight squeeze for footer at bottom of page...continuing anyway:" _
, , "Check bottom of page clearance on tab '" & ActiveDocument.Name & "'"
End If
iMsgboxResponse = vbYes ' Deem agreement if there is no msgbox to be presented !!
For i = ActiveDocument.Sections.Count To 1 Step -1
sstr = ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range.Text _
& ActiveDocument.Sections(i).Footers(wdHeaderFooterPrimary).Range.Text
If (sstr <> "") And (sstr <> (vbCr & vbCr)) Then
If iBeenPromptedCount = 1 Then
iMsgboxResponse=MsgBox("Yet another header or footer already exists." _
& CARR_RET & CARR_RET _
& "Do you want to OVERWRITE..ALL..existing footers,without being asked again?", _
vbYesNo + vbDefaultButton2)
If iMsgboxResponse = vbYes Then bAlwaysOverwrite = True
End If
iBeenPromptedCount = iBeenPromptedCount + 1
If Not bAlwaysOverwrite Then
iMsgboxResponse = _
MsgBox("Header(s) and/or footer(s) already exist(s). Please pick one:" _
& CARR_RET & CARR_RET _
& "Yes to OVERWRITE this section's footer;" & CARR_RET _
& "No or Enter key to skip THIS section and continue," & CARR_RET _
& "Cancel or Escape key to abort all now?", _
vbYesNoCancel + vbDefaultButton2, _
"Already has header or footer in tab '" & ActiveDocument.Name & "'")
End If
If iMsgboxResponse = vbCancel Then _
Application.StatusBar = "Footers cancelled": Exit Sub
End If
If iMsgboxResponse = vbYes Then
'This is no rant. Removing the Gates vars. causes this to fail. Help?
Set rngKILLGates = Selection.Range
Set GatesSUCKS1=ActiveDocument.Fields.Add(Range:=Selection.Range,Type:=wdFieldP age)
Set GatesSUCKS2=ActiveDocument.Fields.Add(Range:=Selection.Range,Type:=wdFieldD ate)
Set GatesSUCKS3=ActiveDocument.Fields.Add(Range:=Selection.Range,Type:=wdFieldT ime)
ActiveDocument.Sections(i).Footers(wdHeaderFooterPrimary).Range.Text = _
"Page " & GatesSUCKS1.Result.Text & " of " & _
ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) & _
"; printed: " & " DATE " & " " & GatesSUCKS3.Result.Text _
& CARR_RET & "(by " & ActiveDocument.BuiltInDocumentProperties _
(wdPropertyLastAuthor) & " in " & ActiveDocument.FullName _
& " on " & Date & ")"
'ActiveDocument.Sections(i).Footers(wdHeaderFooterPrimary).Range.Text= _
"NO! Not updated"
On Error Resume Next
GatesSUCKS1.Delete: GatesSUCKS2.Delete: GatesSUCKS3.Delete
On Error GoTo 0
'This adds a right-aligned page number to the primary footer _
in the section "i" in the active document.
'ActiveDocument.Sections(i).Footers(wdHeaderFooterPrimary).PageNumbers.Add _
' PageNumberAlignment:=wdAlignPageNumberLeft
End If
Next i
End With
End Sub
Sorry for the width. I truly worked hard to squeeze it for this post. Also note that the HTM VBA parser inserted 2 or 3 blank spaces in the middle of several keywords in the code:p Sub pmFooterInsertCurrentDocument()
'Inserts a footer in each section in active document, including the complete path.
Dim iMsgboxResponse As Integer, iBeenPromptedCount As Integer
Dim bAlwaysOverwrite As Boolean,fFoo As Single,i As Integer,sstr As String
'This is no rant. Removing the Gates vars. causes this to fail. Help?
Dim rngKILLGates As Range,GatesSUCKS1 As Field,GatesSUCKS2 As Field,GatesSUCKS3 As Field
iBeenPromptedCount = 0: bAlwaysOverwrite = False
CARR_RET = Chr(10) ' & Chr(13) unnecessary
With ActiveDocument.PageSetup
'with "points" (1/72 inch?), footer always takes .2" margin, so consider its excess;
'Bottom margin should leave .4" to fit our 2-line-footer, for typical font anyway
fFoo = .FooterDistance - Application.InchesToPoints(0.2)
If .BottomMargin - IIf(fFoo > 0, fFoo, 0) < Application.InchesToPoints(0.4) Then
MsgBox "Note-tight squeeze for footer at bottom of page...continuing anyway:" _
, , "Check bottom of page clearance on tab '" & ActiveDocument.Name & "'"
End If
iMsgboxResponse = vbYes ' Deem agreement if there is no msgbox to be presented !!
For i = ActiveDocument.Sections.Count To 1 Step -1
sstr = ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range.Text _
& ActiveDocument.Sections(i).Footers(wdHeaderFooterPrimary).Range.Text
If (sstr <> "") And (sstr <> (vbCr & vbCr)) Then
If iBeenPromptedCount = 1 Then
iMsgboxResponse=MsgBox("Yet another header or footer already exists." _
& CARR_RET & CARR_RET _
& "Do you want to OVERWRITE..ALL..existing footers,without being asked again?", _
vbYesNo + vbDefaultButton2)
If iMsgboxResponse = vbYes Then bAlwaysOverwrite = True
End If
iBeenPromptedCount = iBeenPromptedCount + 1
If Not bAlwaysOverwrite Then
iMsgboxResponse = _
MsgBox("Header(s) and/or footer(s) already exist(s). Please pick one:" _
& CARR_RET & CARR_RET _
& "Yes to OVERWRITE this section's footer;" & CARR_RET _
& "No or Enter key to skip THIS section and continue," & CARR_RET _
& "Cancel or Escape key to abort all now?", _
vbYesNoCancel + vbDefaultButton2, _
"Already has header or footer in tab '" & ActiveDocument.Name & "'")
End If
If iMsgboxResponse = vbCancel Then _
Application.StatusBar = "Footers cancelled": Exit Sub
End If
If iMsgboxResponse = vbYes Then
'This is no rant. Removing the Gates vars. causes this to fail. Help?
Set rngKILLGates = Selection.Range
Set GatesSUCKS1=ActiveDocument.Fields.Add(Range:=Selection.Range,Type:=wdFieldP age)
Set GatesSUCKS2=ActiveDocument.Fields.Add(Range:=Selection.Range,Type:=wdFieldD ate)
Set GatesSUCKS3=ActiveDocument.Fields.Add(Range:=Selection.Range,Type:=wdFieldT ime)
ActiveDocument.Sections(i).Footers(wdHeaderFooterPrimary).Range.Text = _
"Page " & GatesSUCKS1.Result.Text & " of " & _
ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) & _
"; printed: " & " DATE " & " " & GatesSUCKS3.Result.Text _
& CARR_RET & "(by " & ActiveDocument.BuiltInDocumentProperties _
(wdPropertyLastAuthor) & " in " & ActiveDocument.FullName _
& " on " & Date & ")"
'ActiveDocument.Sections(i).Footers(wdHeaderFooterPrimary).Range.Text= _
"NO! Not updated"
On Error Resume Next
GatesSUCKS1.Delete: GatesSUCKS2.Delete: GatesSUCKS3.Delete
On Error GoTo 0
'This adds a right-aligned page number to the primary footer _
in the section "i" in the active document.
'ActiveDocument.Sections(i).Footers(wdHeaderFooterPrimary).PageNumbers.Add _
' PageNumberAlignment:=wdAlignPageNumberLeft
End If
Next i
End With
End Sub