'//In ThisDocument module
 
Private Sub Document_Open() 
    DocSave "TestSave" 
End Sub 
 
 '//In a standard module or in Normal.dot for general use
 
 'DocName is the InputBox default if approriate for a standard letter etc.
Sub DocSave(DocName) 
     
    Dim Rec As Integer 
    Dim ToBeSaved As String, MergeFileName As String, JobNo As String, Direct As String 
    Dim Project As String, SaveName As String, SaveAsName As String 
    Dim Length As Integer 
    Dim Message As String, Title As String, Default As String, MyValue As String 
    Dim DataF As Variant, DRecord As String 
     
     'Set Drive\Folder to save to
    Const SaveRoot = "C:\Atest\" 
     
     'Close custom toolbar, delete if not required
    On Error Resume Next 
    CommandBars("Merge File").Visible = False 
     
     'Input box for filename
    Message = "Enter Sub-Folder/Filename for saving" & Chr(13) & _ 
    "NB - New sub-folders will not be created" & Chr(13) & Chr(13) & _ 
    "Press Cancel to proceed without saving." ' Set prompt.
    Title = "Document File Name" ' Set title.
     
     'Create name for document
    SaveName = InputBox(Message, Title, DocName) 
     
     'Remember name to close it later
    MergeFileName = ActiveDocument.Name 
     
     'Skip process if save not required
    If SaveName = "" Then 
        ToBeSaved = "No" 
        Goto MailMergeLine 
    End If 
     
     
     'Close standard toolbars if visible
    On Error Resume Next 
    CommandBars("MailMerge").Visible = False 
    On Error Resume Next 
    CommandBars("Web").Visible = False 
     
     'Obtain SavePath data from first two merge fields
    Rec = 0 
    For Each DataF In _ 
        Documents(MergeFileName).MailMerge.DataSource.DataFields 
        Rec = Rec + 1 
        DRecord = DataF.Value 
        If Rec = 1 Then JobNo = DRecord 
        If Rec = 2 Then Project = DRecord 
        If Rec = 3 Then Goto MailMergeLine 
    Next DataF 
     
     'Create new merged document
MailMergeLine: 
    With ActiveDocument.MailMerge 
        .Destination = wdSendToNewDocument 
        .Execute 
    End With 
     
     'Go to end if save not required
    If ToBeSaved = "No" Then Goto LastLine 
     
     'Create SavePath from obtained data
    Direct = SaveRoot & JobNo & " " & Project & "\" 
     
     'Trim file extension if entered in input box
    Length = Len(SaveName) 
    If Right(SaveName, 4) = ".doc" Then 
        SaveName = Left(SaveName, Length - 4) 
    End If 
     
     'Create name for file
    SaveAsName = SaveName & ".doc" 
     
     'Open Directory for saving
    ChangeFileOpenDirectory Direct 
     
     'Check for previous instances of the SaveName, if found add incremental suffix
    With Application.FileSearch 
        .NewSearch 
        .LookIn = Direct 
        .SearchSubFolders = False 
        .FileName = SaveName & "*" 
        .FileType = msoFileTypeAllFiles 
        If .Execute() > 0 Then 
            SaveAsName = SaveName & "-" & .FoundFiles.Count & ".doc" 
        End If 
    End With 
     
     'ChangeFileOpenDirectory Direct
    ActiveDocument.SaveAs FileName:=SaveAsName 
     
     'Confirm path and filename used
    MsgBox ActiveDocument.Path & Application.PathSeparator & ActiveDocument.Name 
     
LastLine: 
     'Close mailmerge document
    Windows(MergeFileName).Close savechanges:=False 
     
End Sub