Disable Save and save as in excel 2010 and only allow save via macro

I have a macro which when used saves the file with Rev no/ Date/ and time added to the file name. It also creates a folder called superseded which stores the file separately. I need the macro to disable save, save as and control+s and users be informed that they must save via the macro button on the spreadsheet.

I have attached the file with the macro in it and would be grateful for the above additions to the macro.
STATUS-OF-CYCLE-PARKING-ON-ESTATES---24-
BaberA62Asked:
Who is Participating?
 
Saurabh Singh TeotiaCommented:
I just run the macro and it worked for me...

Here is the code and workbook for your reference:-

Public dtsv As Boolean

Sub SaveNumberedVersion()

    Dim strVer As String
    Dim strDate As String
    Dim strPath As String
    Dim strNewPath As String
    Dim strFile As String
    Dim strOldFilePath As String
    Dim oVars As Variant
    Dim strFileType As Integer
    Dim strVersionName As String
    Dim intPos As Long
    Dim sExt As String
    Dim wb As Workbook
    Dim strNewFolderName As String
       
    Set oVars = ActiveWorkbook.CustomDocumentProperties
    
    strDate = Format((Date), "dd MMM yyyy")
    strOldFilePath = ActiveWorkbook.FullName
    strNewFolderName = "Superseded"
      
    strPath = ActiveWorkbook.Path
    
        If Len(Dir(strPath & "\" & strNewFolderName, vbDirectory)) = 0 Then
            MkDir (strPath & "\" & strNewFolderName)
        End If
        
               
    With ActiveWorkbook
        On Error GoTo CancelledByUser
        If Len(.Path) = 0 Then 'No path means document not saved
           dtsv = True
            .Save 'So save it
        End If
        strPath = .Path 'Get path
        strFile = .Name 'Get document name
    
  
    End With
    
 
    
    intPos = InStr(strFile, " - ") 'Mark the version number
    sExt = Right(strFile, Len(strFile) - InStrRev(strFile, ".xl"))
    
       
    
    If intPos = 0 Then 'No version number
        intPos = InStrRev(strFile, ".xl") 'Mark the extension instead
    End If
    
    strFile = Left(strFile, intPos - 1) 'Strip the extension or version number
    
    Select Case LCase(sExt) 'Determine file type by extension
        Case Is = "xlsx"
            strFileType = 51
        Case Is = "xlsm"
            strFileType = 52
        Case Is = "xlsb"
            strFileType = 50
        Case Is = "xls"
            strFileType = 56
        'Case Is = "dotx"
            'strFileType = 14
        'Case Is = "dotm"
            'strFileType = 15
    End Select

Start: 'Get Registry Data
    On Error Resume Next 'No entry in registry will flag an error
    strVer = oVars("varVersion").Value
    On Error GoTo 0
    If strVer = "" Then 'Variable does not exist
        strVer = "0"
        ActiveWorkbook.CustomDocumentProperties.Add Name:="varVersion", LinkToContent:=False, Type:=msoPropertyTypeString, Value:="0"
    End If
    strVer = Val(strVer) + 1 'Increment number
    oVars("varVersion").Value = strVer
    'Define the new version filename change version in line below to Rev if required
    strVersionName = strPath & "\" & strFile & " - " & strDate & _
    " - Rev " & Format(Val(strVer), "00# ") _
    & Format(Time(), "hh-mm") & Chr(46) & sExt
    
    
   strNewPath = strPath & "\" & strNewFolderName & "\" & strFile & " - " & strDate & _
    " - Rev " & Format(Val(strVer), "00# ") _
    & Format(Time(), "hh-mm") & Chr(46) & sExt
    
    'and save a copy of the file with that name
       dtsv = True
    ActiveWorkbook.SaveAs strNewPath
    ActiveWorkbook.SaveAs strVersionName
    
    Kill strOldFilePath
    
    Exit Sub

CancelledByUser: 'Error handler
    MsgBox "Cancelled By User", , "Operation Cancelled"
End Sub

Open in new window


Let me know if you need any further help on this..

Saurabh...
STATUS-OF-CYCLE-PARKING-ON-ESTATES---24-
0
 
Saurabh Singh TeotiaCommented:
Use the following code...

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If dtsv = False Then
        MsgBox "You can only save this workbook by macro"
        Cancel = True
    End If

End Sub

Open in new window


Also i put this code in thisworkbook module and comment it out since it wont let  me save without macro..uncomment it and this will do what you are looking for...

Saurabh..
STATUS-OF-CYCLE-PARKING-ON-ESTATES---24-
0
 
Rob HensonFinance AnalystCommented:
Are you not going to get into a vicious circle?

When the Save Macro is run, it will run the BeforeSave event and will cancel the Save.

The Save routine could set a Flag and have the BeforeSave event check that flag before cancelling the save.

Thanks
Rob H
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

 
Saurabh Singh TeotiaCommented:
Rob H,

I took care in the enclosed code file if where im declaring dtsv as public and setting it to true when the macro is triggered.. :-)

Saurabh...
0
 
Rob HensonFinance AnalystCommented:
Ooops, so you did; I hadn't spotted that. Thanks
0
 
BaberA62Author Commented:
Ok I have placed this macro in thisworkbook module. However, when I use the command button which runs the save macro it shows the error message which says that "you can only save this workbook by macro".  After clicking the ok button a few times the microsoft visual basic window pops up which gives a run-time error '70' when I then click on the debug button it shows the error being on the line "kill strOldFilePath"
Any ideas why this is happening?
0
 
Saurabh Singh TeotiaCommented:
Did you made changes in your macro as well..since i made changes in your code too..

Download the file which i uploaded..add the extension .xlsm at the file post downloading and you will be able to see the code as i changed your code too..here is your copy of the code...

Public dtsv As Boolean

Sub SaveNumberedVersion()

    Dim strVer As String
    Dim strDate As String
    Dim strPath As String
    Dim strNewPath As String
    Dim strFile As String
    Dim strOldFilePath As String
    Dim oVars As Variant
    Dim strFileType As Integer
    Dim strVersionName As String
    Dim intPos As Long
    Dim sExt As String
    Dim wb As Workbook
    Dim strNewFolderName As String
       
    Set oVars = ActiveWorkbook.CustomDocumentProperties
    
    strDate = Format((Date), "dd MMM yyyy")
    strOldFilePath = ActiveWorkbook.FullName
    strNewFolderName = "Superseded"
      
    strPath = ActiveWorkbook.Path
    
        If Len(Dir(strPath & "\" & strNewFolderName, vbDirectory)) = 0 Then
            MkDir (strPath & "\" & strNewFolderName)
        End If
        
               
    With ActiveWorkbook
        On Error GoTo CancelledByUser
        If Len(.Path) = 0 Then 'No path means document not saved
        dtsv = True
            .Save 'So save it
        End If
        strPath = .Path 'Get path
        strFile = .Name 'Get document name
    
  
    End With
    
    
    
    intPos = InStr(strFile, " - ") 'Mark the version number
    sExt = Right(strFile, Len(strFile) - InStrRev(strFile, ".xl"))
    
       
    
    If intPos = 0 Then 'No version number
        intPos = InStrRev(strFile, ".xl") 'Mark the extension instead
    End If
    
    strFile = Left(strFile, intPos - 1) 'Strip the extension or version number
    
    Select Case LCase(sExt) 'Determine file type by extension
        Case Is = "xlsx"
            strFileType = 51
        Case Is = "xlsm"
            strFileType = 52
        Case Is = "xlsb"
            strFileType = 50
        Case Is = "xls"
            strFileType = 56
        'Case Is = "dotx"
            'strFileType = 14
        'Case Is = "dotm"
            'strFileType = 15
    End Select

Start: 'Get Registry Data
    On Error Resume Next 'No entry in registry will flag an error
    strVer = oVars("varVersion").Value
    On Error GoTo 0
    If strVer = "" Then 'Variable does not exist
        strVer = "0"
        ActiveWorkbook.CustomDocumentProperties.Add Name:="varVersion", LinkToContent:=False, Type:=msoPropertyTypeString, Value:="0"
    End If
    strVer = Val(strVer) + 1 'Increment number
    oVars("varVersion").Value = strVer
    'Define the new version filename change version in line below to Rev if required
    strVersionName = strPath & "\" & strFile & " - " & strDate & _
    " - Rev " & Format(Val(strVer), "00# ") _
    & Format(Time(), "hh-mm") & Chr(46) & sExt
    
    
   strNewPath = strPath & "\" & strNewFolderName & "\" & strFile & " - " & strDate & _
    " - Rev " & Format(Val(strVer), "00# ") _
    & Format(Time(), "hh-mm") & Chr(46) & sExt
    
    'and save a copy of the file with that name
    ActiveWorkbook.SaveAs strNewPath
    ActiveWorkbook.SaveAs strVersionName
    
    Kill strOldFilePath
    
    Exit Sub

CancelledByUser: 'Error handler
    MsgBox "Cancelled By User", , "Operation Cancelled"
End Sub

Open in new window

0
 
BaberA62Author Commented:
Hi Saurabh,
Still having the same problems. The command button still doesn't work as desired.

Can you upload the file please.
Thanks
0
 
BaberA62Author Commented:
Sorry about this Saurabh, but I can see only the xml docs ... don't know how to look at these as spreadsheets. Please can you post the xlsm file. Thanks.
0
 
Saurabh Singh TeotiaCommented:
Yeah it's an xlsm file only..their is some problem in the EE that it's not showing the correct extension..just download the file and at the end add .xlsm in the file name and you will be good post that...

Saurabh...
0
 
BaberA62Author Commented:
Only thing I found is that the disable command works just once. Subsequently it allowed me to use both the save and saveas commands ...
0
 
BaberA62Author Commented:
Saurabh, when file is first opened, and the user tries save or saveas the macro does not allow the user to save the file, however, once the file has been saved using the command button. After this when the user tries the save and saveas commands they allow the user to save the file.
0
 
Saurabh Singh TeotiaCommented:
Intresting..because you are exit the sub that's the reason..

Do this..right before exit sub which you have at the end before add this line...

dtsv = False

Open in new window


This will take care of that...
0
 
BaberA62Author Commented:
Thanks very much Saurabh, that did the trick.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.