VBA - Snippets

Message_ShapeDoesNotExistInHeaderFooter

Public Sub Message_ShapeDoesNotExistInHeaderFooter( _
         ByVal sShapeName As String)
Dim sMessage As String
    sMessage = "The shape '" & sShapeName & "' does not exist in the header/footer"
    Call MsgBox(sMessage, vbOKOnly + vbInformation, g_sCOMPANYNAME & " (" & g_sVERSION & ") - " & "Shape Not Found")
    Call Tracer_Add("MESSAGE", sMessage)
End Sub

Section_Delete

Removes a particular section from the active document.

Public Sub Section_Delete()
Const sPROCNAME As String = "Section_Delete"
   On Error GoTo AnError


   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "")
End Sub

Section_FooterAdd

Adds a footer to the current section.

Public Sub Section_FooterAdd(sText As String, _
                             Optional sFooterType As String = "PRIMARY")
Const sPROCNAME As String = "Section_FooterAdd"
   On Error GoTo AnError
   
'activewindow.activepane.view.seekview = wdseekcurrentpageheaderfooter
   With ActiveDocument.Sections(1)
      If sFooterType = "PRIMARY" Then .Headers(wdHeaderFooterPrimary).Range.Text = sText
      If sFooterType = "FIRST" Then .Headers(wdHeaderFooterPrimary).Range.Text = sText
      If sFooterType = "ODD" Then .Headers(wdHeaderFooterPrimary).Range.Text = sText
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "add a footer to the current section of the document")
End Sub

Section_FooterEmptyIsIt

Determines if the footer of the current section is empty.

Public Function Section_FooterEmptyIsIt() As Boolean
Const sPROCNAME As String = "Section_FooterEmptyIsIt"

   On Error GoTo AnError
   If ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text <> vbCr Then
      Section_FooterEmptyIsIt = True
   Else
      Section_FooterEmptyIsIt = False
   End If
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "determine if the footer of the current section is empty")
End Function

Section_FooterFieldsAny

Determines if there are any fields in the footer for the current section.

Public Function Section_FooterFieldsAny() As Boolean
Const sPROCNAME As String = "Section_FooterFieldsAny"
   On Error GoTo AnError


   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "determine if there are any fields in the footer for the current section")
End Sub

Section_FooterFindTab

Public Function Section_FooterFindTab( _
         ByVal oFooterRange As Word.Range) _
         As Long
 
Const sPROCNAME As String = "Section_FooterFindTab"

Dim oFindRange As Word.Range
Dim oReturnRange As Word.Range

   On Error GoTo ErrorHandler
   
   Set oFindRange = oFooterRange.Duplicate
   
   With oFindRange.Find
       .ClearFormatting
       .Text = vbTab
       .Forward = True
       .Wrap = wdFindStop
       If .Execute Then
           Set oReturnRange = oFindRange.Duplicate
       End If
   End With

   Section_FooterFindTab = oReturnRange.Start

   Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Section_FooterParseLCR

Public Function Section_FooterParseLCR( _
         ByVal oFooter As Word.HeaderFooter, _
         ByVal sLeftRightCenter As String) _
         As Word.Range

Dim oFooterParagraph As Word.Paragraph
Dim oFooterRange As Word.Range
Dim lTabPos1 As Long
Dim lTabPos2 As Long
Dim oRangeLeft As Word.Range
Dim oRangeCenter As Word.Range
Dim oRangeRight As Word.Range

    ' Assume footer has exactly one paragraph (Word default)
    Set oFooterParagraph = oFooter.Range.Paragraphs(1)
    Set oFooterRange = oFooterParagraph.Range.Duplicate
    
    ' Remove final paragraph mark from working range
    oFooterRange.End = oFooterRange.End - 1
    
    ' Collect tab positions (character positions, not tab stop positions)
    lTabPos1 = InStr(1, oFooterRange.Text, vbTab)
    lTabPos2 = InStr(lTabPos1 + 1, oFooterRange.Text, vbTab)

    Set oRangeLeft = oFooterRange.Duplicate
    oRangeLeft.End = oRangeLeft.Start + lTabPos1 - 1
   
    Set oRangeCenter = oFooterRange.Duplicate
    oRangeCenter.Start = oRangeLeft.End + 1
    oRangeCenter.End = oFooterRange.Start + lTabPos2 - 1
   
    Set oRangeRight = oFooterRange.Duplicate
    oRangeRight.Start = oRangeCenter.End + 1

    Select Case sLeftRightCenter
       Case "Left":
          Set Section_FooterParseLCR = oRangeLeft
       Case "Center":
          Set Section_FooterParseLCR = oRangeCenter
       Case "Right":
          Set Section_FooterParseLCR = oRangeRight
    End Select
End Function

Section_FooterParseLR

Public Function Section_FooterParseLR( _
         ByVal oFooter As Word.HeaderFooter, _
         ByVal sLeftRightCenter As String) _
         As Word.Range

Const sPROCNAME As String = "Section_FooterParseLR"

Dim oFooterParagraph As Word.Paragraph
Dim oFooterRange As Word.Range
Dim lTabPos As Long
Dim oRangeLeft As Word.Range
Dim oRangeRight As Word.Range

   On Error GoTo ErrorHandler

   ' Assume footer has exactly one paragraph (Word default)
   Set oFooterParagraph = oFooter.Range.Paragraphs(1)
   Set oFooterRange = oFooterParagraph.Range.Duplicate
    
   ' Remove final paragraph mark from working range
   oFooterRange.End = oFooterRange.End - 1
              
   lTabPos = Section_FooterFindTab(oFooterRange)

   Set oRangeLeft = oFooterRange.Duplicate
   oRangeLeft.End = oRangeLeft.Start + lTabPos  ' - 1
   
   Set oRangeRight = oFooterRange.Duplicate
   oRangeRight.Start = oRangeLeft.End + 1

   Select Case sLeftRightCenter
      Case "Left":
         Set Section_FooterParseLR = oRangeLeft
      Case "Right":
         Set Section_FooterParseLR = oRangeRight
   End Select

   Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Section_FooterSet

Defines the footer for the current section to be the same as the footer in the previous section.

Public Sub Section_FooterSet(bSameAsPrevious As Boolean)
Const sPROCNAME As String = "Section_FooterSet"

   On Error GoTo AnError
   Selection.Range.Sections(1).Footers(wdHeaderFooterPrimary) _
                              .LinkToPrevious = bSameAsPrevious
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "define the footer for the current section to be the same as the footer in the" & _
        "in the previous section")
End Sub

Section_FooterTextGet

Public Function Section_FooterTextGet( _
         ByVal oFooter As Word.HeaderFooter, _
         ByVal sLeftRightCenter As String) _
         As String

Dim arTabSplit() As String
Dim sText As String
Dim sReturn As String

    sText = oFooter.Range.Text
    sText = Left(sText, Len(sText) - 1)    'strip final paragraph mark
    arTabSplit = Split(sText, vbTab)
    Select Case sLeftRightCenter
       Case "Left":
          sReturn = arTabSplit(0)
       
       Case "Center":
          If (UBound(arTabSplit) = 2) Then
             sReturn = arTabSplit(1)
          End If
       
       Case "Right":
          If (UBound(arTabSplit) = 1) Then
             sReturn = arTabSplit(1)
          End If
          If (UBound(arTabSplit) = 2) Then
             sReturn = arTabSplit(2)
          End If
       
    End Select
    
    Section_FooterTextGet = sReturn
End Function

Section_GetTabstop

Public Function Section_GetTabstop(ByVal oTargetSection As Word.Section) As Single
Const sPROCNAME As String = "getTabstop"

   Dim sngPageWidth As Single
   Dim sngMargin As Single

   On Error GoTo ErrorHandler

   sngPageWidth = oTargetSection.PageSetup.PageWidth
   sngMargin = oTargetSection.PageSetup.LeftMargin + oTargetSection.PageSetup.RightMargin
   Section_GetTabstop = sngPageWidth - sngMargin

   Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Section_HeaderEmptyIsIt

Determines if the header for the current section contains any text.

Public Function Section_HeaderEmptyIsIt() As Boolean
Const sPROCNAME As String = "Section_HeaderEmptyIsIt"

   On Error GoTo AnError
   If ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text <> vbCr Then
      Section_HeaderEmptyIsIt = True
   Else
      Section_HeaderEmptyIsIt = False
   End If
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "determine if the header for the current section contains any text")
End Function

Section_HeaderFieldsAny

Determines if there are any fields in the header for the current section.

Public Function Section_HeaderFieldsAny() As Boolean
Const sPROCNAME As String = "Section_HeaderFieldsAny"

Dim fldField As Field
   On Error GoTo AnError
   For Each fldField In ActiveDocument.Sections(1) _
                          .Headers(wdHeaderFooterPrimary).Range.Fields
      If fldField.Type = wdFieldAddin Then
'         MsgBox fldField.Code.Text
         MsgBox fldField.Data
      End If
   Next fldField
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "determines if there are any fields in the header for the current section")
End Function

Section_HeaderFooterUpdate

The type of seek view can be either ?? Or ??.

Public Function Section_HeaderFooterUpdate(lSeekViewType As Long) As Boolean
Const sPROCNAME As String = "Section_HeaderFooterUpdate"

   On Error GoTo AnError
   ActiveWindow.ActivePane.View.SeekView = lSeekViewType
   Selection.WholeStory
   Selection.Fields.Update
   ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
      "")
End Function

Section_HeaderSet

Defines the header for the current selection to be the same as the header in the previous section.

Public Sub Section_HeaderSet(bSameAsPrevious as Boolean)
Const sPROCNAME As String = "Section_HeaderSet"
   On Error GoTo AnError
 
   Selection.Range.Sections(1) _
      .Headers(wdHeaderFooterPrimary).LinkToPrevious = bSameAsPrevious

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "define the header for the current section to be the same as the header in " & _
        "the previous section")
End Sub

Section_HeaderShapeExists

Public Function Section_HeaderShapeExists( _
         ByVal lSectionNo As Long, _
         ByVal enHeaderFooterIndex As WdHeaderFooterIndex, _
         ByVal sShapeName As String, _
Optional ByVal bDisplayMessage As Boolean = False) _
         As Boolean
         
Const sPROCNAME As String = "Section_HeaderShapeExists"

Dim oShapeRange As Word.ShapeRange

   On Error GoTo AnError
   Set oShapeRange = ActiveDocument.Sections(lSectionNo).Headers(enHeaderFooterIndex).Range.ShapeRange(sShapeName)
   Section_HeaderShapeExists = True

AnError:
   If (bDisplayMessage = True) Then
      Call modMessages.Message_ShapeDoesNotExistInHeaderFooter(sShapeName)
   End If
   Section_HeaderShapeExists = False
End Function

Section_OrientationGet

Public Function Section_OrientationGet() As String
   On Error GoTo AnError
   If Selection.PageSetup.Orientation = WdOrientation.wdOrientPortrait Then
      Section_OrientationGet = "Portrait"
   End If
   If Selection.PageSetup.Orientation = WdOrientation.wdOrientLandscape Then
      Section_OrientationGet = "Landscape"
   End If
   If gbDEBUG_ERRMSG = False Then Exit Function
AnError:
   Call Error_Handle("Section_OrientationGet", msMODULENAME, _
        "return the page orientation for the current section.")
End Function

Section_OrientationSet

Public Sub Section_OrientationSet(ByVal sOrientation As String)
   On Error GoTo AnError
   If sOrientation = "Portrait" Then
      Selection.PageSetup.Orientation = WdOrientation.wdOrientPortrait
   End If

   If sOrientation = "Landscape" Then
      Selection.PageSetup.Orientation = WdOrientation.wdOrientLandscape
   End If
   If gbDEBUG_ERRMSG = False Then Exit Sub
AnError:
   Call Error_Handle("Section_OrientationSet", msMODULENAME, _
        "change the page orienation of the current section.")
End Sub

Section_PageEvenUpdate

Updates all the fields in the "first" page header and footer.

Public Sub Section_PageEvenUpdate()
Const sPROCNAME As String = "Section_PageEvenUpdate"
   On Error GoTo AnError
   If Section_HeaderFooterExists(wdSeekFirstPageHeader) = True Then
      Call Section_HeaderFooterUpdate(wdSeekFirstPageHeader)
   End If

   If Section_HeaderFooterExists(wdSeekFirstPageFooter) = True Then
      Call Section_HeaderFooterUpdate(wdSeekFirstPageHeader)
   End If

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "")
End Sub

Section_PageFirstUpdate

Updates all the fields in the "first" page header and footer.

Public Sub Section_PageFirstUpdate()
Const sPROCNAME As String = "Section_PageFirstUpdate"

   On Error GoTo AnError
   If Section_HeaderFooterExists(wdSeekFirstPageHeader) = True Then 
      Call Section_HeaderFooterUpdate(wdSeekFirstPageHeader)
   End If

   If Section_HeaderFooterExists(wdSeekFirstPageFooter) = True Then 
      Call Section_HeaderFooterUpdate(wdSeekFirstPageHeader)
   End If

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "")
End Sub

Section_PagePrimaryUpdate

Updates all the fields in the "primary" page header and footer.

Public Sub Section_PagePrimaryUpdate()
Const sPROCNAME As String = "Section_PagePrimaryUpdate"

   On Error GoTo AnError
   If Section_HeaderFooterExists(wdSeekPrimaryHeader) = True Then 
      Call Section_HeaderFooterUpdate(wdSeekPrimaryHeader)
   End If

   If Section_HeaderFooterExists(wdSeekPrimaryFooter) = True Then 
      Call Section_HeaderFooterUpdate(wdSeekPrimaryFooter)
   End If 

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "")
End Sub

Section_PrepareToDelete

Public Sub Section_PrepareToDelete( _
         ByVal lSectionNo As Long)

Const sPROCNAME As String = "Section_PrepareToDelete"

   On Error GoTo ErrorHandler
   
   If (lSectionNo > 1) Then
      'if the previous section has a different first page we need to have the same before we can delete
      If (ActiveDocument.Sections(lSectionNo - 1).PageSetup.DifferentFirstPageHeaderFooter = True) Then
         ActiveDocument.Sections(lSectionNo).PageSetup.DifferentFirstPageHeaderFooter = True
      End If

      ActiveDocument.Sections(lSectionNo).Headers(wdHeaderFooterFirstPage).LinkToPrevious = False
      ActiveDocument.Sections(lSectionNo).Headers(wdHeaderFooterPrimary).LinkToPrevious = False
      
      ActiveDocument.Sections(lSectionNo).Footers(wdHeaderFooterFirstPage).LinkToPrevious = False
      ActiveDocument.Sections(lSectionNo).Footers(wdHeaderFooterPrimary).LinkToPrevious = False
   End If
   
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Section_Print

Prints the current section of the active document.

Public Sub Section_Print()
Const sPROCNAME As String = "Section_Print"
   On Error GoTo AnError


   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "print the current section of the active document")
End Sub

SectionNo

Public Function Sel_SectionNo() As Integer
   On Error GoTo AnError
   Sel_SectionNo = Application.Selection.Information(WdInformation.wdActiveEndSectionNumber)
   If gbDEBUG_ERRMSG = False Then Exit Function
AnError:
   Call Error_Handle("Sel_SectionNo", msMODULENAME, _
        ".")
End Function

---

© 2026 Better Solutions Limited. All Rights Reserved. © 2026 Better Solutions Limited Top