通过VBA打印WORD的绝对页码

' Copyright 2005 Standard Solutions Inc - All Rights Reserved
' Author: Thushan Abeysekera
' Date: 2005/08/31
' Description: PrintGoodPages macro prints only non blank pages.
Public Sub PrintGoodPages()
Dim docType
Dim currentPageNo As Long, currentLineNo As Long
Dim sRelativePage As String, sSection As String, sCurrentPage As String
Dim sSectionsNPages As String, sTempSectionsNPages As String, testAsc As String
Dim sStartOfRange As String, sEndOfRange As String
Dim bInclude As Boolean, bAbnormalNextPage As Boolean, bStartOfRange As Boolean
Dim Pgs As Long, i As Long, j As Long, k As Long
Dim sSectionsNPagesArr(1 To 10) As String
docType = ActiveWindow.View.Type
currentPageNo = Selection.Information(wdActiveEndPageNumber)
currentLineNo = Selection.Information(wdFirstCharacterLineNumber)
ActiveWindow.View.Type = wdPrintView
sSectionsNPages = ""
sSection = ""
sRelativePage = ""
sCurrentPage = ""
sStartOfRange = ""
sEndOfRange = ""
bInclude = False
bAbnormalNextPage = False
bStartOfRange = True
i = 0
j = 1
k = 1
Pgs = ActiveDocument.ComputeStatistics(wdStatisticPages, True)
For i = 1 To Pgs
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=Str(i)
' Check whether it has actually gone to page i http://vbaexpress.com/forum/images/smilies/001.gif
If Selection.Information(wdActiveEndPageNumber) <> i Then
j = 1
' Go down 100 lines and see whether you can go to the next page
Do Until j = 100 Or Selection.Information(wdActiveEndPageNumber) = i
Selection.MoveDown Unit:=wdLine, Count:=1
j = j + 1
Loop
'Even after going down 100 lines, if you can't go to the next page, show an warning message.
If j = 100 Then
If MsgBox("There's something wrong with this document that PrintGoodPages macro cannot recognise. If continued unexpected results may occur. Do you want to continue?" _
, vbYesNo, "Abnormal Page Break") = vbNo Then
Exit Sub
End If
End If
End If
sSection = Trim(Str(Selection.Information(wdActiveEndSectionNumber)))
sRelativePage = Trim(Str(Selection.Information(wdActiveEndAdjustedPageNumber)))
' Get the current page in pNsN format.
sCurrentPage = "p" + sRelativePage + "s" + sSection
testAsc = Asc(Selection.Characters.First)
bInclude = False

Do
' Check for the page break
If testAsc = 12 Then
' But, since ascii 12 is also used as section break,
' make sure it's a page break by going one char right.
Selection.MoveRight Unit:=wdCharacter, Count:=1
If Selection.Information(wdActiveEndPageNumber) = i Then
testAsc = Asc(Selection.Characters.First)
Else
Exit Do
End If
End If
' Check for carriage return(13), space(88), etc. (If only these are in a page,
' it's still considered as a blank page.
If testAsc = 13 Or testAsc = 88 Or testAsc = 32 Or testAsc = 21 Then
If Selection.Next(Unit:=wdCharacter, Count:=1) Is Nothing Then
Exit Do
Else
Selection.Next(Unit:=wdCharacter, Count:=1).Select
testAsc = Asc(Selection.Characters.First)
End If
Else
bInclude = True
Exit Do
End If
Loop
If bInclude Then
If bStartOfRange Then
sStartOfRange = sCurrentPage
sEndOfRange = sCurrentPage
bStartOfRange = False
Else
sEndOfRange = sCurrentPage
End If
Else
' Following is the print range generation logic.
If Not bStartOfRange Then
bStartOfRange = True
sTempSectionsNPages = sSectionsNPages
If sSectionsNPages = "" Then
If sStartOfRange = sEndOfRange Then
sSectionsNPages = sStartOfRange
Else
sSectionsNPages = sStartOfRange + "-" + sEndOfRange
End If
Else
If sStartOfRange = sEndOfRange Then
sSectionsNPages = sSectionsNPages + "," + sStartOfRange
Else
sSectionsNPages = sSectionsNPages + "," + sStartOfRange + "-" + sEndOfRange
End If
End If
' Print method can only accept a string less than 256 chars.
' If it's more than 256, printing will be done in steps.
If Len(sSectionsNPages) > 255 Then
sSectionsNPagesArr(k) = sTempSectionsNPages
k = k + 1
If sStartOfRange = sEndOfRange Then
sSectionsNPages = sStartOfRange
Else
sSectionsNPages = sStartOfRange + "-" + sEndOfRange
End If
End If
End If
End If
Next i
' Finalizing print range generation.
If Not bStartOfRange Then
bStartOfRange = True
If sSectionsNPages = "" Then
If sStartOfRange = sEndOfRange Then
sSectionsNPages = sStartOfRange
Else
sSectionsNPages = sStartOfRange + "-" + sEndOfRange
End If
Else
If sStartOfRange = sEndOfRange Then
sSectionsNPages = sSectionsNPages + "," + sStartOfRange
Else
sSectionsNPages = sSectionsNPages + "," + sStartOfRange + "-" + sEndOfRange
End If
End If
End If
sSectionsNPagesArr(k) = sSectionsNPages
For i = 1 To k
If MsgBox("Pages to print are " + sSectionsNPagesArr(i) + ". Do you want to print them?" _
, vbOKCancel, "Confirm Printing Step " + Str(i) + " of " + Str(k)) = vbOK Then
Application.PrintOut FileName:="", Range:=wdPrintRangeOfPages, Item:= _
wdPrintDocumentContent, Copies:=1, Pages:=sSectionsNPagesArr(i), PageType:= _
wdPrintAllPages, ManualDuplexPrint:=False, Collate:=True, Background:= _
True, PrintToFile:=False, PrintZoomColumn:=0, PrintZoomRow:=0, _
PrintZoomPaperWidth:=0, PrintZoomPaperHeight:=0
End If
Next i
ActiveWindow.View.Type = docType
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=currentPageNo
Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=currentLineNo
End Sub