文档按指定格式分割

ww0000

文档按指定格式分割

根据黑体字分割成多个文档并以黑体字重命名 文档按指定格式分割.zip (51.35 KB, 下载次数: 17)

2018-9-8 18:56 上传

点击文件名下载附件

duquancai

周末闲来无事，写个代码，请测试！！！

Sub main()
    Dim res As Variant, mDOC As Document, myDirectory$
    Set mDOC = ThisDocument: myDirectory = "分割后"
    If Dir(mDOC.Path & "\" & myDirectory, vbDirectory) <> "" Then
        If Dir(mDOC.Path & "\" & myDirectory & "\*.*") <> "" Then Kill mDOC.Path & "\" & myDirectory & "\*.*"
    Else
        MkDir mDOC.Path & "\" & myDirectory & "\"
    End If
    res = getRange(mDOC)
    If Not IsArray(res) Then Exit Sub
    Dim myPath$, i&, doc As Document, myFile$
    myPath = mDOC.Path & "\" & myDirectory & "\"
    Application.ScreenUpdating = False
    For i = 1 To UBound(res)
        With mDOC.Range(res(i - 1), res(i))
            With .Duplicate
                .End = .Start: .MoveUntil vbCr: .MoveWhile vbCr & Chr(32): .MoveEndUntil vbCr
                myFile = getName(.Text)
            End With
            If Len(myFile) Then
                If Dir(myPath & myFile & ".doc") = "" Then
                    Set doc = Documents.Add(mDOC.FullName)
                    doc.Content.FormattedText = .FormattedText
                    With doc.Content
                        .Start = .End: .MoveStartWhile vbCr & Chr(32), wdBackward: .Text = Empty
                    End With
                    doc.SaveAs myPath & myFile & ".doc", wdFormatDocument
                    doc.Close
                End If
            End If
        End With
    Next
    Application.ScreenUpdating = True
End Sub
Function getRange(ByVal doc As Document) As Variant
    Dim ar(), n&
    With doc.Content.Find
        Do While .Execute("国旗下讲话稿")
            n = n + 1: ReDim Preserve ar(n)
            ar(n - 1) = .Parent.Start
        Loop
    End With
    If n > 0 Then
        ar(n) = doc.Range.End - 1
        getRange = ar
    End If
End Function
Function getName(ByVal aStr As String) As String
    Dim ErrArray() As Variant, oArray As Variant
    ErrArray = Array("\", "/", "*", ":", "?", "<", ">", "|", """", Chr$(7), Chr$(8), Chr$(9), Chr$(10), Chr$(11), Chr$(13))
    For Each oArray In ErrArray
        aStr = Replace(aStr, oArray, "")
    Next
    getName = LTrim(aStr)
End Function

ww0000

duquancai 发表于 2018-9-9 14:59
周末闲来无事，写个代码，请测试！！！

Sub main()

谢谢。测试文档能用，但能不能不用“国旗下讲话稿”这个识别，直接用黑体字识别？因为别的文档没有“国旗下讲话稿”这几个字

duquancai

ww0000 发表于 2018-9-9 19:02
谢谢。测试文档能用，但能不能不用“国旗下讲话稿”这个识别，直接用黑体字识别？因为别的文档没有“国旗 ...

那就自己修改吧！

zhanglei1371

或者付费找楼上做，做到满意为止

ming0018

学习了。movewhile和moveuntil学会了。