Solved

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

Posted on 2015-02-24
14
95 Views
Last Modified: 2015-02-25
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-
0
Comment
Question by:BaberA62
  • 6
  • 6
  • 2
14 Comments
 
LVL 59

Expert Comment

by:Saurabh Singh Teotia
ID: 40627673
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
 
LVL 32

Expert Comment

by:Rob Henson
ID: 40627969
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
 
LVL 59

Expert Comment

by:Saurabh Singh Teotia
ID: 40627971
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
Courses: Start Training Online With Pros, Today

Brush up on the basics or master the advanced techniques required to earn essential industry certifications, with Courses. Enroll in a course and start learning today. Training topics range from Android App Dev to the Xen Virtualization Platform.

 
LVL 32

Expert Comment

by:Rob Henson
ID: 40627974
Ooops, so you did; I hadn't spotted that. Thanks
0
 

Author Comment

by:BaberA62
ID: 40628475
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
 
LVL 59

Expert Comment

by:Saurabh Singh Teotia
ID: 40629046
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
 

Author Comment

by:BaberA62
ID: 40630178
Hi Saurabh,
Still having the same problems. The command button still doesn't work as desired.

Can you upload the file please.
Thanks
0
 
LVL 59

Accepted Solution

by:
Saurabh Singh Teotia earned 500 total points
ID: 40630192
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
 

Author Comment

by:BaberA62
ID: 40630288
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
 
LVL 59

Expert Comment

by:Saurabh Singh Teotia
ID: 40630304
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
 

Author Comment

by:BaberA62
ID: 40630529
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
 

Author Comment

by:BaberA62
ID: 40630540
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
 
LVL 59

Expert Comment

by:Saurabh Singh Teotia
ID: 40630564
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
 

Author Comment

by:BaberA62
ID: 40630653
Thanks very much Saurabh, that did the trick.
0

Featured Post

Courses: Start Training Online With Pros, Today

Brush up on the basics or master the advanced techniques required to earn essential industry certifications, with Courses. Enroll in a course and start learning today. Training topics range from Android App Dev to the Xen Virtualization Platform.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
: Microsoft Office Collaborate for free and online versions of Microsoft  Word, Excel, Powerpoint, OneNote, Onedrive , Email, Calendar etc. In short we can say that Microsoft office is a suite of servers, applications and services developed by  Micr…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

776 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question