VBA Snippets

Header_SectionAdd

Adds a new header to the current section The types of header are "PRIMARY", "FIRST and "ODD".

Public Sub Header_SectionAdd(sText As String, _
                             Optional sHeaderType As String = "PRIMARY")
Const sPROCNAME As String = "Header_SectionAdd"

   On Error GoTo AnError
   With ActiveDocument.Sections(1)
      If sHeaderType = "PRIMARY" Then .Headers(wdHeaderFooterPrimary).Range.Text = sText
      If sHeaderType = "FIRST" Then .Headers(wdHeaderFooterPrimary).Range.Text = sText
      If sHeaderType = "ODD" Then .Headers(wdHeaderFooterPrimary).Range.Text = sText
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "add a header to the current section of the document")
End Sub

Header_SectionPrimarySet

Defines the header of the current section to be the same as the previous section.

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

   On Error GoTo AnError
   Selection.Range.Sections(1).Headers(wdHeaderFooterPrimary) _
                              .LinkToPrevious = bSameAsPrevious
   
'   If Selection.Range.Sections(1).Headers(wdHeaderFooterPrimary).Exists Then
   
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "")
End Sub

HeaderFooter_EvenPageUpdate

Determines if the header or footer exists for an even page in the active document.

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

   On Error GoTo AnError
   If HeaderFooter_Exists(wdSeekFirstPageHeader) = True Then _
      Call HeaderFooter_Update(wdSeekFirstPageHeader)
   If HeaderFooter_Exists(wdSeekFirstPageFooter) = True Then _
      Call HeaderFooter_Update(wdSeekFirstPageHeader)
      
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "determine if the header or footer exists" & _
        " for an even page in the active document")
End Sub

HeaderFooter_Exists

Determines if a particular header or footer exists.

Public Function HeaderFooter_Exists(lSeekViewType As Long, _
                Optional bInformUser As Boolean = FALSE) As Boolean
Const sPROCNAME As String = "HeaderFooter_Options"

   On Error GoTo AnError
   ActiveWindow.ActivePane.View.SeekView = lSeekViewType
   ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
   Section_HeaderFooterExists = True
   If gbDEBUG = False Then Exit Function
AnError:
   Section_HeaderFooterExists = False
   If bInformUser = TRUE Then
      Call Frm_Inform(sPROCNAME, 
           "determine if a particular header or footer exists")
   End If
End Function

HeaderFooter_Options

Defines the options for the header and footer in the active document.

Public Sub HeaderFooter_Options(Optional bDifferentFirstPage As Boolean = False, _
                                Optional bDifferentOddEven As Boolean = False, _
                                Optional lHeaderDistance As Long = 0, _
                                Optional lFooterDistance As Long = 0)
Const sPROCNAME As String = "HeaderFooter_Options"

   On Error GoTo AnError
   With ActiveDocument.PageSetup
      .DifferentFirstPageHeaderFooter = bDifferentFirstPage
      .OddAndEvenPagesHeaderFooter = bDifferentOddEven
      .HeaderDistance = lHeaderDistance
      .FooterDistance = lFooterDistance
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "")
End Sub

HeaderFooter_Update

Updates all the fields in the header and footer of the current selction.

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

   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

Insert_LandscapePage

Public Sub Layout_InsertLandscapePage()
Const sPROCNAME As String = "Layout_InsertLandscapePage"
Dim lsectionno As Long
Dim oCurrentSection As Word.Section
Dim oPreviousSection As Word.Section
Dim oRange As Word.Range
   On Error GoTo ErrorHandler
   lsectionno = Application.Selection.Information(wdActiveEndSectionNumber)
   Set oCurrentSection = ActiveDocument.Sections(lsectionno)
   If (oCurrentSection.PageSetup.Orientation = WdOrientation.wdOrientLandscape) Then
      'need to insert a normal page break, not a section break
      Exit Sub
   End If
   Set oCurrentSection = Application.Selection.Sections(1)
   Application.Selection.MoveUp WdUnits.wdLine, 1
   Set oPreviousSection = Application.Selection.Sections(1)
   Application.Selection.MoveDown WdUnits.wdLine, 1
   'are you NOT at the very top of a section
   If (oPreviousSection.Index = oCurrentSection.Index) Then

      'this puts the sections break on the next line
      'and not at the end of the existing line
      Application.Selection.TypeParagraph
      Application.Selection.InsertBreak (WdBreakType.wdSectionBreakNextPage)

      With Application.Selection
          .TypeParagraph
          Set oRange = Application.Selection.Range
          oRange.MoveStart WdUnits.wdParagraph, -1
          oRange.Select
          .Style = ActiveDocument.Styles("Heading 1")
          .TypeText "New Landscape Section"
          Set oRange = Application.Selection.Range
          oRange.MoveStart WdUnits.wdParagraph, 1
          oRange.Select

          If (Selection_IsAtEndOfDocument = False) Then
             .TypeParagraph
             .TypeParagraph
             .InsertBreak (WdBreakType.wdSectionBreakNextPage)
             .Delete
             Set oRange = Application.Selection.Range
             oRange.Move WdUnits.wdParagraph, -3
             oRange.Select
          End If
          Call Layout_SwitchToLandscapeSection(True)
      End With
   Else
   End If
   Set oRange = Nothing
   Exit Sub
ErrorHandler:
   Set oRange = Nothing
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Insert_PortraitPage

Public Sub Layout_InsertPortraitPage()
Const sPROCNAME As String = "Layout_InsertPortraitPage"
Dim lsectionno As Long
Dim oCurrentSection As Word.Section
Dim oPreviousSection As Word.Section
Dim oRange As Word.Range
   On Error GoTo ErrorHandler
   lsectionno = Application.Selection.Information(wdActiveEndSectionNumber)
   Set oCurrentSection = ActiveDocument.Sections(lsectionno)
   If (oCurrentSection.PageSetup.Orientation = WdOrientation.wdOrientPortrait) Then
      'need to insert a normal page break, not a section break
      Exit Sub
   End If
   Set oCurrentSection = Application.Selection.Sections(1)
   Application.Selection.MoveUp WdUnits.wdLine, 1
   Set oPreviousSection = Application.Selection.Sections(1)
   Application.Selection.MoveDown WdUnits.wdLine, 1
   'are you NOT at the very top of a section
   If (oPreviousSection.Index = oCurrentSection.Index) Then
      'this puts the sections break on the next line
      'and not at the end of the existing line
      Application.Selection.TypeParagraph
      Application.Selection.InsertBreak (WdBreakType.wdSectionBreakNextPage)
      With Application.Selection
          .TypeParagraph
          Set oRange = Application.Selection.Range
          oRange.MoveStart WdUnits.wdParagraph, -1
          oRange.Select
          .Style = ActiveDocument.Styles("Heading 1")
          .TypeText "New Portrait Section"
          Set oRange = Application.Selection.Range
          oRange.MoveStart WdUnits.wdParagraph, 1
          oRange.Select
          If (Selection_IsAtEndOfDocument = False) Then
             .TypeParagraph
             .TypeParagraph
             .InsertBreak (WdBreakType.wdSectionBreakNextPage)
             .Delete
             Set oRange = Application.Selection.Range
             oRange.Move WdUnits.wdParagraph, -3
             oRange.Select
          End If
          Call Layout_SwitchToPortraitSection(True)
      End With
   Else
   End If
   Set oRange = Nothing
   Set oCurrentSection = Nothing
   Exit Sub
ErrorHandler:
   Set oRange = Nothing
   Set oCurrentSection = Nothing
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Insert_Textbox

Public Sub Page_InsertTextbox()
Const sPROCNAME As String = "Page_InsertTextbox"
Dim oShape As Word.Shape
   On Error GoTo ErrorHandler
   Set oShape = ActiveDocument.Shapes.AddTextbox _
        (Orientation:=msoTextOrientationHorizontal, _
        Left:=56, _
        Top:=580, _
        Width:=Application.CentimetersToPoints(16.97), _
        Height:=Application.CentimetersToPoints(2.86))
   With oShape.TextFrame.TextRange
      .Text = "Confidentiality Statement" & vbCrLf
      .ParagraphFormat.Alignment = WdParagraphAlignment.wdAlignParagraphCenter
      .Font.Bold = True
      .ParagraphFormat.LineSpacingRule = WdLineSpacing.wdLineSpaceSingle
      .ParagraphFormat.SpaceBefore = 6
      .ParagraphFormat.SpaceAfter = 6
      .Collapse wdCollapseEnd
      .InsertAfter "The information contained in this document is proprietary and remains the intellectual property of Boyd Consultants. Reproduction or distribution is prohibited unless prior written approval has been received from Boyd Consultants."
      .ParagraphFormat.Alignment = WdParagraphAlignment.wdAlignParagraphLeft
      .Font.Bold = False
   End With
   Set oShape = Nothing
   Exit Sub
ErrorHandler:
   Set oShape = Nothing
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Message_PrintDocumentQuestion

Public Function PrintDocumentQuestion() As Boolean
   Dim breturn As Boolean
   Dim objreturn As VBA.VbMsgBoxResult
   objreturn = MsgBox( _
               "Would you like to print this document ?", _
               VBA.VbMsgBoxStyle.vbYesNo + VBA.VbMsgBoxStyle.vbQuestion, _
               gsFORM_TITLE)

   If objreturn = VBA.VbMsgBoxResult.vbYes Then breturn = True
   If objreturn = VBA.VbMsgBoxResult.vbNo Then breturn = False

   PrintDocumentQuestion = breturn
End Function

Page_FooterInsert

Public Sub Page_FooterInsert()
Const sPROCNAME As String = "Page_FooterInsert"
Dim oFooter As Word.HeaderFooter
Dim oRange As Word.Range
   On Error GoTo ErrorHandler
   ActiveDocument.Sections(1).PageSetup.DifferentFirstPageHeaderFooter = False
   Set oFooter = ActiveDocument.Sections(1).Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary)
   Set oRange = oFooter.Range
   
   oRange.Style = "Footer"
   oRange.ParagraphFormat.TabStops.ClearAll
   oRange.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(8.5), _
                                       Alignment:=WdTabAlignment.wdAlignTabCenter
   oRange.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(17), _
                                       Alignment:=WdTabAlignment.wdAlignTabRight
      
   With oRange
      .InsertAfter "Version 1.0; Date: " & VBA.UCase(Format(Date, "d MMM YYYY"))
      .Collapse Direction:=WdCollapseDirection.wdCollapseEnd
      .InsertAlignmentTab WdAlignmentTabAlignment.wdCenter, WdAlignmentTabRelative.wdMargin
      .MoveStart unit:=WdUnits.wdCharacter, Count:=1
      .InsertAfter "CONFIDENTIAL"
      .InsertAfter vbTab
      .InsertAfter "Page "
      .Collapse WdCollapseDirection.wdCollapseEnd
      .Fields.Add Range:=oRange, Type:=wdFieldPage
      .Collapse WdCollapseDirection.wdCollapseEnd
   End With
   Set oRange = oFooter.Range
   oRange.InsertAfter " of "
   Set oRange = oFooter.Range
   oRange.Collapse WdCollapseDirection.wdCollapseEnd
   oRange.Fields.Add Range:=oRange, Type:=wdFieldNumPages
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Page_HeaderInsert

Public Sub Page_HeaderInsert()
Const sPROCNAME As String = "Page_HeaderInsert"
Dim oHeader As Word.HeaderFooter
Dim oRange As Word.Range
   On Error GoTo ErrorHandler
   If ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text <> vbCr Then
   End If
   ActiveDocument.Sections(1).PageSetup.DifferentFirstPageHeaderFooter = False
   Set oHeader = ActiveDocument.Sections(1).Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary)
   Set oRange = oHeader.Range
   
   oRange.Style = "Header"
   oRange.ParagraphFormat.TabStops.ClearAll
   oRange.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(17), _
                                       Alignment:=WdTabAlignment.wdAlignTabRight
         
   oRange.InsertAfter "Boyd Consultants" & vbTab
   oRange.Collapse WdCollapseDirection.wdCollapseEnd
   ActiveDocument.Fields.Add Range:=oRange, _
                             Type:=wdFieldEmpty, _
                             Text:="FILENAME", _
                             PreserveFormatting:=True
'ActiveDocument.Sections(1).PageSetup.HeaderDistance = CentimetersToPoints
   Set oRange = Nothing
   Set oHeader = Nothing
   Exit Sub
ErrorHandler:
   Set oRange = Nothing
   Set oHeader = Nothing
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Page_InsertPageBreak

Public Sub Page_InsertPageBreak()
   Application.Selection.InsertBreak (WdBreakType.wdPageBreak)
End Sub

Page_InsertSectionBreak

Public Sub Page_InsertSectionBreak()
   Application.Selection.InsertBreak (WdBreakType.wdSectionBreakNextPage)
End Sub

PageSetUp

Defines the page setup for the active document.

Public Sub Doc_PageSetUp()
   On Error GoTo AnError
'   With ActiveDocument.PageSetup
'           .TopMargin = InchesToPoints(0.5)
'           .BottomMargin = InchesToPoints(0.5)
'           .LeftMargin = InchesToPoints(0.5)
'           .RightMargin = InchesToPoints(0.5)
'   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Doc_PageSetUp", msMODULENAME, 1, _
        "")
End Sub

Print

Prints the active document. Allows you to print any number of copies and only a selection of pages.

Public Sub Doc_Print(Optional iCopies As Integer = 1, _
                     Optional sPrintWhat As String = "PAGE", _
                     Optional iPageNos As Integer = -1, _
                     Optional bPrintToFile As Boolean = False)
   On Error GoTo AnError
   ActiveDocument.PrintOut Copies:=iCopies, Collate:=True
'   Application.PrintOut FileName:="", Range:=wdPrintAllDocument, Item:= _
'           wdPrintDocumentContent, Copies:=1, Pages:="", _
'           PageType:=wdPrintAllPages, Collate:=True, _
'           Background:=True, PrintToFile:=False
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Doc_Print", msMODULENAME, 1, _
        "print the active document")
End Sub

Print_PagesFromTo

Public Sub Print_PagesFromTo(ByVal sPageFrom As String, _
                             ByVal sPageTo As String)

   Call ActiveDocument.PrintOut(Range:=WdPrintOutRange.wdPrintFromTo, _
                                From:=sPageFrom, To:=sPageTo)

End Sub

Print_PagesRange

Public Sub Print_PagesRange(ByVal sPageRange As String)

   Call ActiveDocument.PrintOut(Range:=WdPrintOutRange.wdPrintRangeOfPages, _
                                Pages:=sPageRange)

End Sub

Print_PrinterChange

Public Sub Print_PrinterChange(ByVal sPrinterName As String)
   With Dialogs(wdDialogFilePrintSetup)
       .Printer = sPrinterName
       .DoNotSetAsSysDefault = True
       .Execute
   End With
End Sub

Print_Selection

Prints the current selection.

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


   If gbDEBUG = False Then Exit Sub
AnError:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
   Call MsgBox( _
        "print the current selection")
End Sub

Printer_CurrentName

Enables you to obtain the name of the currently selected printer. Could be used to be able to flag if the Linatronix printer is not selected. Include the API Calls.

Public Function Printer_CurrentName() As String
Dim sReturnName As String * 255
Dim sDriver As String
Dim sPort As String
Dim iComma1 As Integer
Dim iComma2 As Integer
   On Error Goto AnError

   Call GetProfileStringA("Windows","Device","",sReturnName, 254)

   sReturnName = Trim(sReturnName)   

   iComma1 = Instr(1,sReturnName,",")
   iComma2 = Instr(iComma1,sReturnName,",")

   sDriver = Mid(sReturnName,icomma1 + 1, icomma2 - icomma1 - 1)
   sPort = Right(sReturnName, Len(sReturnName) - icomma2)

   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Printer_CurrentName", msMODULENAME, 1, _
        "return the name of your current printer")
End Function

PrintPreview

Activates print preview mode for the active document.

Public Sub Doc_PrintPreview()
   On Error GoTo AnError
   ActiveDocument.PrintPreview                             
   ActiveDocument.PageSetup.Orientation = wdOrientLandscape 
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Doc_PrintPreview", msMODULENAME, 1, _
        "activate the print preview")
End Sub

Switch_ToLandscapeSection

Public Sub Layout_SwitchToLandscapeSection(ByVal bLinkToPrevious As Boolean)
Const sPROCNAME As String = "Layout_SwitchToLandscapeSection"
Dim lsectionno As Long
Dim oCurrentSection As Word.Section
Dim oNextSection As Word.Section
Dim oHeaderRange As Word.Range
Dim oFooterRange As Word.Range
   On Error GoTo ErrorHandler
   lsectionno = Application.Selection.Information(wdActiveEndSectionNumber)
   Set oCurrentSection = ActiveDocument.Sections(lsectionno)
   If (oCurrentSection.PageSetup.Orientation = WdOrientation.wdOrientLandscape) Then
      'do nothing
   Else
      If (ActiveDocument.Sections.Count > lsectionno) Then
          Set oNextSection = ActiveDocument.Sections(lsectionno + 1)
          oNextSection.Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
          oNextSection.Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
      End If
      oCurrentSection.Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
      oCurrentSection.Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
      oCurrentSection.PageSetup.Orientation = WdOrientation.wdOrientLandscape
'always reset these, regardless of linktoprevious or not
      Set oHeaderRange = oCurrentSection.Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
      oHeaderRange.ParagraphFormat.TabStops.Item(1).Position = CentimetersToPoints(25.75)
      Set oFooterRange = oCurrentSection.Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
      oFooterRange.ParagraphFormat.TabStops.Item(1).Position = CentimetersToPoints(8.5)
      oFooterRange.ParagraphFormat.TabStops.Item(2).Position = CentimetersToPoints(25.75)
   End If
   Set oNextSection = Nothing
   Set oHeaderRange = Nothing
   Set oFooterRange = Nothing
   Set oCurrentSection = Nothing
   Exit Sub
ErrorHandler:
   Set oNextSection = Nothing
   Set oHeaderRange = Nothing
   Set oFooterRange = Nothing
   Set oCurrentSection = Nothing
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Switch_ToPortraitSection

Public Sub Layout_SwitchToPortraitSection(ByVal bLinkToPrevious As Boolean)
Const sPROCNAME As String = "Layout_SwitchToPortraitSection"
Dim lsectionno As Long
Dim ipageno As Integer
Dim oCurrentSection As Word.Section
Dim oNextSection As Word.Section
Dim oHeaderRange As Word.Range
Dim oFooterRange As Word.Range
   On Error GoTo ErrorHandler
   lsectionno = Application.Selection.Information(wdActiveEndSectionNumber)
   Set oCurrentSection = ActiveDocument.Sections(lsectionno)
   If (oCurrentSection.PageSetup.Orientation = WdOrientation.wdOrientPortrait) Then
      'do nothing
   Else
      If (ActiveDocument.Sections.Count > lsectionno) Then
          Set oNextSection = ActiveDocument.Sections(lsectionno + 1)
          oNextSection.Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
          oNextSection.Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
      End If
      oCurrentSection.Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
      oCurrentSection.Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
      oCurrentSection.PageSetup.Orientation = WdOrientation.wdOrientPortrait
      If (bLinkToPrevious = False) Then
         Set oHeaderRange = oCurrentSection.Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
         oHeaderRange.ParagraphFormat.TabStops.Item(1).Position = CentimetersToPoints(17)
         Set oFooterRange = oCurrentSection.Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
         oFooterRange.ParagraphFormat.TabStops.Item(1).Position = CentimetersToPoints(8.5)
         oFooterRange.ParagraphFormat.TabStops.Item(2).Position = CentimetersToPoints(17)
      End If
   End If
   Set oNextSection = Nothing
   Set oHeaderRange = Nothing
   Set oFooterRange = Nothing
   Set oCurrentSection = Nothing
   Exit Sub
ErrorHandler:
   Set oNextSection = Nothing
   Set oHeaderRange = Nothing
   Set oFooterRange = Nothing
   Set oCurrentSection = Nothing
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

---

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