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

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

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