Solved

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

Posted on 2015-02-24
14
90 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
Comment Utility
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 31

Expert Comment

by:Rob Henson
Comment Utility
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
Comment Utility
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
 
LVL 31

Expert Comment

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

Author Comment

by:BaberA62
Comment Utility
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
Comment Utility
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
Comment Utility
Hi Saurabh,
Still having the same problems. The command button still doesn't work as desired.

Can you upload the file please.
Thanks
0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 59

Accepted Solution

by:
Saurabh Singh Teotia earned 500 total points
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
Thanks very much Saurabh, that did the trick.
0

Featured Post

Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

Join & Write a Comment

Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

744 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

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now