VBA Snippets

Copy

Public Sub Page_Copy()
Dim objRange As Range
   On Error GoTo AnError
   Set objRange = Page_RangeReturn
   objRange.Copy
   If gbDEBUG_ERRMSG = False Then Exit Sub
AnError:
   Call Error_Handle("Page_Copy", msMODULENAME, _
        ".")
End Sub

Cut

Public Sub Page_Cut()
Dim objRange As Range
   On Error GoTo AnError
   Set objRange = Page_RangeReturn
   objRange.Cut
   If gbDEBUG_ERRMSG = False Then Exit Sub
AnError:
   Call Error_Handle("Page_Select", msMODULENAME, _
        ".")
End Sub

Delete

Removes the current page from the active document.

Public Sub Page_Delete()
Dim lpagestart As Long
Dim lpagefinish As Long
Dim rgecurrent As Range
   On Error GoTo AnError
   lpagefinish = Selection.Information(wdActiveEndPageNumber)
   Set rgecurrent = Selection.Range.GoTo(wdGoToPage, wdGoToPage, lpagefinish)
   lpagestart = rgecurrent.Start
   Set rgecurrent = rgecurrent.GoToNext(wdGoToPage)
   lpagefinish = rgecurrent.Start
   If lpagefinish = lpagestart Then
      Set rgecurrent = rgecurrent.Duplicate
      rgecurrent.Expand wdStory
      Set rgecurrent = rgecurrent.Parent.Range(lpagestart, rgecurrent.End)
   Else
      Set rgecurrent = rgecurrent.Parent.Range(lpagestart, lpagefinish)
   End If
   rgecurrent.Delete
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Page_Delete", msMODULENAME, 1, _
        "remove the current page")
End Sub
'****************************************************************************************
Public Sub Page_Delete()
Dim objRange As Range
   On Error GoTo AnError
   Set objRange = Page_RangeReturn
   objRange.Delete
   If gbDEBUG_ERRMSG = False Then Exit Sub
AnError:
   Call Error_Handle("Page_Delete", msMODULENAME, _
        ".")
End Sub

Insert

Inserts a new page at the current location.

Public Sub Page_Insert()
Const sPROCNAME As String = "Page_Insert"
   On Error GoTo AnError
   
   'from print out
   If gbDEBUG = False Then Exit Sub
AnError:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
   Call MsgBox( _
        "insert a new page")
End Sub

InsertBreak

Inserts a normal page break at the current location in the active document.

Public Sub Page_InsertBreak()
Const sPROCNAME As String = "Page_InsertBreak"
   On Error GoTo AnError
   
   Selection.InsertBreak Type:=wdPageBreak                            'small as possible
   'maybe format the page break
   If gbDEBUG = False Then Exit Sub
AnError:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
   Call MsgBox( _
        "insert a regular page break")
End Sub

InsertBreakSection

Inserts a section page break at the current location.

Public Sub Page_InsertBreakSection()
Const sPROCNAME As String = "Page_InsertBreakSection"
   On Error GoTo AnError
   
   Selection.InsertBreak Type:=wdSectionBreakNextPage                'small as possible
   'maybe format the page break
   If gbDEBUG = False Then Exit Sub
AnError:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
   Call MsgBox( _
        "insert a section break")
End Sub

InsertLandscape

Public Sub Layout_InsertLandscapePage()
Const sPROCNAME As String = "Layout_InsertLandscapePage"
Dim lsectionno As Long
Dim oCurrentSection As Section
Dim oPreviousSection As Section
Dim oRange As Range
   On Error GoTo ErrorHandler
   lsectionno = Selection.Information(wdActiveEndSectionNumber)
   Set oCurrentSection = ActiveDocument.Sections(lsectionno)
   If (oCurrentSection.PageSetup.Orientation = wdOrientLandscape) Then
      Exit Sub
   End If
   Set oCurrentSection = Selection.Sections(1)
   Selection.MoveUp wdLine, 1
   Set oPreviousSection = Selection.Sections(1)
   Selection.MoveDown wdLine, 1
   If (oPreviousSection.Index = oCurrentSection.Index) Then
      Selection.TypeParagraph
      Selection.InsertBreak (wdSectionBreakNextPage)
      With Selection
          .TypeParagraph
          Set oRange = Selection.Range
          oRange.MoveStart wdParagraph, -1
          oRange.Select
          .Style = ActiveDocument.Styles("Heading 1")
          .TypeText "New Landscape Section"
          Set oRange = Selection.Range
          oRange.MoveStart wdParagraph, 1
          oRange.Select
          If (Selection_IsAtEndOfDocument = False) Then
             .TypeParagraph
             .TypeParagraph
             .InsertBreak (wdSectionBreakNextPage)
             .Delete
             Set oRange = Selection.Range
             oRange.Move 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

OrientationSet

Defines the page orientation of the current page in the active document.

Public Sub Page_OrientationSet(sOrientation As String)
Const sPROCNAME As String = "Page_OrientationSet"
   On Error GoTo AnError
   If sOrientation = "Portrait" Then Selection.PageSetup.Orientation = wdOrientPortrait
   If sOrientation = "Landscape" Then Selection.PageSetup.Orientation = wdOrientLandscape
   If gbDEBUG = False Then Exit Sub
AnError:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
   Call MsgBox( _
        "")
End Sub

OrientationWhat

Determines the orientation of the current page in the active document.

Public Function Page_OrientationWhat() As String
Const sPROCNAME As String = "Page_OrientationWhat"
Dim sctSection As Section
   On Error Goto AnError
'needs to be for the active section !!!

   For Each sctSection In Selection.Sections
      If sctSection.PageSetup.Orientation = wdOrientLandscape Then
         Page_OrientationWhat = "LANDSCAPE"
      Else: Page_OrientationWhat = "PORTRAIT"
      End If
   Next sctSection
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "determine if the active page id landscape or portrait")
End Function

PageNo

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

Print

Prints the current page.

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


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

RangeReturn

Public Function Page_RangeReturn() As Range
Dim objRange As Range
Dim ipageno As Integer
   On Error GoTo AnError
   
   Set objRange = Selection.Range
   Set objRange = objRange.GoTo(What:=wdGoToBookmark, Name:="\page")
   'you can then operate on the page without selecting it, e.g.
   
   ipageno = Application.Selection.Information(WdInformation.wdActiveEndPageNumber)
   If ipageno = ActiveDocument.Content.ComputeStatistics(wdStatisticPages) Then
      objRange.MoveStart unit:=wdCharacter, Count:=-1
      objRange.MoveEnd unit:=wdCharacter, Count:=1
   End If
   
   Set Page_RangeReturn = objRange
   If gbDEBUG_ERRMSG = False Then Exit Function
AnError:
   Call Error_Handle("Page_RangeReturn", msMODULENAME, _
        ".")
End Function

Select

Public Sub Page_Select()
   On Error GoTo AnError
   Selection.GoTo What:=wdGoToBookmark, Name:="\page"
   If gbDEBUG_ERRMSG = False Then Exit Sub
AnError:
   Call Error_Handle("Page_Select", msMODULENAME, _
        ".")
End Sub