Solved: Combine VB Code

[Frank Rizzo]

Hello all,

Below are three codes; one that forces the user of the workbook to enable the macros and the other to prevent copy, paste, cut etc.

I currently get an error when closing saving changes because the workbook is protected and there is no coding to remove the protection before making the changes. I believe it is where the sheets are hidden area of the code so I will need something that removes the workbook protection to allow those sheets to be hidden or very hidden as the case may be and re protect the book on close.

My password is ‘!@#$1234abcd’

Also, there are two workbook open and close events below that conflict with each other so both codes below need to be combined perhaps calling the ToggleCutCopyAndPaste in another part of the code rather than separate and with the next request; I wish to have part of the code prevent anyone saving this file by either opening and saving as or simply right clicking on the closed file and saving or any other way possible of saving this file as anything other than a 2003 file. It must never be allowed to be saved in any way other than as a 2003 file.

Lastly, where to place the code (ie: ThisWorkbook / Standard Module / Class etc.)

I am going to thank you in advance for any effort you may place trying to get this sorted. This is making my life a nightmare trying to figure this out with my lack of knowledge in vb.

Thank you so much.

Ps. Simply put; I wish to open, must enable the macros, must not be able to copy, cut, paste etc. when open, must not be able to save as anything other than 2003 .xls extension. Must not be able to copy the file on my desktop an save as anything other than 2003 excel workbook.


-Frank

[vba]
Option Explicit

Const WelcomePage = "Macros"

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False

'Evaluate if workbook is saved and emulate default propmts
With ThisWorkbook
If Not .Saved Then
Select Case MsgBox("Do you want to save the changes you made to '" & .Name & "'?", _
vbYesNoCancel + vbExclamation)
Case Is = vbYes
'Call customized save routine
Call CustomSave
Case Is = vbNo
'Do not save
Case Is = vbCancel
'Set up procedure to cancel close
Cancel = True
End Select
End If

'If Cancel was clicked, turn events back on and cancel close,
'otherwise close the workbook without saving further changes
If Not Cancel = True Then
.Saved = True
Application.EnableEvents = True
.Close savechanges:=False
Else
Application.EnableEvents = True
End If
End With
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False

'Call customized save routine and set workbook's saved property to true
'(To cancel regular saving)
Call CustomSave(SaveAsUI)
Cancel = True

'Turn events back on an set saved property to true
Application.EnableEvents = True
ThisWorkbook.Saved = True
End Sub

Private Sub Workbook_Open()
'Unhide all worksheets
Application.ScreenUpdating = False
Call ShowAllSheets
Application.ScreenUpdating = True
End Sub

Private Sub CustomSave(Optional SaveAs As Boolean)
Dim ws As Worksheet, aWs As Worksheet, newFname As String
'Turn off screen flashing
Application.ScreenUpdating = False

'Record active worksheet
Set aWs = ActiveSheet

'Hide all sheets
Call HideAllSheets

'Save workbook directly or prompt for saveas filename
If SaveAs = True Then
newFname = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.xls), *.xls")
If Not newFname = "False" Then ThisWorkbook.SaveAs newFname
Else
ThisWorkbook.Save
End If

'Restore file to where user was
Call ShowAllSheets
aWs.Activate

'Restore screen updates
Application.ScreenUpdating = True
End Sub

Private Sub HideAllSheets()
'Hide all worksheets except the macro welcome page
Dim ws As Worksheet

Worksheets(WelcomePage).Visible = xlSheetVisible

For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
Next ws

Worksheets(WelcomePage).Activate
End Sub

Private Sub ShowAllSheets()
'Show all worksheets except the macro welcome page

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
Next ws

Worksheets(WelcomePage).Visible = xlSheetVeryHidden
End Sub
[/vba]

[vba]
Option Explicit
Private Sub Workbook_Activate()
Call ToggleCutCopyAndPaste(False)
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call ToggleCutCopyAndPaste(True)
End Sub

Private Sub Workbook_Deactivate()
Call ToggleCutCopyAndPaste(True)
End Sub

Private Sub Workbook_Open()
Call ToggleCutCopyAndPaste(False)
End Sub
[/vba]

[vba]
Option Explicit

Sub ToggleCutCopyAndPaste(Allow As Boolean)
'Activate/deactivate cut, copy, paste and pastespecial menu items
Call EnableMenuItem(21, Allow) ' cut
Call EnableMenuItem(19, Allow) ' copy
Call EnableMenuItem(22, Allow) ' paste
Call EnableMenuItem(755, Allow) ' pastespecial

'Activate/deactivate drag and drop ability
Application.CellDragAndDrop = Allow

'Activate/deactivate cut, copy, paste and pastespecial shortcut keys
With Application
Select Case Allow
Case Is = False
.OnKey "^c", "CutCopyPasteDisabled"
.OnKey "^v", "CutCopyPasteDisabled"
.OnKey "^x", "CutCopyPasteDisabled"
.OnKey "+{DEL}", "CutCopyPasteDisabled"
.OnKey "^{INSERT}", "CutCopyPasteDisabled"
Case Is = True
.OnKey "^c"
.OnKey "^v"
.OnKey "^x"
.OnKey "+{DEL}"
.OnKey "^{INSERT}"
End Select
End With
End Sub

Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean)
'Activate/Deactivate specific menu item
Dim cBar As CommandBar
Dim cBarCtrl As CommandBarControl
For Each cBar In Application.CommandBars
If cBar.Name <> "Clipboard" Then
Set cBarCtrl = cBar.FindControl(ID:=ctlId, recursive:=True)
If Not cBarCtrl Is Nothing Then cBarCtrl.Enabled = Enabled
End If
Next
End Sub

Sub CutCopyPasteDisabled()
'Inform user that the functions have been disabled
MsgBox "Sorry! Cutting, copying and pasting have been disabled in this workbook!"
End Sub
[/vba]

[Frank Rizzo]

Good morning all,

I found this code and wanted to place it here in an attempt to assist anyone in my original post. This should work for the save as part although not sure if it would work for simply right clicking on the file and copying itself to the desktop. Not sure if it would force the save in that instance to be 2003 format.

Also, I feel bad for not saying hello straight off the bat and come in as a new member and ask for this and that without first saying hello. Sorry, I am just at my wits end and lost my mind so, glad to be here and good to speak with you and hope you may help in some way.

Cheers.

-Frank


[VBA]
Sub Copy_ActiveSheet_1()
'Working in Excel 97-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
End Select
End If
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook and close it
TempFilePath = Application.DefaultFilePath & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
.Close SaveChanges:=False
End With
MsgBox "You can find the new file in " & TempFilePath
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
[/VBA]

[Frank Rizzo]

Ok then,

Below is what I have been able to put together from my original request.

The following vb codes force macros to be enabled. Also preventing copy, paste, drag and drop insert etc using keys.

Also, The password protection locks all pages and workbook and opens for the hiding and unhiding of sheets and relocks so no errors now.

I am working on the final part of my request which is to prevent copying or saving in anyway possible to another format other than 97-2003.

Is anyone out there?

If so, can you look at what I have an advise if this looks ok. Also, if you have something that can help with the final part of my request, I would appreciate it muchly.

Anyone out there now?

-Frank


STANDARD MODULE

[VBA]
Option Explicit

Sub ToggleCutCopyAndPaste(Allow As Boolean)
'Activate/deactivate cut, copy, paste and pastespecial menu items
Call EnableMenuItem(21, Allow) ' cut
Call EnableMenuItem(19, Allow) ' copy
Call EnableMenuItem(22, Allow) ' paste
Call EnableMenuItem(755, Allow) ' pastespecial

'Activate/deactivate drag and drop ability
Application.CellDragAndDrop = Allow

'Activate/deactivate cut, copy, paste and pastespecial shortcut keys
With Application
Select Case Allow
Case Is = False
.OnKey "^c", "CutCopyPasteDisabled"
.OnKey "^v", "CutCopyPasteDisabled"
.OnKey "^x", "CutCopyPasteDisabled"
.OnKey "+{DEL}", "CutCopyPasteDisabled"
.OnKey "^{INSERT}", "CutCopyPasteDisabled"
Case Is = True
.OnKey "^c"
.OnKey "^v"
.OnKey "^x"
.OnKey "+{DEL}"
.OnKey "^{INSERT}"
End Select
End With
End Sub

Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean)
'Activate/Deactivate specific menu item
Dim cBar As CommandBar
Dim cBarCtrl As CommandBarControl
For Each cBar In Application.CommandBars
If cBar.Name <> "Clipboard" Then
Set cBarCtrl = cBar.FindControl(ID:=ctlId, recursive:=True)
If Not cBarCtrl Is Nothing Then cBarCtrl.Enabled = Enabled
End If
Next
End Sub

Sub CutCopyPasteDisabled()
'Inform user that the functions have been disabled
MsgBox "Sorry! Cutting, copying and pasting have been disabled in this workbook!"
End Sub

[/VBA]


WORKBOOK MODULE

[VBA]Option Explicit

Const WelcomePage = "Macros"

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False

'Evaluate if workbook is saved and emulate default propmts
With ThisWorkbook
If Not .Saved Then
Select Case MsgBox("Do you want to save the changes you made to '" & .Name & "'?", _
vbYesNoCancel + vbExclamation)
Case Is = vbYes
'Call customized save routine
Call CustomSave
Case Is = vbNo
'Do not save
Case Is = vbCancel
'Set up procedure to cancel close
Cancel = True
End Select
End If

'If Cancel was clicked, turn events back on and cancel close,
'otherwise close the workbook without saving further changes
If Not Cancel = True Then
.Saved = True
Application.EnableEvents = True
.Close savechanges:=False
Else
Application.EnableEvents = True
End If
End With
Call ToggleCutCopyAndPaste(True)
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False

'Call customized save routine and set workbook's saved property to true
'(To cancel regular saving)
Call CustomSave(SaveAsUI)
Cancel = True

'Turn events back on an set saved property to true
Application.EnableEvents = True
ThisWorkbook.Saved = True
End Sub

Private Sub Workbook_Open()
'Unhide all worksheets
Application.ScreenUpdating = False
Call ShowAllSheets
Call ToggleCutCopyAndPaste(False)
Application.ScreenUpdating = True
End Sub

Private Sub CustomSave(Optional SaveAs As Boolean)
Dim ws As Worksheet, aWs As Worksheet, newFname As String
'Turn off screen flashing
Application.ScreenUpdating = False

'Record active worksheet
Set aWs = ActiveSheet

'Hide all sheets
Call HideAllSheets

'Save workbook directly or prompt for saveas filename
If SaveAs = True Then
newFname = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.xls), *.xls")
If Not newFname = "False" Then ThisWorkbook.SaveAs newFname
Else
ThisWorkbook.Save
End If

'Restore file to where user was
Call ShowAllSheets
aWs.Activate

'Restore screen updates
Application.ScreenUpdating = True
End Sub

Private Sub HideAllSheets()
Dim ws As Worksheet
ActiveWorkbook.Unprotect Password:="123"
ActiveSheet.Unprotect Password:="123"
'Hide all worksheets except the macro welcome page
Worksheets(WelcomePage).Visible = xlSheetVisible
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
Next ws
ActiveSheet.Protect Password:="123"
ActiveWorkbook.Protect Password:="123"
Worksheets(WelcomePage).Activate
End Sub

Private Sub ShowAllSheets()
Dim ws As Worksheet
ActiveWorkbook.Unprotect Password:="123"
ActiveSheet.Unprotect Password:="123"
'Show all worksheets except the macro welcome page
ActiveWorkbook.Unprotect
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
Next ws
Worksheets(WelcomePage).Visible = xlSheetVeryHidden
ActiveSheet.Protect Password:="123"
ActiveWorkbook.Protect Password:="123"
End Sub
Private Sub Workbook_Activate()
Call ToggleCutCopyAndPaste(False)
End Sub
Private Sub Workbook_Deactivate()
Call ToggleCutCopyAndPaste(True)
End Sub[/VBA]

[Frank Rizzo]

Thanks for nothing.

[mancubus]

wellcome to vbax.

give credit where credit is due.
http://www.vbaexpress.com/kb/getarticle.php?kb_id=379
http://www.excelguru.ca/content.php?162

[Frank Rizzo]

Hello mancubus,

You will have to forgive me as I am not up to date on how to post and the way in which I am supposed to give credit etc. to get help.

I do hope that the lack of any help has not been due to my lack of etiquette because it would be disappointing to think that if a question is posed regarding a code constructed by someone else and God forbid the poster has failed to identify that the code being questioned about was not produced by themselves prevents help being offered, is a bit much.

If I was not clear before, let me first assure you and everyone else in this forum I do not write code even in the least. Any and all codes shown here have been what I was able to find in this site by searching the many, many, many posts I have read as a result of not having anyone even attempt to help in the first place.

I did the best I could by trial and error piecing together other people’s codes to try and assist myself.

It didn’t dawn on me in the least that I had to post the links to the codes I was posting and as you mention, “give credit where credit is due” only due to the fact that in all the posts I have read in the last 18 hours, not once have I seen anyone else do that so again; you are going to have to forgive my ignorance and my tone at the moment because of anything you could have said to me regarding this post, I would have appreciated you saying something like;

“Hello and welcome to the site. In respect of your questions, I have the following help to provide if any, and oh by the way, it is standard etiquette to recognize where you got your coding from in respect of any questions you may have. You may wish to place the links of the posts that you got the code from.”

I would have appreciated the help and apologised, as I am doing now only with a little less tone and would have placed the links as you have.

When I am not so frazzled and short on sleep or patients, I will take the time to read the proper procedures on posting and etiquette but right now, I want to thank you for at least saying hello if nothing else.

Thanks in advance.

-Frank

Ps. For the record, posting links is restricted under 5 posts.

[Aussiebear]

Frank, I can understand your view but you need to realise that people here contribute on a voluntary basis, and often only when they understand what is being asked on them. It just may have been that your posts may have been read by others, but they simply didn't feel confident enough to respond.

Sometimes we just need to be patient, for a response will come....

[Frank Rizzo]

I apologise. No disrespect intended and I understand.

Please forgive me; a lack of sleep and the stress of this coding has turned me into a knuckle head.

I am truly sorry for my tone.

Thank you.

-Frank

[Aussiebear]

Thank you

[Frank Rizzo]

I wanted to stop in an provide the coding regarding my questions.

The first code is placed into 'ThisWorkbook'. Make sure to name one sheet 'ERROR' which will show when the user fails to enable the macros. If they fail to enable the macros, only the error page can be viewed.

'Module 1' will prevent cut, copy, paste, paste special, drag and drop, and all key board short cuts.

'Module 2' will allow you to select macros from the command bar and run the macro called 'Protect All' which will protect all work sheets in the work book at once. Conversely, running the macro called 'Unprotect All' will do as it says.

The error spoke of above was due to the workbook trying to unhide and hide workbook sheets but could not because it had no way to unlock the workbook. This has been corrected and no error. Also, was unnecessary to place a protect and unprotect sheets because only the workbook need be addressed for this operation.

Unlock code from;
http://www.mrexcel.com/forum/showthread.php?p=747381
Forced Macros from;
http://www.vbaexpress.com/kb/getarticle.php?kb_id=379
Save code unused.

-Frank


Place in ThisWorkBook

[VBA]Option Explicit

Const WelcomePage = "ERROR"

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim ChAction As Variant
If ThisWorkbook.Saved = False Then
ChAction = MsgBox("Do you want to save the changes you made to '" & _
ThisWorkbook.Name & "'?", vbYesNoCancel + vbExclamation)
Select Case ChAction
Case vbCancel
Cancel = True
Case vbYes
If MySave(False) = "Saved" Then
ThisWorkbook.Close False
Else
Cancel = True
End If
Case vbNo
ThisWorkbook.Saved = True
End Select
Call ToggleCutCopyAndPaste(True)
End If
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
Cancel As Boolean)
Dim wsActive As Worksheet
Set wsActive = ActiveSheet
Call MySave(SaveAsUI)
Call ShowAllSheets
wsActive.Activate
Cancel = True
End Sub

Private Sub Workbook_Open()
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False
Call ShowAllSheets
Application.ScreenUpdating = True
ThisWorkbook.Saved = True
End Sub

Function MySave(Optional SaveAsUI As Boolean) As String
Dim strName As String
Dim intDoSave As Integer
Dim bSaved As Boolean
Dim bSaveAsHere As Boolean
MySave = "Not Saved"
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
If SaveAsUI = True Then
strName = Application.GetSaveAsFilename
If strName = "False" Then
bSaved = False
Else
Call HideAllSheets
If UCase(strName) = UCase(ThisWorkbook.FullName) Then
ThisWorkbook.Save
bSaved = True
Else
If Dir(strName) <> "" Then
intDoSave = MsgBox("This file already exists. Do you want to replace it?", vbYesNoCancel + vbExclamation)
If intDoSave = vbYes Then
Kill (strName)
Else
Exit Function
End If
End If
ThisWorkbook.SaveAs strName
Application.RecentFiles.Add strName
bSaved = True
End If
End If
Else
Call HideAllSheets
ThisWorkbook.Save
bSaved = True
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
If bSaved Then
ThisWorkbook.Saved = True
MySave = "Saved"
End If
End Function

Private Sub HideAllSheets()
Dim ws As Worksheet
ActiveWorkbook.Unprotect Password:="abcde123"
Worksheets(WelcomePage).Visible = xlSheetVisible
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
Next ws
ActiveWorkbook.Protect Password:="abcde123"
Worksheets(WelcomePage).Activate
End Sub

Private Sub ShowAllSheets()
Dim ws As Worksheet
ActiveWorkbook.Unprotect Password:="abcde123"
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
If ws.Name = "Lists" Then ws.Visible = xlSheetVeryHidden
Next ws
Worksheets(WelcomePage).Visible = xlSheetVeryHidden
ActiveWorkbook.Protect Password:="abcde123"
End Sub
Private Sub Workbook_Activate()
Call ToggleCutCopyAndPaste(False)
End Sub
Private Sub Workbook_Deactivate()
Call ToggleCutCopyAndPaste(True)
End Sub[/VBA]

Place in standard Module1

[VBA]
Option Explicit

Sub ToggleCutCopyAndPaste(Allow As Boolean)
'Activate/deactivate cut, copy, paste and pastespecial menu items
Call EnableMenuItem(21, Allow) ' cut
Call EnableMenuItem(19, Allow) ' copy
Call EnableMenuItem(22, Allow) ' paste
Call EnableMenuItem(755, Allow) ' pastespecial

'Activate/deactivate drag and drop ability
Application.CellDragAndDrop = Allow

'Activate/deactivate cut, copy, paste and pastespecial shortcut keys
With Application
Select Case Allow
Case Is = False
.OnKey "^c", "CutCopyPasteDisabled"
.OnKey "^v", "CutCopyPasteDisabled"
.OnKey "^x", "CutCopyPasteDisabled"
.OnKey "+{DEL}", "CutCopyPasteDisabled"
.OnKey "^{INSERT}", "CutCopyPasteDisabled"
Case Is = True
.OnKey "^c"
.OnKey "^v"
.OnKey "^x"
.OnKey "+{DEL}"
.OnKey "^{INSERT}"
End Select
End With
End Sub

Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean)
'Activate/Deactivate specific menu item
Dim cBar As CommandBar
Dim cBarCtrl As CommandBarControl
For Each cBar In Application.CommandBars
If cBar.Name <> "Clipboard" Then
Set cBarCtrl = cBar.FindControl(ID:=ctlId, recursive:=True)
If Not cBarCtrl Is Nothing Then cBarCtrl.Enabled = Enabled
End If
Next
End Sub

Sub CutCopyPasteDisabled()
'Inform user that the functions have been disabled
MsgBox "Sorry! Cutting, copying and pasting have been disabled in this workbook!"
End Sub
[/VBA]

Place in standard Module2

[VBA]
Dim ws As Worksheet
Sub ProtectAll()
Dim S As Object
Dim pWord1 As String, pWord2 As String
pWord1 = InputBox("Please Enter the password")
If pWord1 = "" Then Exit Sub
pWord2 = InputBox("Please re-enter the password")
If pWord2 = "" Then Exit Sub
If InStr(1, pWord2, pWord1, 0) = 0 Or _
InStr(1, pWord1, pWord2, 0) = 0 Then
MsgBox "You entered different passwords. No action taken"
Exit Sub
End If
For Each ws In Worksheets
ws.Protect Password:="MultiSyncFE950"
Next
MsgBox "All sheets Protected."
Exit Sub
End Sub

Sub UnProtectAll()
Dim S As Object
Dim pWord3 As String
pWord3 = InputBox("Please Enter the password")
If pWord3 = "" Then Exit Sub
For Each ws In Worksheets
On Error GoTo errorTrap1
ws.Unprotect Password:="MultiSyncFE950"
Next
MsgBox "All sheets UnProtected."
Exit Sub
errorTrap1:
MsgBox "Sheets could not be UnProtected - Password Incorrect"
Exit Sub
End Sub
[/VBA]