Hi,
I have been working for quite some time on a code that would protect a worksheet from printing/copying/pasting/saving and force people to enable macros. It works perfectly fine with my computer running Excel 2016 and works with my colleagues who also have Excel 2016 however when I sent that to our client who's running Excel 2010, nothing works. There are no error messages but the macros just don't do what they are supposed to do. Any hel
Here is the code:
with a module:
I have been working for quite some time on a code that would protect a worksheet from printing/copying/pasting/saving and force people to enable macros. It works perfectly fine with my computer running Excel 2016 and works with my colleagues who also have Excel 2016 however when I sent that to our client who's running Excel 2010, nothing works. There are no error messages but the macros just don't do what they are supposed to do. Any hel
Here is the code:
Code:
Option Explicit[/I][I]Const WelcomePage = "Macros"[/I]
[I]Private Sub Workbook_BeforeClose(Cancel As Boolean)[/I]
[I]If ActiveWorkbook.ReadOnly Then[/I]
[I]Call ToggleCutCopyAndPaste(True)[/I]
[I]End If[/I]
[I] 'Turn off events to prevent unwanted loops[/I]
[I]Application.EnableEvents = False[/I]
[I] 'Evaluate if workbook is saved and emulate default propmts[/I]
[I] With ThisWorkbook[/I]
[I] If Not .Saved Then[/I]
[I] ActiveWorkbook.Close savechanges:=False[/I]
[I] Application.EnableEvents = True[/I]
[I] End If[/I]
[I] End With[/I]
[I]Dim sht As Worksheet, csheet As Worksheet[/I]
[I]Application.ScreenUpdating = False[/I]
[I]Set csheet = ActiveSheet[/I]
[I]For Each sht In ActiveWorkbook.Worksheets[/I]
[I] If sht.Visible Then[/I]
[I] sht.Activate[/I]
[I] Range("A1").Select[/I]
[I] ActiveWindow.ScrollRow = 1[/I]
[I] ActiveWindow.ScrollColumn = 1[/I]
[I] End If[/I]
[I]Next sht[/I]
[I]csheet.Activate[/I]
[I]Application.ScreenUpdating = True[/I]
[I]End Sub[/I]
[I]Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)[/I]
[I]If ActiveWorkbook.ReadOnly Then[/I]
[I]MsgBox "File was opened as read-only and cannot be saved"[/I]
[I]Cancel = True[/I]
[I]ActiveWorkbook.Close savechanges:=False[/I]
[I]End If[/I]
[I]'Turn off events to prevent unwanted loops[/I]
[I]Application.EnableEvents = False[/I]
[I]'Call customized save routine and set workbook's saved property to true(To cancel regular saving)[/I]
[I]Call CustomSave(SaveAsUI)[/I]
[I]Cancel = True[/I]
[I] 'Turn events back on an set saved property to true[/I]
[I]Application.EnableEvents = True[/I]
[I]ThisWorkbook.Saved = True[/I]
[I]End Sub[/I]
[I]Private Sub Workbook_Open()[/I]
[I] 'Unhide all worksheets[/I]
[I] Application.ScreenUpdating = False[/I]
[I] Call ShowAllSheets[/I]
[I] Application.ScreenUpdating = True[/I]
[I]Application.Goto ThisWorkbook.Sheets("Database menu").Range("A1"), True[/I]
[I]If ActiveWorkbook.ReadOnly Then[/I]
[I]Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",False)"[/I]
[I]ActiveWindow.DisplayWorkbookTabs = False[/I]
[I]Call ToggleCutCopyAndPaste(False)[/I]
[I]End If[/I]
[I]End Sub[/I]
[I]Private Sub CustomSave(Optional SaveAs As Boolean)[/I]
[I] Dim ws As Worksheet, aWs As Worksheet, newFname As String[/I]
[I] 'Turn off screen flashing[/I]
[I] Application.ScreenUpdating = False[/I]
[I] 'Record active worksheet[/I]
[I] Set aWs = ActiveSheet[/I]
[I] 'Hide all sheets[/I]
[I] Call HideAllSheets[/I]
[I] 'Save workbook directly or prompt for saveas filename[/I]
[I] If SaveAs = True Then[/I]
[I] newFname = Application.GetSaveAsFilename( _[/I]
[I] fileFilter:="Excel Files (*.xls), *.xls")[/I]
[I] If Not newFname = "False" Then ThisWorkbook.SaveAs newFname[/I]
[I] Else[/I]
[I] ThisWorkbook.Save[/I]
[I] End If[/I]
[I] 'Restore file to where user was[/I]
[I] Call ShowAllSheets[/I]
[I] aWs.Activate[/I]
[I] 'Restore screen updates[/I]
[I] Application.ScreenUpdating = True[/I]
[I]End Sub[/I]
[I]Private Sub HideAllSheets()[/I]
[I] 'Hide all worksheets except the macro welcome page[/I]
[I]Dim ws As Worksheet[/I]
[I]Worksheets(WelcomePage).Visible = xlSheetVisible[/I]
[I]For Each ws In ThisWorkbook.Worksheets[/I]
[I]If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden[/I]
[I]Next ws[/I]
[I]Worksheets(WelcomePage).Activate[/I]
[I]End Sub[/I]
[I]Private Sub ShowAllSheets()[/I]
[I] 'Show all worksheets except the macro welcome page[/I]
[I] Dim ws As Worksheet[/I]
[I] For Each ws In ThisWorkbook.Worksheets[/I]
[I] If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible[/I]
[I] Next ws[/I]
[I] Worksheets(WelcomePage).Visible = xlSheetVeryHidden[/I]
[I]End Sub[/I]
[I]Private Sub Workbook_BeforePrint(Cancel As Boolean)[/I]
[I]If ActiveWorkbook.ReadOnly Then[/I]
[I]Cancel = True[/I]
[I]MsgBox "Sorry, you cannot print this file", vbInformation[/I]
[I]End If[/I]
[I]End Sub[/I]
[I]Private Sub Workbook_Activate()[/I]
[I]If ActiveWorkbook.ReadOnly Then[/I]
[I]Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",False)"[/I]
[I]ActiveWindow.DisplayWorkbookTabs = False[/I]
[I]Call ToggleCutCopyAndPaste(False)[/I]
[I]End If[/I]
[I]End Sub[/I]
[I]Private Sub Workbook_Deactivate()[/I]
[I]If ActiveWorkbook.ReadOnly Then[/I]
[I]Call ToggleCutCopyAndPaste(True)[/I]
[I]End If[/I]
[I]End Sub[/I]
with a module:
Code:
[I]Option Explicit[/I]
[I]Sub ToggleCutCopyAndPaste(Allow As Boolean)[/I]
[I] 'Activate/deactivate cut, copy, paste and pastespecial menu items[/I]
[I] Call EnableMenuItem(21, Allow) ' cut[/I]
[I] Call EnableMenuItem(19, Allow) ' copy[/I]
[I] Call EnableMenuItem(22, Allow) ' paste[/I]
[I] Call EnableMenuItem(755, Allow) ' pastespecial[/I]
[I] 'Activate/deactivate drag and drop ability[/I]
[I] Application.CellDragAndDrop = Allow[/I]
[I] 'Activate/deactivate cut, copy, paste and pastespecial shortcut keys[/I]
[I] With Application[/I]
[I] Select Case Allow[/I]
[I] Case Is = False[/I]
[I] .OnKey "^c", "CutCopyPasteDisabled"[/I]
[I] .OnKey "^v", "CutCopyPasteDisabled"[/I]
[I] .OnKey "^x", "CutCopyPasteDisabled"[/I]
[I] .OnKey "+{DEL}", "CutCopyPasteDisabled"[/I]
[I] .OnKey "^{INSERT}", "CutCopyPasteDisabled"[/I]
[I] Case Is = True[/I]
[I] .OnKey "^c"[/I]
[I] .OnKey "^v"[/I]
[I] .OnKey "^x"[/I]
[I] .OnKey "+{DEL}"[/I]
[I] .OnKey "^{INSERT}"[/I]
[I] End Select[/I]
[I] End With[/I]
[I]End Sub[/I]
[I]Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean)[/I]
[I] 'Activate/Deactivate specific menu item[/I]
[I] Dim cBar As CommandBar[/I]
[I] Dim cBarCtrl As CommandBarControl[/I]
[I] For Each cBar In Application.CommandBars[/I]
[I] If cBar.Name <> "Clipboard" Then[/I]
[I] Set cBarCtrl = cBar.FindControl(ID:=ctlId, recursive:=True)[/I]
[I] If Not cBarCtrl Is Nothing Then cBarCtrl.Enabled = Enabled[/I]
[I] End If[/I]
[I] Next[/I]
[I]End Sub[/I]
[I]Sub CutCopyPasteDisabled()[/I]
[I] 'Inform user that the functions have been disabled[/I]
[I] MsgBox "Cutting, copying and pasting have been disabled in this file"[/I]
[I]End Sub