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

!本文可能 超过1年没有更新,今后内容也许不会被维护或者支持,部分内容可能具有时效性,涉及技术细节或者软件使用方面,本人不保证相应的兼容和可操作性。

标题可能不是很恰当,准确的来说就是将一个有很多页面的Word文档按照指定的页数分解为多个独立的Word文档。本来想通过复制指定页内容然后再新建Word来实现的,后来发现这样做一是很麻烦,二是格式容易错。最后想到了一个比较笨的办法:复制一份原稿,然后除了要保留的页面外,其余的统统删去,然后下个页面再复制一份,以此反复,直到完成全部的拆分。

对于页面的删除,可以通过先选中这个页面内容,然后再执行Selection.Delete方法。这样删除不需要的页面后留下的就是我们需要保留的页面了,这份文档算是完成。

这里有个需要注意的地方,保留Word文档N页中第M页共P页,需要执行两步删除,第一步是删除M页之前的所有页面,第二步是删除M+P页之后的所有页面,然后得到的就是所要的。细节方面就是当执行第一步后,第M页会自动转为第1页(因为前面的都删除了),所以我们接下来执行第二步的时候需要从第1+P页开始,另外如果M=1,说明需要保留从第一页开始,那么第一步可以略去,如果M+P>=总页数,则说明需要保留的包含最后一页,那么第二步就可以略去。

下面提供一份VBScript Class msoWord_SplitPages,其中演示了上面的算法思路,供大家参考:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
'
' 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

上面的VBS会要求拆分的页码范围,一般不指定的话就意味着整个文档作为拆分对象(从第一页到最后一页),如果未指定ToPage终止页,那么将默认为这个文档的最后一页,脚本需要打开一次文档并利用wdNumberOfPagesInDocument来决定文档总页数。接下来给个调用例子:

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

上述代码将拆分test.doc的第1,2页、第3,4页等等为单独的Word文档,这里拆分的方式由PageWidth和PageSkipWidth决定,因为PageWidth是2所以一次拆分2页,PageSkipWidth设为1决定了第一次从第1页开始,那么第二次就应该从第3页开始,默认PageSkipWidth为0,也就是第一次从第1页开始,第二次就从第2页开始了。当然关于这个操作的逆操作就是将多个Word文档合并成一个文档,可以参考《VBScript/VBA批量合并多个Word文件到一个文件》。好了,代码已经放到github的gist上了,欢迎交流。

若无特别说明,本网站文章均为原创,原则上这些文章不允许转载,但是如果阁下是出于研究学习目的可以转载到阁下的个人博客或者主页,转载遵循创作共同性“署名-非商业性使用-相同方式共享”原则,请转载时注明作者出处谢绝商业性、非署名、采集站、垃圾站或者纯粹为了流量的转载。谢谢合作!
请稍后...

发表评论

电子邮件地址不会被公开。 必填项已用*标注