关于word的一些小模块

dogingate

1、将文档按照标题拆分
2、将文档按节拆分
3、合并文档
4、对每个文档套用一种模板（还不完善）


补充内容 (2019-6-16 21:39):
已更新带有例子的docm文件，详见8楼

201228

谢谢 楼主分享， 就是不知道怎么用

dogingate

201228 发表于 2018-7-11 19:10
谢谢 楼主分享， 就是不知道怎么用

呵呵，随便找一篇文章运行一下就知道了

dogingate

Attribute VB_Name = "Word模块导出"
'''1、引用Microsoft Visual Basic for Application Extensibility 5.3，
'''2、并且选择信任对VBA工程访问）
Sub VBComponentsExporting()
Dim strExportFolderPath As String
Dim oVBComp As Object
Dim oExportFolder As Object
Dim strExtName As String
Dim oDoc As Object

Set oDoc = ThisDocument

Set fso = CreateObject("scripting.filesystemobject")

strExportFolderPath = oDoc.Path & "\" & "Word所有模块"

If Not fso.folderexists(strExportFolderPath) Then
    fso.createfolder (strExportFolderPath)
End If

Set zd = CreateObject("scripting.dictionary")

For Each oVBComp In oDoc.VBProject.VBComponents
    If Not zd.exists(oVBComp.Name) Then
        Select Case oVBComp.Type
            Case vbext_ct_StdModule 'case 1
                zd(oVBComp.Name) = oVBComp.Name & ".bas"
            Case vbext_ct_ClassModule 'case 2
                zd(oVBComp.Name) = oVBComp.Name & ".cls"
            Case vbext_ct_MSForm 'case 3
                zd(oVBComp.Name) = oVBComp.Name & ".frm"
            Case 100
                zd(oVBComp.Name) = oVBComp.Name & ".txt"
        End Select
    End If
Next oVBComp

Set oVBProj = oDoc.VBProject
zdkeys = zd.keys
For i = 0 To zd.Count - 1
    strVBCompName = zdkeys(i)
    oVBProj.VBComponents(strVBCompName).Export strExportFolderPath & "\" & zd(strVBCompName)
Next i

MsgBox "所有模块导出完毕！"

End Sub

dogingate

Attribute VB_Name = "Word模块导入"
Sub ModuleUpdating()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim oVBProj As Object, oVBComp As Object, oDoc As Object
Dim strFilePath As String

Set fso = CreateObject("scripting.filesystemobject")

Set oDoc = ThisDocument

strFilePath = oDoc.Path & "\" & oDoc.Name

For i = 1 To Application.VBE.VBProjects.Count
    If Application.VBE.VBProjects(i).fileName = strFilePath Then
        Set oVBProj = Application.VBE.VBProjects(i)
    End If
Next i

For Each oVBComp In oVBProj.VBComponents
    Select Case oVBComp.Type
        Case 1, 2, 3
            With oVBProj.VBComponents
                .Remove .Item(oVBComp.Name) '删除模块、类模块、窗体
            End With
        Case Else
            oVBComp.CodeModule.DeleteLines 1, oVBComp.CodeModule.CountOfLines '删除工作表或Thisworkbook代码区代码
    End Select
Next

'   选择模块所在文件夹
strFolderPath = oDoc.Path & "\" & "Word所有模块"

Set reg = CreateObject("vbscript.regexp")
Set oFolder = fso.getfolder(strFolderPath)
For Each file In oFolder.Files
    strFileName = fso.getbasename(file)
    sText = LCase(strFileName)
   
    With reg
        .Global = True '设置是否匹配所有的符合项，True表示匹配所有, False表示仅匹配第一个符合项
        .IgnoreCase = True '           设置是否区分大小写，True表示不区分大小写, False表示区分大小写
        .Pattern = "^(thisdocument)" '           判断是否可以找到匹配的字符，若可以则返回True

        If .test(sText) Then '是document模块
            Set objMatches = .Execute(sText)
            strMatches = objMatches(0).Value '编号从0开始
            oVBProj.VBComponents("ThisDocument").CodeModule.AddFromFile file
        Else '非document模块
            oVBProj.VBComponents.Import file
        End If
    End With
   
Next file

End Sub

dogingate

为什么不能编辑，为什么不能删帖？

yhs185

好的，谢谢，过后有时间试一下。

dogingate

不知道怎么编辑这第一篇文章的标题和内容，所以只能再开一个贴了

以下是带有例子的代码

1、word表格批处理读取到excel表格中
2、按标题和按节拆分3、多个word文档进行合并

dogingate

里面有一些bug，也就是未考虑到一些空字符串的情形，因此加一句on error resume next即可

lgdn

学习 学习
.
.