MS Word VBA:正在保存文件，运行时错误5152

我最近发布了一个关于如何拆分和保存邮件合并文档的问题。在网上找到一些代码后，我能够将其与我自己的代码结合起来，以将文档拆分并创建我想要的名称。然而，现在当代码去保存文档时，它发出了一个5152错误，我不知道如何去做。这是我的代码的外观，错误发生在ActiveDocument.SaveAs文件名：=Fullname，fileformat:=wdFormatDocumentDefault，AddToRecentFiles:=False

Option Explicit

Sub Splitter()

' splitter Macro

' Macro created by Doug Robbins to save each letter created by a mailmergeas a separate file.
Application.ScreenUpdating = False
Dim Program As String
Dim DocName As String
Dim Letters As Integer, Counter As Integer
Dim filename, extension, Fullname, Mask As String

Letters = ActiveDocument.Sections.Count
Selection.HomeKey Unit:=wdStory
Counter = 1
While Counter < Letters
'program = ActiveDocument.MailMerge.DataSource.DataFields("Program_Outcomes_PlanReport_Name").Value
DocName = "Reports" & LTrim$(Str$(Counter))  'Generic name of document
ActiveDocument.Sections.First.Range.Cut
Documents.Add
Selection.Paste
ActiveDocument.Sections(2).PageSetup.SectionStart = wdSectionContinuous

filename = ActiveDocument.Paragraphs(1).Range.Text
            filename = Replace(filename, Chr$(13), "")
            filename = Replace(filename, Chr$(10), "")
            filename = Replace(filename, "/", "_")
            filename = Replace(filename, "&", "_")
            extension = ".docx"
            DocName = "E:\assessment rubrics" & filename & " - Academic Program Review - " & Format(Now(), Mask)
            Fullname = DocName & extension

ActiveDocument.SaveAs filename:=Fullname, fileformat:=wdFormatDocumentDefault, AddToRecentFiles:=False
ActiveWindow.Close
Counter = Counter + 1
Wend

Application.ScreenUpdating = True

End Sub

选项显式
子拆分器（）
'拆分器宏
'由Doug Robbins创建的宏，用于将MailMerge创建的每个字母保存为单独的文件。
Application.ScreenUpdating=False
将程序设置为字符串
将DocName设置为字符串
将字母设置为整数，计数器设置为整数
Dim文件名、扩展名、全名、掩码为字符串
Letters=ActiveDocument.Sections.Count
Selection.HomeKey单位：=wdStory
计数器=1
而反字母
'program=ActiveDocument.MailMerge.DataSource.DataFields（“程序结果计划报告名称”）.Value
DocName=“Reports”<rim$（Str$（Counter））'文档的通用名称
ActiveDocument.Sections.First.Range.Cut
文件。添加
选择。粘贴
ActiveDocument.Sections（2）.PageSetup.SectionStart=wdSectionContinuous
filename=ActiveDocument.段落（1）.Range.Text
filename=Replace（文件名，Chr$（13），“”）
filename=Replace（文件名，Chr$（10），“”）
filename=Replace（文件名“/”，“389;”）
filename=Replace（文件名“&”和“389;”）
扩展名=“.docx”
DocName=“E:\assessment rubrics”&filename&“-Academic Program Review-”&Format（Now（），Mask）
Fullname=DocName和扩展名
ActiveDocument.SaveAs文件名：=全名，文件格式：=wdFormatDocumentDefault，AddToRecentFiles:=False
活动窗口，关闭
计数器=计数器+1
温德
Application.ScreenUpdating=True
端接头

cvtstr（这些字符/|？*：“\不允许出现在文件名中。请使用以下函数：

Function cvtstr(strIn As String) As String
    Dim i As Integer

    Const str = "\/|?*<>"":"
    cvtstr = strIn
    For i = 1 To Len(str)
        cvtstr = Replace(cvtstr, Mid$(str, i, 1), " ")
    Next i
End Function

Function cvtstr(strIn As String) As String
    Dim i As Integer

    Const str = "/|?*<>"":"
    cvtstr = strIn
    For i = 1 To Len(str)
        cvtstr = Replace(cvtstr, Mid$(str, i, 1), " ")
    Next i
End Function

编辑：

结合使用filepath和filename不是一种好做法，但由于您是从段落中提取的，因此在找到更好的解决方案来改进代码之前，您可以执行以下操作：

使用以下功能：

Function cvtstr(strIn As String) As String
    Dim i As Integer

    Const str = "\/|?*<>"":"
    cvtstr = strIn
    For i = 1 To Len(str)
        cvtstr = Replace(cvtstr, Mid$(str, i, 1), " ")
    Next i
End Function

Function cvtstr(strIn As String) As String
    Dim i As Integer

    Const str = "/|?*<>"":"
    cvtstr = strIn
    For i = 1 To Len(str)
        cvtstr = Replace(cvtstr, Mid$(str, i, 1), " ")
    Next i
End Function

cvtstr（这些字符/|？*：“\不允许出现在文件名中。请使用以下函数：

Function cvtstr(strIn As String) As String
    Dim i As Integer

    Const str = "\/|?*<>"":"
    cvtstr = strIn
    For i = 1 To Len(str)
        cvtstr = Replace(cvtstr, Mid$(str, i, 1), " ")
    Next i
End Function

Function cvtstr(strIn As String) As String
    Dim i As Integer

    Const str = "/|?*<>"":"
    cvtstr = strIn
    For i = 1 To Len(str)
        cvtstr = Replace(cvtstr, Mid$(str, i, 1), " ")
    Next i
End Function

编辑：

结合使用filepath和filename不是一种好做法，但由于您是从段落中提取的，因此在找到更好的解决方案来改进代码之前，您可以执行以下操作：

使用以下功能：

Function cvtstr(strIn As String) As String
    Dim i As Integer

    Const str = "\/|?*<>"":"
    cvtstr = strIn
    For i = 1 To Len(str)
        cvtstr = Replace(cvtstr, Mid$(str, i, 1), " ")
    Next i
End Function

Function cvtstr(strIn As String) As String
    Dim i As Integer

    Const str = "/|?*<>"":"
    cvtstr = strIn
    For i = 1 To Len(str)
        cvtstr = Replace(cvtstr, Mid$(str, i, 1), " ")
    Next i
End Function

---

这就是我的代码现在的样子

Function cvtstr(strIn As String) As String
    Dim i As Integer

    Const str = "/|?*<>"":"
    cvtstr = strIn
    For i = 1 To Len(str)
        cvtstr = Replace(cvtstr, Mid$(str, i, 1), " ")
    Next i
End Function


Sub Splitter()

' splitter Macro

' Macro created by Doug Robbins to save each letter created by a mailmergeas a separate file.
Application.ScreenUpdating = False
Dim Program As String
Dim DocName As String
Dim Letters As Integer, Counter As Integer
Dim filename, extension, Fullname, filepath, Mask As String

Letters = ActiveDocument.Sections.Count
Selection.HomeKey Unit:=wdStory
Counter = 1
While Counter < Letters
'program =  ActiveDocument.MailMerge.DataSource.DataFields("Program_Outcomes_PlanReport_Name").Value
DocName = "Reports" & LTrim$(str$(Counter))  'Generic name of document
ActiveDocument.Sections.First.Range.Cut
Documents.Add
Selection.Paste
'ActiveDocument.Sections(2).PageSetup.SectionStart = wdSectionContinuous

Filename = cvtstr(ActiveDocument.Paragraphs(1).Range.Text)
Filename = Left(Filename, Len(Filename) - 1)
extension = ".docx"
DocName = "E:\assessment rubrics\" & Filename & " - Academic Program Review - " & cvtstr(Format(Now(), Mask)))
FullName = DocName & extension

ActiveDocument.SaveAs filename:=Fullname, fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False

ActiveWindow.Close
Counter = Counter + 1
Wend

Application.ScreenUpdating = True

End Sub

函数cvtstr（strIn作为字符串）作为字符串
作为整数的Dim i
Const str=“/|？*”：“
cvtstr=strIn
对于i=1到Len（str）
cvtstr=替换（cvtstr，Mid$（str，i，1），“”）
接下来我
端函数
子拆分器（）
'拆分器宏
'由Doug Robbins创建的宏，用于将MailMerge创建的每个字母保存为单独的文件。
Application.ScreenUpdating=False
将程序设置为字符串
将DocName设置为字符串
将字母设置为整数，计数器设置为整数
Dim文件名、扩展名、全名、文件路径、掩码为字符串
Letters=ActiveDocument.Sections.Count
Selection.HomeKey单位：=wdStory
计数器=1
而反字母
'program=ActiveDocument.MailMerge.DataSource.DataFields（“程序结果计划报告名称”）.Value
DocName=“Reports”<rim$（str$（Counter））'文档的通用名称
ActiveDocument.Sections.First.Range.Cut
文件。添加
选择。粘贴
'ActiveDocument.Sections（2）.PageSetup.SectionStart=wdSectionContinuous
Filename=cvtstr（ActiveDocument.parations（1）.Range.Text）
Filename=左（Filename，Len（Filename）-1）
扩展名=“.docx”
DocName=“E:\assessment rubrics\”&Filename&“-Academic Program Review-”&cvtstr（格式（Now（），Mask）））
FullName=DocName和扩展名
ActiveDocument.SaveAs文件名：=全名，文件格式：=wdFormatXMLDocument，AddToRecentFiles:=False
活动窗口，关闭
计数器=计数器+1
温德
Application.ScreenUpdating=True
端接头

这就是我的代码现在的样子

Function cvtstr(strIn As String) As String
    Dim i As Integer

    Const str = "/|?*<>"":"
    cvtstr = strIn
    For i = 1 To Len(str)
        cvtstr = Replace(cvtstr, Mid$(str, i, 1), " ")
    Next i
End Function


Sub Splitter()

' splitter Macro

' Macro created by Doug Robbins to save each letter created by a mailmergeas a separate file.
Application.ScreenUpdating = False
Dim Program As String
Dim DocName As String
Dim Letters As Integer, Counter As Integer
Dim filename, extension, Fullname, filepath, Mask As String

Letters = ActiveDocument.Sections.Count
Selection.HomeKey Unit:=wdStory
Counter = 1
While Counter < Letters
'program =  ActiveDocument.MailMerge.DataSource.DataFields("Program_Outcomes_PlanReport_Name").Value
DocName = "Reports" & LTrim$(str$(Counter))  'Generic name of document
ActiveDocument.Sections.First.Range.Cut
Documents.Add
Selection.Paste
'ActiveDocument.Sections(2).PageSetup.SectionStart = wdSectionContinuous

Filename = cvtstr(ActiveDocument.Paragraphs(1).Range.Text)
Filename = Left(Filename, Len(Filename) - 1)
extension = ".docx"
DocName = "E:\assessment rubrics\" & Filename & " - Academic Program Review - " & cvtstr(Format(Now(), Mask)))
FullName = DocName & extension

ActiveDocument.SaveAs filename:=Fullname, fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False

ActiveWindow.Close
Counter = Counter + 1
Wend

Application.ScreenUpdating = True

End Sub

函数cvtstr（strIn作为字符串）作为字符串
作为整数的Dim i
Const str=“/|？*”：“
cvtstr=strIn
对于i=1到Len（str）
cvtstr=替换（cvtstr，Mid$（str，i，1），“”）
接下来我
端函数
子拆分器（）
'拆分器宏
'由Doug Robbins创建的宏，用于将MailMerge创建的每个字母保存为单独的文件。
Application.ScreenUpdating=False
将程序设置为字符串
将DocName设置为字符串
将字母设置为整数，计数器设置为整数
Dim文件名、扩展名、全名、文件路径、掩码为字符串
Letters=ActiveDocument.Sections.Count
Selection.HomeKey单位：=wdStory
计数器=1
而反字母
'program=ActiveDocument.MailMerge.DataSource.DataFields（“程序结果计划报告名称”）.Value
DocName=“Reports”<rim$（str$（Counter））'文档的通用名称
ActiveDocument.Sections.First.Range.Cut
文件。添加
选择。粘贴
'ActiveDocument.Sections（2）.PageSetup.SectionStart=wdSectionContinuous
Filename=cvtstr（ActiveDocument.parations（1）.Range.Text）
Filename=左（Filename，Len（Filename）-1）
扩展名=“.docx”
DocName=“E:\assessment rubrics\”&Filename&“-Academic Program Review-”&cvtstr（格式（Now（），Mask）））
FullName=DocName和扩展名
ActiveDocument.SaveAs文件名：=全名，文件格式：=wdFormatXMLDocument，AddToRecentFiles:=False
活动窗口，关闭
计数器=计数器+1
温德
Application.ScreenUpdating=True
端接头

Im假设它必须与文件路径的写入方式有关，因为错误消息显示：

运行时错误“5152”：这不是有效的文件名。请尝试以下一项或多项：*检查路径以确保键入的路径相同*从文件和文件夹列表中选择一个文件。

首先，

assessment rubrics

是文件夹名还是文件名的第一个单词？如果它是一个文件夹名，那么您应该更改它