代码改变世界

Word 文档拆分

2009-09-29 16:45 by Format Deng, ... 阅读, ... 评论, 收藏, 编辑

本文代码为通过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 > 44, .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 StringAs 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 StringAs 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