VBA/VBScript裁剪拆分Word文档为多个文件(分解为多个独立页面)

'
' Description: VBScript/VBS/VBA
'              split single word document
'              to multi-documents by pages
' Author: wangye  <pcn88 at hotmail dot com>
' Website: http://wangye.org
' Copyright by author
'
Const PrevPage = 0
Const NextPage = 1
Class msoWord_SplitPages
  Private m_nFromPage
  Private m_nToPage
  Private m_nTotalPages
  Private m_nPageWidth
  Private m_wdApp
  Private m_strFileName
  Private m_strDestFilePath
  Private m_nPageSkipWidth
 
  Private Sub Class_Initialize()
    Set m_wdApp = WSH.CreateObject("Word.Application")
    m_wdApp.Visible = True
    m_nPageSkipWidth = 0
    m_nPageWidth = 1
    m_nFromPage = 1
    m_nToPage = 0
  End Sub
 
  Private Sub Class_Terminate()
    m_wdApp.Visible = True
    m_wdApp.Quit
    Set m_wdApp = Nothing
  End Sub
 
  Private Function getTotalPages(filename)
    Const wdNumberOfPagesInDocument = 4
    Dim doc
    Set doc = m_wdApp.Documents.Open(filename)
      getTotalPages = _
        m_wdApp.Selection.Information(wdNumberOfPagesInDocument)
      doc.Close
    Set doc = Nothing
  End Function
 
  Private Function isPagesValid()
    isPagesValid = CBool(m_nFromPage<=m_nToPage And _
        m_nFromPage>0 And m_nToPage<=m_nTotalPages)
  End Function
 
  ' keepPage Need keep pages
  ' t        delete type PrevPage or Next Page
  Private Sub deletePages(keepPage, t)
    Const wdGoToPage = 1
    Const wdGoToNext = 2
    Const wdStory = 6
 
    Dim Range,Selection
    Dim Range1, Range2
 
    If Not isPagesValid() Then Exit Sub
    If t=PrevPage And keepPage<1 Then Exit Sub
    If t=NextPage And keepPage>m_nTotalPages Then Exit Sub
 
    Set Selection = m_wdApp.Selection
    Set Range = m_wdApp.Selection.Range
 
      Selection.GoTo wdGoToPage, wdGoToNext, keepPage
      Selection.Select
 
      Set Range1 = Selection.Range
        If t=PrevPage Then
          Selection.HomeKey wdStory
        Else
          Selection.EndKey wdStory
        End If
        Selection.Select
        Set Range2 = Selection.Range
        If t=PrevPage Then
          Range.Start = Range2.Start
          Range.End = Range1.End
        Else
          Range.Start = Range1.Start
          Range.End = Range2.End
        End If
          Range.Select
          Selection.Delete
          Selection.TypeBackspace
        Set Range2 = Nothing
      Set Range1 = Nothing
    Set Range = Nothing
    Set Selection = Nothing
  End Sub
 
  Private Function min_(a, b)
    If a>b Then
      min_ = b
    Else
      min_ = a
    End If
  End Function
 
  ' 设置拆分页面的起始页数（初始为1）
  Public Sub setFromPage(p)
    m_nFromPage = p
  End Sub
 
  ' 设置拆分页面的末尾页数（初始为总页数）
  Public Sub setToPage(p)
    m_nToPage = p
  End Sub
 
  ' 设置每次拆分所需要保留的页数
  Public Sub setPageWidth(p)
    m_nPageWidth = p
  End Sub
 
  ' 设置执行拆分跳过的页数
  Public Sub setPageSkipWidth(p)
    m_nPageSkipWidth = p
  End Sub
 
  ' 设置源Word文件路径
  Public Sub setFileName(fn)
    m_strFileName = fn
  End Sub
 
  ' 设置拆分后的多个Word文件所在的文件夹
  Public Sub setDestFilePath(fn)
    m_strDestFilePath = fn
  End Sub
 
  ' 执行函数
  Public Function execute()
    execute = False
 
    m_nTotalPages = getTotalPages(m_strFileName)
    If m_nToPage <1 Then m_nToPage = m_nTotalPages
    If Not isPagesValid() Then Exit Function
    Dim i,fso,doc
    Set fso = WSH.CreateObject("Scripting.FileSystemObject")
 
    If m_strFileName="" Or (Not fso.FileExists(m_strFileName)) Then
      Exit Function
    End If
 
    If m_strDestFilePath="" Or (Not fso.FolderExists(m_strDestFilePath)) Then
      m_strDestFilePath = fso.GetParentFolderName(m_strFileName)
    End If
 
    Dim strTempFileName
    For i=m_nFromPage To _
      min_(m_nToPage, m_nTotalPages) Step m_nPageSkipWidth+1
      ' 复制一份临时文档供我们删减
      strTempFileName = m_strDestFilePath & "\~$tmp" & i & fso.GetTempName
      fso.CopyFile m_strFileName, strTempFileName
      Set doc = m_wdApp.Documents.Open(strTempFileName)
        If i>1 Then
          deletePages i-1, PrevPage
        End If
        If (i+m_nPageWidth-1)<m_nTotalPages Then
          deletePages m_nPageWidth, NextPage
        End If
        doc.Save
        doc.Close
      Set doc = Nothing
      ' 将处理完的临时文档按页码复制回指定文件夹
      fso.MoveFile strTempFileName, m_strDestFilePath & "\" & i & ".doc"
    Next
 
    Set fso = Nothing
    execute = True
  End Function
End Class

Dim obj
Set obj = New msoWord_SplitPages
    obj.setPageWidth 2
    obj.setPageSkipWidth 1
    obj.setFileName "D:\src\test.doc"
    obj.setDestFilePath "D:\dest"
    MsgBox obj.execute
Set obj = Nothing