Sub PatPresentation() ' Dim pageSequence As String pageSequence = "" 'pageSequence = "2,3,4,6,7,19,22,29,8," ' ' PatPresentation Macro ' Macro created 11/3/2005 by Patrick Donahue ' Dim psArray() As String psArray = Split(pageSequence, ",") Dim ndx As Integer Dim curPage As Integer Dim lastPage As Integer lastPage = ActiveDocument.Content.Information(wdNumberOfPagesInDocument) ActiveDocument.PrintPreview ' go into Print Preview mode ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitFullPage ' use Whole Page Zoom mode ActiveWindow.View.FullScreen = True ' go into Full Screen mode ActiveDocument.Background.Fill.Visible = False ActiveWindow.DisplayVerticalScrollBar = False ' get rid of Vertical Scroll Bar CommandBars("Print Preview").Visible = False ' get rid of Print Preview menu line CommandBars("Full Screen").Visible = False ' get rid of Full Screen toggle switch CommandBars("Control Toolbox").Visible = False ' get rid of Control Toolbox thingy CommandBars("Exit Design Mode").Visible = False ' get rid of Exit Design Mode thingy System.Cursor = Word.WdCursorType.wdCursorNorthwestArrow ' make cursor an arrow instead of hourglass Dim nPut As String MsgBox ("Instructions: type ..." & vbCrLf & vbCrLf & " then Enter to go to a specified chart" & vbCrLf & "Enter only to go to next page in Sermon sequence" & vbCrLf & "b then Enter to go to previous page in Sermon sequence" & vbCrLf & "u or p then Enter to PageUp" & vbCrLf & "d or n then Enter to PageDown" & vbCrLf & "x or q then Enter to Exit") If UBound(psArray) = -1 Then ' no sequence to follow nPut = Selection.Information(wdActiveEndPageNumber) ' "1" Else nPut = psArray(0) End If Selection.GoTo What:=wdGoToPage, Name:=nPut Do While True nPut = InputBox("Chart Number ?", "Go To", "", 19000, 19000) ' place InputBox off the screen (hidden) If nPut = "exit" Or nPut = "x" Or nPut = "q" Then Exit Do If nPut = EscapeKey Or nPut = "f" Then ' forward in sequence (EscapeKey is Return) curPage = Selection.Information(wdActiveEndPageNumber) 'MsgBox "UBound(psArray)=" & UBound(psArray) If UBound(psArray) = -1 Then ' no sequence Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext ElseIf curPage = Int(psArray(UBound(psArray) - 1)) Then Selection.GoTo What:=wdGoToPage, Name:=lastPage Else For ndx = 0 To UBound(psArray) - 1 If Int(psArray(ndx)) = curPage Then Selection.GoTo What:=wdGoToPage, Name:=psArray(ndx + 1) Exit For End If Next ndx If ndx = UBound(psArray) Then Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext End If ElseIf nPut = "b" Then ' backwards in sequence curPage = Selection.Information(wdActiveEndPageNumber) 'MsgBox "curPage=" & curPage 'MsgBox "lastPage=" & lastPage 'MsgBox "UBound(psArray)=" & UBound(psArray) If UBound(psArray) = -1 Then ' no sequence Selection.GoTo What:=wdGoToPage, Which:=wdGoToPrevious ElseIf curPage = lastPage Then Selection.GoTo What:=wdGoToPage, Name:=psArray(UBound(psArray) - 1) Else For ndx = 1 To UBound(psArray) - 1 'MsgBox "CurPage=" & curPage & " psArray(ndx)=" & psArray(ndx) & " psArray(ndx+1)=" & psArray(ndx + 1) If Int(psArray(ndx)) = curPage Then Selection.GoTo What:=wdGoToPage, Name:=psArray(ndx - 1) Exit For End If Next ndx If ndx = UBound(psArray) Then Selection.GoTo What:=wdGoToPage, Which:=wdGoToPrevious End If ElseIf nPut = "d" Or nPut = "n" Then Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext ElseIf nPut = "u" Or nPut = "p" Then Selection.GoTo What:=wdGoToPage, Which:=wdGoToPrevious ElseIf IsNumeric(nPut) Then If Int(nPut) < 1 Then nPut = 1 If Int(nPut) > lastPage Then nPut = lastPage ' to get InsertionPoint mark to disappear - doesn't always work Selection.GoTo What:=wdGoToPage, Name:=nPut End If Loop Selection.EscapeKey Selection.EscapeKey End Sub