|
Sub 按一级标题拆分文档()
Dim doc As Document, newDoc As Document, para As Paragraph, title1 As String
Selection.HomeKey Unit:=wdStory
ReDim arr(0 To 0)
arr(0) = 0
Set doc = ActiveDocument
总字数 = doc.Range.Characters.Count
Path = doc.Path & "\" '获取当前文档
' 遍历当前文档中的每个段落
For i = 1 To doc.Paragraphs.Count
' 判断段落是否为一级标题
If doc.Paragraphs(i).OutlineLevel = 1 Then
r = doc.Paragraphs(i).Range.Start
ReDim Preserve arr(0 To n)
arr(n) = r
n = n + 1
End If
Next
'Stop
For j = 0 To UBound(arr) '1维数组不用加维度
For Each para In doc.Paragraphs
If para.OutlineLevel = 1 Then
title1 = para.Range.Text
title1 = 截文本(title1)
' 去除标题中的非法字符,以便作为文件名使用
title1 = Replace(title1, "*", "")
title1 = Replace(title1, "/", "")
title1 = Replace(title1, "\", "")
title1 = Replace(title1, ":", "")
title1 = Replace(title1, "?", "")
title1 = Replace(title1, Chr(34), "")
title1 = Replace(title1, "<", "")
title1 = Replace(title1, ">", "")
title1 = Replace(title1, "|", "")
title1 = Trim(title1)
If j + 1 > UBound(arr) Then
doc.Range(arr(UBound(arr)), 总字数).Select
Else
st = arr(j)
ed = arr(j + 1)
doc.Range(st, ed).Select 'range从0下标开始,注意!!!
End If
Selection.Copy
Set newDoc = Documents.Add
' 设置新文档的标题
Selection.Paste
Selection.TypeBackspace
' 替换为你想保存的目录
newDoc.SaveAs2 Path & title1 & ".docx"
newDoc.Close 0
j = j + 1
End If
Next
Next
End Sub
Function 截文本(x)
截文本 = Left(x, Len(x) - 1)
End Function |
评分
-
1
查看全部评分
-
|