将文件名保存为word中的第一行，然后递增

Question

我有这个在MS Word 2013中使用的VBA宏脚本，它运行良好。但是我需要更改一个部分，因为它会导致一些问题。 （位于下方的完整VBA脚本）。

代码更改

baseFile.SaveAs _
            FileName:=saveFN & Format(iterNum, "0000") & ".prtl", _
            FileFormat:=wdFormatText, _
            AddToRecentFiles:=False

        ' close the modified file without saving
        baseFile.Close SaveChanges:=wdDoNotSaveChanges

        iterNum = iterNum + 1
    Next para

目标

我希望它不是递增文件名，而是从文字doc中取出文本的第一行，并将其用作文件名，然后使用下一个文件名保存下一个文字行。

示例：

Word文字文字：

Perter Pan：/ Green Pants / 胡克船长：/挂钩/

期望的结果

Perter Pan - 绿色裤子 胡克船长 - 胡克

备注：

请注意，必须删除“/”，并且“：”应替换为“ - ”，否则无法保存文件。

完整的VBA脚本：

此脚本允许您为Adobe Premiere制作标题。如果你需要制作很多标题，这就是你的脚本。

Option Explicit

Sub EditVideoFile()
    Dim dataFile As Document    ' this data doc or template
    Dim baseFile As Document    ' file being modified
    Dim baseFileFN As String    ' path\name of file from Adobe
    Dim rgData As Range         ' range of data file containing replacements
    Dim para As Paragraph       ' paragraph in rgData
    Dim rgPattern As Range      ' a range used in baseFile
    Dim replaceText As String   ' current line from this data file
    Dim iterNum As Long         ' number of current line / saved file
    Dim saveFN As String        ' path\base name of saved file

    Set dataFile = ActiveDocument

    MsgBox "Select the data file (*.prtl) to be processed."
    With Dialogs(wdDialogFileOpen)
        .Name = "*.prtl"
        If .Show = -1 Then
            Set baseFile = ActiveDocument   ' file just opened becomes Active
            baseFileFN = baseFile.FullName  ' this path\name will be used to open it again
        Else
            Exit Sub
        End If
    End With

    MsgBox "Select the folder and filename (without numbers) to save as."
    With Dialogs(wdDialogFileSaveAs)
        If .Display = -1 Then   ' just get the path\name, don't actually save
            saveFN = WordBasic.FileNameInfo(.Name, 5) & WordBasic.FileNameInfo(.Name, 4) & "-"
            'MsgBox saveFN
        Else
            Exit Sub
        End If
    End With

    On Error GoTo Errhdl
    iterNum = 1
    Set rgData = dataFile.Range
    rgData.MoveStart unit:=wdParagraph, Count:=1 ' exclude paragraph containing macro button
    For Each para In rgData.Paragraphs
        replaceText = Left(para.Range.Text, Len(para.Range.Text) - 1) ' exclude paragraph mark

        ' force all-caps XYZ to lower-case xyz
        ' to avoid inserting text from data file in all caps
        Set rgPattern = baseFile.Range
        With rgPattern.Find
            .Text = "XYZ"
            .Wrap = wdFindStop
            While .Execute
                rgPattern.Text = LCase(rgPattern.Text)
            Wend
        End With

        ' do the replacement
        baseFile.Range.Find.Execute _
            FindText:="xyz", _
            MatchCase:=False, _
            ReplaceWith:=replaceText, _
            Replace:=wdReplaceAll

        baseFile.SaveAs _
            **FileName:=saveFN & Format(iterNum, "0000") & ".prtl", _**
            FileFormat:=wdFormatText, _
            AddToRecentFiles:=False

        ' close the modified file, then reopen the unmodified base
        baseFile.Close SaveChanges:=wdDoNotSaveChanges
        Set baseFile = Documents.Open(FileName:=baseFileFN, AddToRecentFiles:=False, Visible:=False)

        iterNum = iterNum + 1
    Next para

    baseFile.Close SaveChanges:=wdDoNotSaveChanges
    MsgBox "Done"
    Exit Sub

Errhdl:
    MsgBox "Error " & Err.Number & " at line " & iterNum & vbCr & Err.Description
End Sub

更新

我已经改变了

FileName:=saveFN & Format(iterNum, "0000") & ".prtl", _

到

FileName:=Format(replaceText) & ".prtl", _

它给了我需要的结果但是我需要弄清楚如何删除“/”和“：”。