Excel stopped working

The SUB below is working fine when [X] is clicked BUT not when the SAVE Icon is..

a prompt "Excel stopped working" always pops up when saving but when ignored, it continued  saving anyway.  What could be causing this?

many many thanks

The SAVE Icon:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim file_name As Variant
    Dim FName As String
    On Error Resume Next
    Application.DisplayAlerts = False
    nyr = Format(Sheets("FS").Range("A2"), "yyyy")
    nfty = " for the year " & nyr & ".xlsm"
    FName = Replace(ThisWorkbook.FullName, ".xlsm", "") & nfty
    file_name = Application.GetSaveAsFilename(FName, _
                FileFilter:="Excel Files,*.xlsm,All Files,*.*", _
                Title:="Save As File Name")
    If file_name = False Then
        Cancel = True
    Else
        If LCase$(Right$(file_name, 5)) <> ".xlsm" Then
            file_name = file_name & ".xlsm"
        End If
        Application.EnableEvents = False
        ActiveWorkbook.SaveAs Filename:=file_name
        Application.EnableEvents = True
    End If
    On Error GoTo 0
    Application.DisplayAlerts = True
    Application.Quit
End Sub