Question

我最近发布了一个关于让我的邮件合并文档拆分并保存的问题。在网上找到一些代码后，我能够将它与我自己的代码结合起来，以便分割文档并创建一个我想要的名称。但是，现在当代码保存文档时，它会发出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

Answer 1

cvtstr（您的文件名中不允许使用这些字符/ |？*＆lt;＆gt;：“\。使用以下函数：

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

然后你的代码应该是：

    Dim filename As String, Fullname As String, Mask As String, filepath As String
    .
    .
    .
    filename = cvtstr(Replace(ActiveDocument.Paragraphs(1).Range.Text, "Templates\", "")) 'this part is temporary solution. You actually need to distinguish filepath and filename in ActiveDocument.Paragraphs(1).Range.Text    
    filename = Left(filename, Len(filename) - 1) & " - Academic Program Review - " & cvtstr(Format(Now(), Mask)))

    filepath = "E:\assessment_rubrics\Templates\"

    FullName = filepath & filename & ".docx"

编辑：

组合文件路径和文件名不是一个好习惯，但是从段落中提取它，直到找到更好的解决方案来改进代码，您可以执行以下操作：

使用以下功能：

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

并在代码中使用以下行

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

Answer 2

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

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

MS Word VBA：保存文件，运行时错误5152

2 个答案: