Word 文档拆分
2009-09-29 16:45 Format Deng 阅读(1605) 评论(0) 编辑 收藏 举报本文代码为通过VBA将Word文档按标题进行分页,并构建一个一个字典用于Word文档标题名和保存文件名的一个映射。
使用时现在initmapper中添加对应。
本文所述方法利用Word的分页,所以需要在分页视图中运行。
Sub test()
initMapper()
Dim page As page, currDoc As Document
t = Timer
'Application.Visible = False
Application.ScreenUpdating = False
For Each page In Windows(1).Panes(1).Pages
currDoc = GetDoc(GetTitle(page))
page.Rectangles(1).Range.Copy()
currDoc.Range(currDoc.Content.End - 1).Paste()
Next
Application.Visible = True
Application.ScreenUpdating = True
MsgBox(Timer - t)
'SaveAndCloseAll
End Sub
Function GetTitle(ByVal page As page) As String
Dim result As String
result = "No Title"
With page.Rectangles(1).Range
For i = 1 To IIf(.Paragraphs.Count > 4, 4, .Paragraphs.Count)
If .Paragraphs(i).Range.Font.Name = "黑体" Then
result = .Paragraphs(i).Range.Text
Exit For
End If
Next i
End With
result = Replace(result, Chr(32), "")
result = Replace(result, Chr(13), "")
result = MapTitle(result)
GetTitle = result & ".doc"
End Function
Function MapTitle(ByVal title As String)
If titles.Exists(title) Then
MapTitle = titles(title)
Else
MapTitle = title
End If
End Function
'初始化标题映射字典
Sub initMapper()
titles.Add("混凝土(原材料、配合比)检验批质量验收记录表(Ⅰ)", "混凝土检验批")
titles.Add("混凝土(施工)检验批质量验收记录表(Ⅱ)", "混凝土检验批")
titles.Add("混凝土(强度、桩身处理及承载力试验)检验批质量验收记录表(Ⅲ)", "混凝土检验批")
titles.Add("钢筋(原材料及加工)检验批质量验收记录表(Ⅰ)", "钢筋检验批")
titles.Add("钢筋(连接及安装)检验批质量验收记录表(Ⅱ)", "钢筋检验批")
titles.Add("喷射混凝土(原材料)检验批质量验收记录表(Ⅰ)", "喷射混凝土检验批")
titles.Add("喷射混凝土支护(施工)检验批质量验收记录表(Ⅱ)", "喷射混凝土检验批")
titles.Add("喷射混凝土支护(养护及强度)检验批质量验收记录表(Ⅲ)", "喷射混凝土检验批")
End Sub
Sub SaveAndCloseAll()
For Each doc In Documents
doc.Save()
doc.Close()
Next
End Sub
'通过对象名字获取一个Document对象
Function GetDoc(ByVal fileName As String) As Document
If IsDocOpened(fileName) Then
GetDoc = Documents(fileName)
ElseIf Dir("D:\" & fileName) <> "" Then
GetDoc = Documents.Open("D:\" & fileName, Visible:=True)
Else
Documents.Add(Visible:=False).SaveAs("D:\" & fileName)
SetMargin(Documents(fileName))
GetDoc = Documents(fileName)
End If
End Function
Function IsDocOpened(ByVal DocName As String) As Boolean
Dim doc As Document
Dim result As Boolean
result = False
For Each doc In Documents
If doc.Name = DocName Then
result = True
Exit For
End If
Next
IsDocOpened = result
End Function
Sub SetMargin(ByVal doc As Document)
With doc.PageSetup
.TopMargin = CentimetersToPoints(2.3)
.BottomMargin = CentimetersToPoints(2.3)
.LeftMargin = CentimetersToPoints(2.3)
.RightMargin = CentimetersToPoints(2)
End With
End Sub
initMapper()
Dim page As page, currDoc As Document
t = Timer
'Application.Visible = False
Application.ScreenUpdating = False
For Each page In Windows(1).Panes(1).Pages
currDoc = GetDoc(GetTitle(page))
page.Rectangles(1).Range.Copy()
currDoc.Range(currDoc.Content.End - 1).Paste()
Next
Application.Visible = True
Application.ScreenUpdating = True
MsgBox(Timer - t)
'SaveAndCloseAll
End Sub
Function GetTitle(ByVal page As page) As String
Dim result As String
result = "No Title"
With page.Rectangles(1).Range
For i = 1 To IIf(.Paragraphs.Count > 4, 4, .Paragraphs.Count)
If .Paragraphs(i).Range.Font.Name = "黑体" Then
result = .Paragraphs(i).Range.Text
Exit For
End If
Next i
End With
result = Replace(result, Chr(32), "")
result = Replace(result, Chr(13), "")
result = MapTitle(result)
GetTitle = result & ".doc"
End Function
Function MapTitle(ByVal title As String)
If titles.Exists(title) Then
MapTitle = titles(title)
Else
MapTitle = title
End If
End Function
'初始化标题映射字典
Sub initMapper()
titles.Add("混凝土(原材料、配合比)检验批质量验收记录表(Ⅰ)", "混凝土检验批")
titles.Add("混凝土(施工)检验批质量验收记录表(Ⅱ)", "混凝土检验批")
titles.Add("混凝土(强度、桩身处理及承载力试验)检验批质量验收记录表(Ⅲ)", "混凝土检验批")
titles.Add("钢筋(原材料及加工)检验批质量验收记录表(Ⅰ)", "钢筋检验批")
titles.Add("钢筋(连接及安装)检验批质量验收记录表(Ⅱ)", "钢筋检验批")
titles.Add("喷射混凝土(原材料)检验批质量验收记录表(Ⅰ)", "喷射混凝土检验批")
titles.Add("喷射混凝土支护(施工)检验批质量验收记录表(Ⅱ)", "喷射混凝土检验批")
titles.Add("喷射混凝土支护(养护及强度)检验批质量验收记录表(Ⅲ)", "喷射混凝土检验批")
End Sub
Sub SaveAndCloseAll()
For Each doc In Documents
doc.Save()
doc.Close()
Next
End Sub
'通过对象名字获取一个Document对象
Function GetDoc(ByVal fileName As String) As Document
If IsDocOpened(fileName) Then
GetDoc = Documents(fileName)
ElseIf Dir("D:\" & fileName) <> "" Then
GetDoc = Documents.Open("D:\" & fileName, Visible:=True)
Else
Documents.Add(Visible:=False).SaveAs("D:\" & fileName)
SetMargin(Documents(fileName))
GetDoc = Documents(fileName)
End If
End Function
Function IsDocOpened(ByVal DocName As String) As Boolean
Dim doc As Document
Dim result As Boolean
result = False
For Each doc In Documents
If doc.Name = DocName Then
result = True
Exit For
End If
Next
IsDocOpened = result
End Function
Sub SetMargin(ByVal doc As Document)
With doc.PageSetup
.TopMargin = CentimetersToPoints(2.3)
.BottomMargin = CentimetersToPoints(2.3)
.LeftMargin = CentimetersToPoints(2.3)
.RightMargin = CentimetersToPoints(2)
End With
End Sub