Force a SAVEAS with a designated filename

Mr. Chan

It is alright..

Thank you for your time.

good health..

I am sorry. I am also not understand why there is bug in the code. 

Mr. Chan

Thank you for your reply.

Your suggestion is to prevent overwriting the template filename, well and good.

If you would kindly go over what I have written for the "before_save" (pls see below the adjusted codes) - it is doing well if I clicked [x] then save - the only problem there is that the dialog box is appearing twice before saving!

But with the Save Icon - it has a snag ("excel has stopped working" - pls see image) - it will continue though if I ignore the prompt.

Also, I included a Me.Saved (declared true in the workbook_open) condition - that it will just exit when there are no changes made.

My main concern is the dialog box appearing twice before saving and the snag when the Save Icon is used... other than that I think it is workable.

many many thanks and good health

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim file_name As Variant
    Dim FName As String
    If Me.Saved Then
        Cancel = True
        Application.Quit
        Exit Sub
    End If
    ' ThisWorkbook.ChangeFileAccess xlReadWrite - IS NOT WORKING!
    Application.DisplayAlerts = False
    nyr = Format(Sheets("FS").Range("A2"), "yyyy")
    nfty = " for the year " & nyr & ".xlsm"
    FName = Replace(ThisWorkbook.FullName, ".xlsm", "") & nfty
    If ExactWordInString(FName, " for the year ") <> 0 Then
        FName = Replace(ThisWorkbook.FullName, ".xlsm", "")
    End If
    file_name = Application.GetSaveAsFilename(FName, _
         FileFilter:="Excel Files,*.xlsm,All Files,*.*", Title:="Save As File Name")
    If file_name = False Then
        Cancel = True
        'SetAttr ActiveWorkbook, vbReadOnly - NONE OF THESE 3 CODES IS WORKING!
        'ActiveWorkbook.ChangeFileAccess Mode:=xlReadOnly
        'ThisWorkbook.ChangeFileAccess xlReadOnly
        Application.Quit
        Exit Sub
    Else
        If LCase$(Right$(file_name, 5)) <> ".xlsm" Then
            file_name = file_name & ".xlsm"
        End If
        ActiveWorkbook.SaveAs Filename:=file_name
        Application.DisplayAlerts = True
        Application.Quit
    End If
 End Sub

Suppose the template/original file is "Template.xlsm". 

In this case, the condition should be set as 
               If file_name = "Template.xlsm" then

                     Cancel = True

                     Goto label_of_getsaveasfilename

In the cancel portion of the dialog box - 

in exiting - I tried 3 different ways to make the file read-only BUT they all failed... nothing worked!

    If file_name = False Then
       'SetAttr ActiveWorkbook, vbReadOnly
       'ActiveWorkbook.ChangeFileAccess Mode:=xlReadOnly
       'ThisWorkbook.ChangeFileAccess xlReadOnly
       '** the above 3 codes does not work!
        Cancel = true
        Application.Quit
        Exit Sub
    End If

I changed the SUB to before save and It is working all right (for [X] and Save Icon) -

except that the dialog box is appearing twice when saving..

what could be the problem?

many thanks

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

Function ExactWordInString(Text As String, Word As String) As Boolean
    ExactWordInString = " " & UCase(Text) & " " Like "*[!A-Z]" & UCase(Word) & "[!A-Z]*"
End Function
(courtesy of Mr. Rothstein)

Mr. Chan

Yes, I saw that too in your post.

I'll look into it.

many thanks and good health..

Thanks to Mr Damien Rosario's idea, there is an easier way. You may save the file as .xltm-file. It is Excel Macro Enabled Template file. I think this is much easier for the problem.

Mr. Chan

That's a nice concept..

I'll test it and give you feedback soonest.

many many thanks and good health.