VBA To Save As

[ReeceC952]

Hi,

I have a template that I would like users to fill out and then save as a new file name. Quite a lot of the users aren't great with excel and I don't want them to just save the template, I need them to save as. Therefore, I'd like to have a button with an assigned macro that they can press rather than manually saving it themselves.

I would like to have the macro open up the save as dialog box that's already in a specified directory and only has the option to save the workbook as macro-enabled. Does anyone know if this is possible to do in VBA?

Thanks,

Reece

 

[Boller]

Is your template an .xltm file?

 

[ReeceC952]

No it's .xlsm I think - a macro-enabled workbook

 

[Boller]

I would suggest that you use an .xltm file instead, from which the users can open an .xlsm file.
Code can be written to prevent users from opening the .xltm and allow opening as an .xlsm only.
This will then preserve the template.
Do you want to do this?

Thereafter, can think about writing code to save files to a specific path only, and as .xlsm only.

 

[ReeceC952]

Yeah that sounds good - thanks for the help!

 

[Boller]

Try this.

Put in the ThisWorkbook module of the template file (.xltm) :

Private Sub Workbook_Open()
'Check whether the WB is the template
Dim pw$
If ActiveWorkbook.FileFormat = 53 Then
    pw = InputBox(prompt:="The file opened is the Template file (with the extension "".xltm"")." _
         & " Enter password to continue.")
    If pw <> "Password" Then 'Change password as required
        MsgBox ("This file will be closed." & Chr(13) & Chr(13) _
                & "Re-open it as an "".xlsm"" file by double clicking it in Windows explorer.")
        ThisWorkbook.Close
    End If
End If
End Sub

This will prevent users from opening the template file unless they have the password.
All they will be able to open is an .xlsm workbook from the template.

Advise if you still need to restrict saving workbooks to a specific path, and as .xlsm only.

 

[Boller]

Advise if you still need to restrict saving workbooks to a specific path, and as .xlsm only.

I did this anyway for my own records.
Put this in the template file's ThisWorkbook module :

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'NOTES : _
(1)This procedure is for new workbooks opened from the specified template file. _
   It opens the SaveAs dialog box at the required folder and with the _
   required file type selected, and saves as the name input by the user. _
(2)For it to work properly, go to File>Options>Save>Save Worbooks and select _
   "Don't show the Backstage when opening and saving files". _
(3)The names of workbooks created from the template must not start with _
   the name of the template.
Dim tName$, dr$, pth$, newFileType$, newWB As Variant
'Store template name, new workbook file type, and folder path _
*** Change as required :
On Error Resume Next
tName = "SaveAsTemplate"    'Template name
newFileType = "*.xlsm"      'New workbook file type
pth = "D:\Documents\Cmlvm"  'Folder path
ChDrive pth
ChDir pth
On Error GoTo 0
'Exit if the WB is the template
If ThisWorkbook.FileFormat = 53 Then Exit Sub
'Check if the WB has the template name (if so, assume it is a new WB) - see Note(3).
If Left(ThisWorkbook.Name, Len(tName)) = tName Then
    'Disable event procedures
    Application.EnableEvents = False
    Do
        'Open the SaveAs file dialog
        newWB = Application.GetSaveAsFilename _
            (InitialFileName:="", FileFilter:="Excel Files (" & newFileType & ")," & newFileType)
        'Exit if no file name input
        If newWB = False Then Exit Do
        On Error Resume Next
        'Save the file with the new name
        ThisWorkbook.SaveAs Filename:=newWB, FileFormat:=52
        'Check if something wrong with the input file name
        If Err = 0 Then
            On Error GoTo 0
            Exit Do
        End If
    'Loop if something wrong with the file name
    Loop
    'Enable event procedures
    Application.EnableEvents = True
    'Re-set the save command
    Cancel = True
End If
End Sub

If anyone knows how to programmatically set "Don't show the Backstage when opening and saving files", please post.

 

[Boller]

Just spotted a mistake in the code. Revised version :

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'NOTES : _
(1)This procedure is for new workbooks opened from the specified template file. _
   It opens the SaveAs dialog box at the required folder and with the _
   required file type selected, and saves as the name input by the user. _
(2)To avoid displaying the Backstage window when the procedure is run, _
   go to File>Options>Save>Save Worbooks and select _
   "Don't show the Backstage when opening and saving files". _
(3)The names of workbooks created from the template must not start with _
   the name of the template.
Dim tName$, dr$, pth$, newFileType$, newWB As Variant
'Store template name, new workbook file type, and folder path _
*** Change as required :
tName = "SaveAsTemplate"    'Template name
newFileType = "*.xlsm"      'New workbook file type
pth = "D:\Documents\Cmlvm"  'Folder path
'Exit if the WB is the template
If ThisWorkbook.FileFormat = 53 Then Exit Sub
'Check if the WB has the template name (if so, assume it is a new WB) - see Note(3).
If Left(ThisWorkbook.Name, Len(tName)) = tName Then
    'Disable event procedures
    Application.EnableEvents = False
    'Set the folder path
    On Error Resume Next
    ChDrive pth
    ChDir pth
    On Error GoTo 0
    Do
        'Open the SaveAs file dialog
        newWB = Application.GetSaveAsFilename _
            (InitialFileName:="", FileFilter:="Excel Files (" & newFileType & ")," & newFileType)
        'Exit if no file name input
        If newWB = False Then
            'Re-set the save command
            Cancel = True
            Exit Do
        End If
        On Error Resume Next
        'Save the file with the new name
        ThisWorkbook.SaveAs Filename:=newWB, FileFormat:=52
        'Check if something wrong with the input file name
        If Err = 0 Then
            On Error GoTo 0
            'Re-set the save command
            Cancel = True
            Exit Do
        End If
    'Loop if something wrong with the file name
    Loop
    'Enable event procedures
    Application.EnableEvents = True
End If
End Sub