求助：word 按文件内容修改文件名称，怎么修改？谢谢!!!

沐浴阳光1

Sub word根据文件指定位置内容修改文件名()
   On Error Resume Next
    Dim p$, f$, mydoc, s1, s2
    Dim reg, mh
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True
    reg.MultiLine = True
    p = ThisWorkbook.Path & "\"
    With CreateObject("word.application")
        .Visible = False
        f = Dir(p & "*.doc*")
        Do While f <> ""
            Set mydoc = .Documents.Open(p & f)
            s1 = mydoc.Content
            .ActiveDocument.Close
            If Len(s1) > 0 Then
                reg.Pattern = "实施单位：([\S+]+)" '需要将文件名称改为"实施单位+项目名称+项目负责人.docx"
                Set mh = reg.Execute(s1)
               s2 = mh(0).submatches(0)
               Name p & f As p & s2 & ".docx"
            End If
            f = Dir
        Loop
        .Quit
    End With
End Sub

liulang0808

楼主目前的代码没有达到需求？

沐浴阳光1

liulang0808 发表于 2023-5-22 07:48
楼主目前的代码没有达到需求？

目前文件名只能加实施单位，我要实现项目名称为:实施单位+项目名称+项目负责人。

wj2368

。。。。。。。。。。。。。

liulang0808

Sub word根据文件指定位置内容修改文件名()
   On Error Resume Next
    Dim p$, f$, mydoc, s1, s2
    Dim reg, mh
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True
'    reg.MultiLine = True
    p = ThisWorkbook.Path & "\"
    With CreateObject("word.application")
        .Visible = False
        f = Dir(p & "*.doc*")
        Do While f <> ""
            Set mydoc = .Documents.Open(p & f)
            s1 = mydoc.Content

            .ActiveDocument.Close
            If Len(s1) > 0 Then
                reg.Pattern = "项目名称：(\S+)\s*实施单位：(\S+)\s*主管部门：\s?\S+\s*项目负责人：(\S+)"
                Set mh = reg.Execute(s1)
               s2 = mh(0).submatches(0) & "+" & mh(0).submatches(1) & "+" & mh(0).submatches(2)
               

               Name p & f As p & s2 & ".docx"
            End If
            f = Dir
        Loop
        .Quit
    End With
End Sub

liulang0808

修改文件名.zip (74.61 KB, 下载次数: 4)

2023-5-22 20:48 上传

点击文件名下载附件

建议楼主以后将问题直接描述清楚

沐浴阳光1

wj2368 发表于 2023-5-22 20:06
。。。。。。。。。。。。。

多谢了，完全满足需求。

沐浴阳光1

liulang0808 发表于 2023-5-22 20:48
建议楼主以后将问题直接描述清楚

好的。多谢了，完全满足需求。

smiletwo

smiletwo

Sub word根据文件指定位置内容修改文件名()
   On Error Resume Next
    Dim p$, f$, WDApp As Object, mydoc As Object, txt$, sgdw$, xmmc$, xmfzr$
    Dim reg, mh
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True
    reg.MultiLine = True
    p = ThisWorkbook.Path & "\"
    Set WDApp = CreateObject("word.application")
    WDApp.Visible = False
    f = Dir(p & "*.doc*")
    Do While f <> ""
        sgdw = ""
        xmmc = ""
        xmfzr = ""
        Set mydoc = WDApp.Documents.Open(p & f)
        txt = mydoc.Content
        mydoc.Close
        reg.Pattern = "项目名称[：:]([\S+]+).+?实施单位[：:]([\S+]+).+?项目负责人[：:]([\S+]+)"
        If reg.test(txt) Then
            Set mh = reg.Execute(txt)
            xmmc = mh(0).submatches(0)
            sgdw = mh(0).submatches(1)
            xmfzr = mh(0).submatches(2)
        End If
        Name p & f As p & sgdw & "-" & xmmc & "-" & xmfzr & ".docx"
        f = Dir
    Loop
    WDApp.Quit
    Set WDApp = Nothing
End Sub