Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
VBScript/VBS/VBA split single word document to multi-documents by pages
' Description: VBScript/VBS/VBA
' split single word document
' to multi-documents by pages
' Author: wangye <pcn88 at hotmail dot com>
' Website:
' 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
Set m_wdApp = Nothing
End Sub
Private Function getTotalPages(filename)
Const wdNumberOfPagesInDocument = 4
Dim doc
Set doc = m_wdApp.Documents.Open(filename)
getTotalPages = _
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
Set Range1 = Selection.Range
If t=PrevPage Then
Selection.HomeKey wdStory
Selection.EndKey wdStory
End If
Set Range2 = Selection.Range
If t=PrevPage Then
Range.Start = Range2.Start
Range.End = Range1.End
Range.Start = Range1.Start
Range.End = Range2.End
End If
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
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
Set doc = Nothing
' 将处理完的临时文档按页码复制回指定文件夹
fso.MoveFile strTempFileName, m_strDestFilePath & "\" & i & ".doc"
Set fso = Nothing
execute = True
End Function
End Class
' Example:
' Dim obj
' Set obj = New msoWord_SplitPages
' obj.setPageWidth 2
' obj.setPageSkipWidth 1
' obj.setFileName "D:\test\testmultipages.doc"
' MsgBox obj.execute
' Set obj = Nothing
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.