Sub SendMergedDocByEmail()
    '*** Macro to Automate Merge and Send by Email ***
    Dim fldrname, vsn, defaultpath, strSend
    vsn = Format(Now, "dd-mm-yy")
    
    strSend = InputBox("Enter a Subject line or Click [OK] to accept the Default", "Enter a Subject line", "Your Documents as promised")
    If strSend = "" Then Application.Quit SaveChanges:=wdDoNotSaveChanges

    With ActiveDocument.MailMerge
        .Destination = wdSendToEmail
        .MailAddressFieldName = "CustEmail"
        .MailSubject = strSend
        .SuppressBlankLines = True
        .MailAsAttachment = False
        .MailFormat = wdMailFormatHTML
        With .DataSource
            .ActiveRecord = wdFirstRecord
            defaultpath = .DataFields("DefaultFolder").Value
            fldrname = .DataFields("FolderNo").Value
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        .Execute Pause:=False
    End With
        ActiveDocument.SaveAs FileName:=defaultpath & "\" & fldrname & "\" & _
        ActiveDocument.BuiltInDocumentProperties(wdPropertyTitle) & " " & vsn & ".doc"
    Application.Quit SaveChanges:=wdDoNotSaveChanges
End Sub