Сохранение Word-файла с именем из текста

Public Sub SaveMyDocument()
Dim FD1 As FileDialog, FD2 As FileDialog
Dim FName As String, Fold As String, i As Long, Doc As Document
Dim Shp As Shape
    Set FD1 = Application.FileDialog(msoFileDialogFilePicker)
        With FD1
            .AllowMultiSelect = True
            .ButtonName = "Пересохранить"
            With .Filters
                .Clear
                .Add "Все файлы", "*.*"
                .Add "Файлы Word", "*.doc, *.docx"
             End With
             .Title = "Пересохранение файлов"
        End With
    FD1.Show
    Set FD2 = Application.FileDialog(msoFileDialogFolderPicker)
        With FD2
        .ButtonName = "Выбрать"
        .Title = "Выбор папки сохранения"
        End With
    FD2.Show
        Fold = FD2.SelectedItems(1)
        If FD1.SelectedItems.Count = 0 Then Exit Sub
            For i = 1 To FD1.SelectedItems.Count
                Set Doc = Documents.Open(FD1.SelectedItems(i))
                    For Each Shp In Doc.Shapes
                        Shp.Select
                        If Shp.Type = msoTextBox Then
                             Selection.Find.ClearFormatting
                            Selection.Find.Replacement.ClearFormatting
                                With Selection.Find
                                    .Text = "G00([0-9]{1;})"
                                    .Replacement.Text = ""
                                    .Forward = True
                                    .Wrap = wdFindContinue
                                    .MatchWildcards = True
                                    .Execute
                                        If .Found = True Then
                                            Doc.SaveAs2 = Fold & "\" & Selection.Text & "*.doc"
                                            Doc.Close
                                            Exit For
                                        End If
                                End With
                            End If
                    Next Shp
        Next i
End Sub

Public Sub Test()
Dim FD As String
Dim FName As String
Dim Path As String
Dim Shp As Shape
   Set Doc = ActiveDocument
         FD = [здесь указывается папка сохранения]
                    For Each Shp In Doc.Shapes
                        Shp.Select
                        If Shp.Type = msoTextBox Then
                             Selection.Find.ClearFormatting
                             Selection.Find.Replacement.ClearFormatting
                                With Selection.Find
                                    .Text = "G00([0-9]{1;})"
                                    .Replacement.Text = ""
                                    .Forward = True
                                    .Wrap = wdFindContinue
                                    .MatchWildcards = True
                                    .Execute
                                        If .Found = True Then
                                            FName = Selection
                                            Path = FD & "\" & FName & ".doc"
                                            Doc.SaveAs2 Path
                                            Doc.Close
                                            Exit Sub
                                        End If
                                End With
                            End If
                  Next Shp
End Sub