Option Explicit Dim PageNum As Long, NumPages As Long, XtraPages As Long, MyRange As Range, _ PagestoPrint As String, OddPagesToPrint As String, EvenPagesToPrint As String Sub Booklet2000DuplexPrinter() NumPages = Selection.Information(wdNumberOfPagesInDocument) 'If number of pages not a multiple of 4, add manual page breaks at the end If NumPages Mod 4 > 0 Then Call AddExtraPages 'Put the pages to be printed into a single string, in the correct order Call GetPagesToPrintDuplex 'Print Call PrintPages(PagestoPrint) 'If any page breaks were added, delete them again If XtraPages > 0 Then Call DeleteExtraPages Call ClearVariables End Sub Sub Booklet2000SimplexPrinter() NumPages = Selection.Information(wdNumberOfPagesInDocument) 'If number of pages not a multiple of 4, add manual page breaks at the end If NumPages Mod 4 > 0 Then Call AddExtraPages 'Put the pages to be printed into a single string, in the correct order Call GetPagesToPrintSimplex Call PrintPages(OddPagesToPrint) MsgBox "Please turn the paper over and press OK when you'r ready to print" Call PrintPages(EvenPagesToPrint) 'If any page breaks were added, delete them again If XtraPages > 0 Then Call DeleteExtraPages Call ClearVariables End Sub Sub AddExtraPages() 'Adds page breaks to make the number of pages a multiple of 4 XtraPages = 4 - NumPages Mod 4 For PageNum = 1 To XtraPages Set MyRange = ActiveDocument.Range MyRange.Collapse wdCollapseEnd MyRange.InsertBreak Type:=wdPageBreak Next PageNum NumPages = Selection.Information(wdNumberOfPagesInDocument) End Sub Sub GetPagesToPrintDuplex() For PageNum = 1 To NumPages / 2 If Len(PagestoPrint) > 0 Then PagestoPrint = PagestoPrint & "," If PageNum Mod 2 = 1 Then 'odd page PagestoPrint = PagestoPrint & (NumPages + 1 - PageNum) & "," & PageNum Else ' even page PagestoPrint = PagestoPrint & PageNum & "," & (NumPages + 1 - PageNum) End If Next PageNum End Sub Sub GetPagesToPrintSimplex() For PageNum = 1 To NumPages / 2 If PageNum Mod 2 = 1 Then 'odd page If Len(OddPagesToPrint) > 0 Then OddPagesToPrint = OddPagesToPrint & "," OddPagesToPrint = OddPagesToPrint & (NumPages + 1 - PageNum) & "," & PageNum Else 'even page If Len(EvenPagesToPrint) > 0 Then EvenPagesToPrint = EvenPagesToPrint & "," EvenPagesToPrint = EvenPagesToPrint & PageNum & "," & (NumPages + 1 - PageNum) End If Next PageNum End Sub Sub PrintPages(PagestoPrint As String) Dim Pos As Long, PagesToPrintChunk As String, TestPages As Variant 'The 'pages to print' string can only be a maximum of 256 characters long '(Word limitation). If > 256 characters, prints it in smaller chunks '(otherwise just prints it) Do While Len(PagestoPrint) > 256 PagesToPrintChunk = Left$(PagestoPrint, 256) 'Strip the chunk string so it ends before the final comma Pos = InStrRev(PagesToPrintChunk, ",") PagesToPrintChunk = Left$(PagesToPrintChunk, Pos - 1) 'find out how many pages are now listed in the string (needs to be a multiple of 4) TestPages = Split(PagesToPrintChunk, ",") NumPages = UBound(TestPages) + 1 'If not a multipke of 4, removes some page numbers so that it is If NumPages Mod 4 > 0 Then For PageNum = 1 To NumPages Mod 4 Pos = InStrRev(PagesToPrintChunk, ",") PagesToPrintChunk = Left$(PagesToPrintChunk, Pos - 1) Next End If Application.PrintOut Pages:=PagesToPrintChunk, _ Range:=wdPrintRangeOfPages, Background:=False 'Strip main string so it starts just after the same comma PagestoPrint = Mid$(PagestoPrint, Pos + 1) Loop Application.PrintOut Pages:=PagestoPrint, _ Range:=wdPrintRangeOfPages, Background:=False End Sub Sub DeleteExtraPages() 'If manual page breaks were added earlier, deletes them again Set MyRange = ActiveDocument.Range MyRange.Collapse wdCollapseEnd MyRange.MoveStart unit:=wdCharacter, Count:=-(XtraPages + 1) MyRange.Delete End Sub Sub ClearVariables() Set MyRange = Nothing PageNum = 0 NumPages = 0 XtraPages = 0 PagestoPrint = vbNullString OddPagesToPrint = vbNullString EvenPagesToPrint = vbNullString End Sub