Word文档页数随意变

'公用变量,可读写的属性Public NumTargetPages As Long '目标页数Public UndoAfterFailure As Boolean '调整失败后恢复'可调整的项目'包括：字体，行距，左、右、上、下边距Public Enum adjItems　adjFontSize = 1　adjLineSpacing = 2　adjMarginLeft = 4　adjMarginRight = 8　adjMarginTop = 16　adjMarginBottom = 32End Enum'全部项目都可以调整Const ADJ_ALL = adjFontSize Or adjLineSpacing Or adjMarginLeft Or _　adjMarginRight Or adjMarginTop Or adjMarginBottom'错误信息'错误信息常量声明,略...Const ERR_MSG_OPERATION_SUCCESSFUL = "操作成功！该文档现在包含预定的页数。"Const ERR_MSG_SHRINK_FAILED = "错误！无法把该文档缩减到预定的页数。"Const ERR_MSG_STRETCH_FAILED = "错误！无法把该文档扩展到预定的页数。"Const ERR_MSG_TARGETPAGES_OVERFLOW = "错误！目标页数与现有页数的差距不能超过50%。"Const ERR_MSG_TARGETPAGES_SAME_AS_CURRENT_PAGES = "错误！目标页数与现有页数完全一样。"Const ERR_MSG_NO_TARGETPAGES = "错误！没有指定目标页数。"'默认允许的最小字体Const MIN_FONTSIZE As Single = 6'默认允许的最小行距Const MIN_LINESPACING As Single = 11'允许将页边距缩小到多少(百分比)Const MIN_MARGINS_PERCENTAGE As Single = 0.7Const DEF_MARGIN_ADJUSTMENT As Long = 12'声明其他对象型变量,略...'======类的属性和方法======='类初始化Private Sub Class_Initialize()If Documents.Count Then　'用于撤销已执行的格式修改操作　Set objUndoList = CommandBars.FindControl(ID:=128)End If'默认修改失败后恢复UndoAfterFailure = TrueEnd SubPrivate Sub Class_Terminate()Set objUndoList = NothingEnd SubProperty Get CurPageCount() As Long'获得文档的当前页数If Documents.Count Then　CurPageCount = ActiveDocument.ComputeStatistics(wdStatisticPages)End IfEnd PropertyPrivate Property Get sDefaultLineSpacing()'返回"正文"样式的行距，磅With ActiveDocument.Styles(wdStyleNormal).ParagraphFormat　'行距规则？　Select Case .LineSpacingRule　Case wdLineSpaceMultiple　　sDefaultLineSpacing = .LineSpacing　Case wdLineSpaceSingle, wdLineSpace1pt5, wdLineSpaceDouble　' 0, 1,或 2　　sDefaultLineSpacing = (.LineSpacingRule + 1) * 12　Case Else '忽略wdLineSpaceExactly和wdLineSpaceAtLeast　　sDefaultLineSpacing = 12　End SelectEnd WithEnd Property
Private Property Get DefaultFontRange() As Range
'找到一个按照"正文"样式格式化的Range。
'缩小字体时，查看该Range就可以知道字体缩小
'到了什么程度
If Documents.Count Then
With Selection
Set objOriginalSel = .Range
With .Find
.ClearFormatting
.Font.Size = ActiveDocument.Styles(wdStyleNormal).Font.Size
.Text = vbNullString
.Forward = True
.Wrap = wdFindContinue
.Format = True
If .Execute Then
Set DefaultFontRange = Selection.Range
Else
Set DefaultFontRange = Nothing
End If
End With
objOriginalSel.Select
End With
End If
End Property
Private Property Get nCurUndoItems()
'返回‘常用’工具栏‘撤消’列表的项目数
If IsObject(objUndoList) Then
With objUndoList
If .Enabled Then nCurUndoItems = .ListCount
End With
End If
End Property
Function Execute() As Boolean
'根据设定的参数，将文档页数调整到预定的数量
On Error Resume Next
nInitialPages = CurPageCount '初始页数
'‘撤消’列表的当前项数
nInitialUndoItems = nCurUndoItems
'默认允许以所有手段调整文字占用的空间
If nAdjustItems = 0 Then nAdjustItems = ADJ_ALL
'是否允许调整边距
bAdjustAnyMargin = CBool(nAdjustItems And adjMarginLeft) Or _
CBool(nAdjustItems And adjMarginRight) Or _
CBool(nAdjustItems And adjMarginTop) Or _
CBool(nAdjustItems And adjMarginBottom)
'根据目标页数的不同，执行不同的操作（缩减页数或扩展页数）
Select Case NumTargetPages
Case 0
'没有指定目标页数
Err.Raise ERR_NO_TARGETPAGES, , ERR_MSG_NO_TARGETPAGES
Case Is > nInitialPages * 1.5, Is < (nInitialPages + 1) 2
'目标页数与现有页数的差距不能超过50%
Err.Raise ERR_TARGETPAGES_OVERFLOW, , ERR_MSG_TARGETPAGES_OVERFLOW
Case Is < nInitialPages
'缩减页数
ShrinkToFit
Execute = (CurPageCount = NumTargetPages)
If Execute = True Then
'缩减页数成功
Err.Raise ERR_OPERATION_SUCCESSFUL, , ERR_MSG_OPERATION_SUCCESSFUL
Else
'缩减页数失败
Err.Raise ERR_SHRINK_FAILED, , ERR_MSG_SHRINK_FAILED
'是否恢复到调整页数之前的原始文档？
If UndoAfterFailure Then UndoAll
End If
Case Is > nInitialPages
'扩展页数
StretchToFit
Execute = (CurPageCount = NumTargetPages)
If Execute = True Then
'扩展页数成功
Err.Raise ERR_OPERATION_SUCCESSFUL, , ERR_MSG_OPERATION_SUCCESSFUL
Else
'扩展页数失败
Err.Raise ERR_STRETCH_FAILED, , ERR_MSG_STRETCH_FAILED
'是否恢复到调整页数之前的原始文档？
If UndoAfterFailure Then UndoAll
End If
Case Else
End Select
If IsObjectValid(objOriginalSel) Then objOriginalSel.Select
'刷新屏幕
Application.ScreenRefresh
End Function
Private Sub StretchToFit()
'扩展文档页数
With ActiveDocument
'如果允许调整字体...
If CBool(nAdjustItems And adjFontSize) Then
Do Until bFontDone
'增大字体
.Range.Font.Grow
'分析页数
nCurPages = CurPageCount
'当前页数是否等于目标页数？
If nCurPages = NumTargetPages Then
' 已经达到目标页数
Exit Sub
ElseIf nCurPages > NumTargetPages Then
'页数太多了。必须撤消最后一次修改操作
.Undo 1
bFontDone = True
Else
'文档页数仍旧太少，继续扩展文档
End If
Loop
End If
'调整行距,略...
'调整边距,略...
End With
End Sub
Private Sub ShrinkToFit()
'缩减文档页数
With ActiveDocument
'如果允许调整字体...
If CBool(nAdjustItems And adjFontSize) Then
Dim sCurFontSize As Single
'确定最小字体
If sMinFontSize = 0 Then sMinFontSize = MIN_FONTSIZE
Dim rNormalFont As Range
Set rNormalFont = DefaultFontRange
Do Until bFontDone
' FitToPages执行失败会出现5538和5539错误
On Error Resume Next
.FitToPages
Select Case Err
Case 5538, 5539
' FitToPages失败，结束循环
Err.Clear
bFontDone = True
Case 0 'FitToPages执行成功
'文档是否包含用‘正文’样式格式化的文字？
If IsObjectValid(rNormalFont) Then
'它当前的字体大小是多少？
sCurFontSize = rNormalFont.Font.Size
'如果字体已经达到允许的最小极限，则结束循环
If sCurFontSize < sMinFontSize Then
.Undo 1
bFontDone = True
End If
Else
'文档不包含‘正文’样式大小的文字。字体可能被调整到6
'磅（FitToPages的下限）
End If
Case Else '其他不能确定的异常
Err.Clear
bFontDone = True
End Select
'分析页数
nCurPages = CurPageCount
'当前页数是否等于目标页数？
If nCurPages = NumTargetPages Then
'已经达到目标页数
Exit Sub
ElseIf nCurPages < NumTargetPages Then
'页数太少了。如果不允许调整行距，撤消最后的操作
If Not CBool(nAdjustItems And adjLineSpacing) Then
.Undo 1
End If
bFontDone = True
Else
'页数仍旧太多，继续缩减页数
End If
Loop
End If
'调整行距,略...
'调整边距,略...
End With
End Sub
Private Sub UndoAll()
'撤消所有调整页数的操作,略...
End Sub