Macro for Always saveas option

maheshrk81

Board Regular
Joined
Jan 5, 2010
Messages
153
Hi All,

I save a file is some path, where the file is saved as Read-only recommended. But few of then are opening as write and overwriting the file.
Can i have a macro, when the user saves the file, it should pop-up the msg saying they are not allowed to save the file in that path and show the SAVEAS option. Please help.

Thanks,
Mahi
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Can try something like this, which goes in ThisWorkbook module:

Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Dim strInitialFilename As String
  Dim strExtensionName As String
  Dim strFileFilter As String
  Dim vntSaveAsFilename
  On Error GoTo ErrorHandler
  If Me.Path <> vbNullString Then
    Cancel = True
    Application.EnableEvents = False
    strInitialFilename = Replace(Me.FullName, Me.Name, "Copy of " & Me.Name)
    strExtensionName = CreateObject("Scripting.FileSystemObject").GetExtensionName(Me.Name)
    strFileFilter = "Excel Files (*." & strExtensionName & "), *." & strExtensionName
    vntSaveAsFilename = Application.GetSaveAsFilename(strInitialFilename, strFileFilter)
    If vntSaveAsFilename = False Then GoTo ExitHandler
    Me.SaveAs vntSaveAsFilename
  End If
ExitHandler:
  On Error Resume Next
  Application.EnableEvents = True
  Exit Sub
ErrorHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitHandler
End Sub
 
Upvote 0
Hi ParamRay,

Thanks you, this code worked perfect. But can we set-up only once particular Path? Like, i have a SharePoint site path where i save the file and i don't anyone to overwrite the file there. The users can download to local drive and do the changes. Is that possible through macro?

Thanks,
Mahesh

Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Dim strInitialFilename As String
  Dim strExtensionName As String
  Dim strFileFilter As String
  Dim vntSaveAsFilename
  On Error GoTo ErrorHandler
  If Me.Path <> vbNullString Then
    Cancel = True
    Application.EnableEvents = False
    strInitialFilename = Replace(Me.FullName, Me.Name, "Copy of " & Me.Name)
    strExtensionName = CreateObject("Scripting.FileSystemObject").GetExtensionName(Me.Name)
    strFileFilter = "Excel Files (*." & strExtensionName & "), *." & strExtensionName
    vntSaveAsFilename = Application.GetSaveAsFilename(strInitialFilename, strFileFilter)
    If vntSaveAsFilename = False Then GoTo ExitHandler
    Me.SaveAs vntSaveAsFilename
  End If
ExitHandler:
  On Error Resume Next
  Application.EnableEvents = True
  Exit Sub
ErrorHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitHandler
End Sub
[/QUOTE]
 
Upvote 0
Hi,

Can we make a default Save as option to Desktop. Currently it is showing the same exiting path.

Thanks,
Mahi
 
Upvote 0

Forum statistics

Threads
1,213,484
Messages
6,113,923
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top