Ensure workbook name is not changed

[msgrant]

How can I ensure that a workbook when saved is only saved under its current name therefore not enabling another user to save as a different workbook name. I have used macro to save in two separate locations for security purposes with a specific name and location but if name is changed by save as then backup copy is not saved to same location.

 

[Fausto]

Hey there,

Please paste this into your project and see if it is what you're looking for. One issue is that it will only allow the user to save the file to the same location... It should be relatively easy to strip out the path of the file name in the saveas variable.

I hope this helps, if not please post again!!!

Regards

Fausto Di-Trapani


Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.EnableEvents = False
Cancel = True
Dim saveas As String
If SaveAsUI = True Then
saveas = Application.GetSaveAsFilename(filefilter:="Microsoft Excel Workbook (*.xls), *.xls")
If saveas = "False" Then
Application.EnableEvents = True
Exit Sub
End If
Else
saveas = "Normal"
End If
If saveas = "Normal" Then
Me.Save
Else
If saveas <> ThisWorkbook.Path & "\Sheet Name.xls" Then
MsgBox "Illegal filename!!!" & vbCrLf & "The filename must be Sheet Name.xls", vbCritical, "Error"
Application.EnableEvents = True
Exit Sub
Else
Me.saveas saveas
End If
End If
Me.Saved = True
Application.EnableEvents = True
End Sub

 

[erik.van.geit]

Hello, msgrant,
would this do ?

Private Sub Workbook_BeforeSave(ByVal CheckSaveAs As Boolean, Cancel As Boolean)
    If CheckSaveAs Then
    MsgBox "SaveAs not allowed", 48, "TITLE"
    Cancel = True
    End If
End Sub

kind regards,
Erik

 

[Fausto]

Msgrant,

After initially replying, I thought what if the user changes the file name in explorer, this should stop the buggers from doing this... I have edited the code slightly:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.EnableEvents = False
Cancel = True
Dim saveas As String
If SaveAsUI = True Then
saveas = Application.GetSaveAsFilename(filefilter:="Microsoft Excel Workbook (*.xls), *.xls")
If saveas = "False" Then
Application.EnableEvents = True
Exit Sub
End If
Else
saveas = "Normal"
End If
If saveas = "Normal" Then
If ThisWorkbook.Name <> "Sheet Name.xls" Then
MsgBox "Illegal filename!!!" & vbCrLf & "The filename must be Sheet Name.xls", vbCritical, "Error"
Application.EnableEvents = True
Exit Sub
End If
Else
If saveas <> ThisWorkbook.Path & "\Sheet Name.xls" Then
MsgBox "Illegal filename!!!" & vbCrLf & "The filename must be Sheet Name.xls", vbCritical, "Error"
Application.EnableEvents = True
Exit Sub
Else
Me.saveas saveas
End If
End If
Me.Saved = True
Application.EnableEvents = True
End Sub


Hope this helps

 

[Fausto]

Msgrant

Im really sorry, but I made a little error in my last post... I have edited the code and I have re attached it below. Please excuse the previous error and disregard my previous posts. That little bit of code could have made you cry, it sometimes would (in certain circumstances) not save changes to a file... Once again my appologies!!!

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.EnableEvents = False
Cancel = True
Dim saveas As String
If SaveAsUI = True Then
    saveas = Application.GetSaveAsFilename(filefilter:="Microsoft Excel Workbook (*.xls), *.xls")
    If saveas = "False" Then
        Application.EnableEvents = True
        Exit Sub
    End If
Else
    saveas = "Normal"
End If
If saveas = "Normal" Then
    If ThisWorkbook.Name <> "Sheet Name.xls" Then
        MsgBox "Illegal filename!!!" & vbCrLf & "The filename must be Sheet Name.xls", vbCritical, "Error"
        Application.EnableEvents = True
        Exit Sub
    Else
        Me.Save
    End If
Else
    If saveas <> ThisWorkbook.Path & "\Sheet Name.xls" Then
        MsgBox "Illegal filename!!!" & vbCrLf & "The filename must be Sheet Name.xls", vbCritical, "Error"
        Application.EnableEvents = True
        Exit Sub
    Else
         Me.saveas saveas
    End If
End If
Me.Saved = True
Cancel = False
Application.EnableEvents = True
End Sub