I am creating a spreadsheet in Excel 2003 for my users and have following two requirements.
1) Allow users to have Paste Values only and disable all other Paste options;
2) Force users to enable macros in a workbook
I found following two VBA codes on internet that are working perfectly well and solving both of my issues but I do not know how to combine them into a single VBA code that has to go into ThisWorkbook. As these two are very common requirements for anyone that is developing forms for bunch of users and has to protect their formatting and data validation being destroyed by user inputting the data, I believe that there are lots of people that might benefit from this solution. I would appreciate a help with this issue.
1) Allow users to have Paste Values only and disable all other Paste options;
Original link where this code was posted: Catch Paste
'-------------------------------------------------------------------------
' Module : modHandlePaste
' Author : Jan Karel Pieterse
' Created : 24-9-2007
' Purpose : Module that ensures paste and paste formats is disabled
'-------------------------------------------------------------------------
Option Explicit
Option Private Module
Dim mcCatchers As Collection
Sub CatchPaste()
'-------------------------------------------------------------------------
' Procedure : CatchPaste
' Author : Jan Karel Pieterse Microsoft Office Application Development by JKP Application Development Services.
' Created : 24-9-2007
' Purpose : This routine ensures all paste operations are redirected to our own.
' This way we avoid overwriting styles and validations.
'-------------------------------------------------------------------------
StopCatchPaste
Set mcCatchers = New Collection
'Paste button
AddCatch "Dummy", 22
'Paste button (with dropdown)
EnableDisableControl 6002, False
'Paste Special button
AddCatch "Dummy", 755
'Paste As Hyperlink button
AddCatch "Dummy", 2787
'Paste Formats bottun
AddCatch "Dummy", 369
'Insert Cut cells button
AddCatch "Dummy", 3185
'Insert Copied Cells button
AddCatch "Dummy", 3187
Application.OnKey "^v", "MyPasteValues"
Application.OnKey "^{Insert}", "MyPasteValues"
Application.OnKey "+{Insert}", "MyPasteValues"
Application.OnKey "~", "MyPasteValues"
Application.OnKey "{Enter}", "MyPasteValues"
'Changing the celldragdrop mode clears the clipboard.
'This means if you switch from another workbook back to this one, you would be unable to copy
'information and paste it into the template. This is why we do not reinstate the
'celldragdropmode when switching away from a B1 template and vice versa: switch it off
'when we return to a template.
If Application.CellDragAndDrop Then
'If the user has manually changed this mode to true, the clipboard WILL be emptied due to the next line
Application.CellDragAndDrop = False
End If
End Sub
Sub StopCatchPaste()
'-------------------------------------------------------------------------
' Procedure : StopCatchPaste
' Author : Jan Karel Pieterse Microsoft Office Application Development by JKP Application Development Services.
' Created : 24-9-2007
' Purpose : Resets the paste operations to their defaults
'-------------------------------------------------------------------------
Dim lCount As Long
On Error Resume Next
Set mcCatchers = Nothing
EnableDisableControl 6002, True
Application.OnKey "^v"
Application.OnKey "^{Insert}"
Application.OnKey "+{Insert}"
Application.OnKey "~"
Application.OnKey "{Enter}"
'Changing the celldragdrop mode clears the clipboard.
'This means if you switch from another workbook back to this one, you would be unable to copy
'information and paste it into the template. This is why we do not reinstate the
'celldragdropmode when switching away from a B1 template and vice versa: switch it off
'when we return to a template.
'Next line disabled for this reason!!!
' Application.CellDragAndDrop = True
End Sub
Sub AddCatch(sCombarName As String, lID As Long)
'-------------------------------------------------------------------------
' Procedure : AddCatch
' Author : Jan Karel Pieterse Microsoft Office Application Development by JKP Application Development Services.
' Created : 24-9-2007
' Purpose : Adds a commandbarcontrol to be monitored
'-------------------------------------------------------------------------
Dim oCtl As CommandBarControl
Dim CCatcher As clsCommandBarCatcher
Dim oBar As CommandBar
Set oCtl = Nothing
On Error Resume Next
Set oBar = Application.CommandBars(sCombarName)
If oBar Is Nothing Then
Set oBar = Application.CommandBars.Add(sCombarName, , , True)
oBar.Controls.Add ID:=lID
oBar.Visible = True
End If
With oBar
Set oCtl = .FindControl(ID:=lID, recursive:=True)
If oCtl Is Nothing Then
Set oCtl = .Controls.Add(ID:=lID)
End If
End With
'Try Insert copied/cut cells separately through the cells shortcut menu
If oCtl Is Nothing And (lID = 3185 Or lID = 3187) Then
Set oCtl = Application.CommandBars("Cell").FindControl(ID:=lID, recursive:=True)
End If
Set CCatcher = New clsCommandBarCatcher
Set CCatcher.oComBarCtl = oCtl
mcCatchers.Add CCatcher
Set CCatcher = Nothing
oBar.Delete
Set oBar = Nothing
End Sub
Private Sub EnableDisableControl(lID As Long, bEnable As Boolean)
'-------------------------------------------------------------------------
' Procedure : EnableDisableControl
' Author : Jan Karel Pieterse Microsoft Office Application Development by JKP Application Development Services.
' Created : 24-9-2007
' Purpose : Enables or disables a specific control on all commandbars
'-------------------------------------------------------------------------
Dim oBar As CommandBar
Dim oCtl As CommandBarControl
On Error Resume Next
For Each oBar In CommandBars
Set oCtl = oBar.FindControl(ID:=lID, recursive:=True)
If Not oCtl Is Nothing Then
oCtl.Enabled = bEnable
End If
Next
End Sub
Public Sub MyPasteValues()
'-------------------------------------------------------------------------
' Procedure : EnableDisableControl
' Author : Jan Karel Pieterse Microsoft Office Application Development by JKP Application Development Services.
' Created : 24-9-2007
' Purpose : Propriatary paste values routine called from control event
' handler in clsCommandBarCatcher and from various OnKey macros.
'-------------------------------------------------------------------------
If Application.CutCopyMode <> False Then
If MsgBox("Normal paste operation has been disabled. You are about to Paste Values (cannot be undone), proceed?" & vbNewLine & "Tip: to be able to undo a paste, use the paste values button on the toolbar.", vbQuestion + vbOKCancel, GSAPPNAME) = vbOK Then
On Error Resume Next
Selection.PasteSpecial Paste:=xlValues
IsCellValidationOK Selection
End If
ElseIf Application.MoveAfterReturn Then
On Error Resume Next
Select Case Application.MoveAfterReturnDirection
Case xlUp
ActiveCell.Offset(-1).Select
Case xlDown
ActiveCell.Offset(1).Select
Case xlToRight
ActiveCell.Offset(, 1).Select
Case xlToLeft
ActiveCell.Offset(, -1).Select
End Select
End If
End Sub
Public Function IsCellValidationOK(oRange As Object) As Boolean
'-------------------------------------------------------------------------
' Procedure : ValidateCells
' Author : Jan Karel Pieterse Microsoft Office Application Development by JKP Application Development Services.
' Created : 21-11-2007
' Purpose : This routine checks if entries pasted into the cells in oRange
' are not violating a validation rule.
' Returns False if any cell's validation is violated
'-------------------------------------------------------------------------
Dim oCell As Range
If TypeName(oRange) <> "Range" Then Exit Function
IsCellValidationOK = True
For Each oCell In oRange
If Not oCell.Validation Is Nothing Then
If oCell.HasFormula Then
Else
If oCell.Validation.Value = False Then
IsCellValidationOK = False
Exit For
End If
End If
End If
Next
If IsCellValidationOK = False Then
MsgBox "Warning!!!" & vbNewLine & vbNewLine & _
"The paste operation has caused illegal entries to appear" & vbNewLine & _
"in one or more cells containing validation rules." & vbNewLine & vbNewLine & _
"Please check all cells you have just pasted " & vbNewLine & _
"into and correct any errors!", vbOKOnly + vbExclamation, GSAPPNAME
oRange.Select
End If
End Function
2) Force users to enable macros in a workbook
Original link where this code was posted: XL-CENTRAL.COM : VBA : Force Users to Enable Macros in a Workbook
'Force the explicit declaration of variables
Option Explicit
'Assign the name of the warning sheet to a constant
Const Warning As String = "Warning"
Private Sub Workbook_Open()
'Turn off screen updating
Application.ScreenUpdating = False
'Call the ShowAllSheets routine
Call ShowAllSheets
'Set the workbook's Saved property to True
Me.Saved = True
'Turn on screen updating
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Declare the variable
Dim Ans As Integer
'If the workbook's Saved property is False, emulate Excel's default save prompt
If Me.Saved = False Then
Do
Ans = MsgBox("Do you want to save the changes you made to '" & _
Me.Name & "'?", vbQuestion + vbYesNoCancel)
Select Case Ans
Case vbYes
Call CustomSave
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
Loop Until Me.Saved
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Cancel regular saving
Cancel = True
'Call the CustomSave routine
Call CustomSave(SaveAsUI)
End Sub
Private Sub CustomSave(Optional SaveAs As Boolean)
'Declare the variables
Dim ActiveSht As Object
Dim FileFormat As Variant
Dim FileName As String
Dim FileFilter As String
Dim FilterIndex As Integer
Dim Msg As String
Dim Ans As Integer
Dim OrigSaved As Boolean
Dim WorkbookSaved As Boolean
'Turn off screen updating
Application.ScreenUpdating = False
'Turn off events so that the BeforeSave event doesn't occur
Application.EnableEvents = False
'Assign the status of the workbook's Saved property to a variable
OrigSaved = Me.Saved
'Assign the active sheet to an object variable
Set ActiveSht = ActiveSheet
'Call the HideAllSheets routine
Call HideAllSheets
'Save workbook or prompt for SaveAs filename
If SaveAs Or Len(Me.Path) = 0 Then
If Val(Application.Version) < 12 Then
FileFilter = "Microsoft Office Excel Workbook (*.xls), *.xls"
FilterIndex = 1
Else
FileFilter = "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm, " & _
"Excel 97-2003 Workbook (*.xls), *.xls"
If Right(Me.Name, 4) = ".xls" Then
FilterIndex = 2
Else
FilterIndex = 1
End If
End If
Do
FileName = Application.GetSaveAsFilename( _
InitialFileName:=Me.Name, _
FileFilter:=FileFilter, _
FilterIndex:=FilterIndex, _
Title:="SaveAs")
If FileName = "False" Then Exit Do
If IsLegalFilename(FileName) = False Then
Msg = "The file name is invalid. Try one of the "
Msg = Msg & "following:" & vbCrLf & vbCrLf
Msg = Msg & Chr(149) & " Make sure that the file name "
Msg = Msg & "does not contain any" & vbCrLf
Msg = Msg & " of the following characters: "
Msg = Msg & "< > ? [ ] : | or *" & vbCrLf
Msg = Msg & Chr(149) & " Make sure that the file/path "
Msg = Msg & "name does not exceed" & vbCrLf
Msg = Msg & " more than 218 characters."
MsgBox Msg, vbExclamation, "Invalid File Name"
Else
If Val(Application.Version) < 12 Then
FileFormat = -4143
Else
If Right(FileName, 4) = ".xls" Then
FileFormat = 56
Else
FileFormat = 52
End If
End If
If Len(Dir(FileName)) = 0 Then
Application.DisplayAlerts = False
Me.SaveAs FileName, FileFormat
Application.DisplayAlerts = True
WorkbookSaved = True
Else
Ans = MsgBox("'" & FileName & "' already exists. " & _
"Do you want to replace it?", vbQuestion + vbYesNo, _
"Confirm Save As")
If Ans = vbYes Then
Application.DisplayAlerts = False
Me.SaveAs FileName, FileFormat
Application.DisplayAlerts = True
WorkbookSaved = True
End If
End If
End If
Loop Until Me.Saved
Else
Application.DisplayAlerts = False
Me.Save
Application.DisplayAlerts = True
WorkbookSaved = True
End If
'Call the ShowAllSheets routine
Call ShowAllSheets
'Activate the prior active sheet
ActiveSht.Activate
'Set the workbook's Saved property
If WorkbookSaved Then
Me.Saved = True
Else
Me.Saved = OrigSaved
End If
'Turn on screen updating
Application.ScreenUpdating = True
'Turn on events
Application.EnableEvents = True
End Sub
Private Sub HideAllSheets()
'Declare the variable
Dim Sh As Object
'Display the warning sheet
Sheets(Warning).Visible = xlSheetVisible
'Hide every sheet, except the warning sheet
For Each Sh In Sheets
If Sh.Name <> Warning Then
Sh.Visible = xlSheetVeryHidden
End If
Next Sh
End Sub
Private Sub ShowAllSheets()
'Declare the variable
Dim Sh As Object
'Display every sheet, except the warning sheet
For Each Sh In Sheets
If Sh.Name <> Warning Then
Sh.Visible = xlSheetVisible
End If
Next Sh
'Hide the warning sheet
Sheets(Warning).Visible = xlSheetVeryHidden
End Sub
Private Function IsLegalFilename(ByVal fname As String) As Boolean
Dim BadChars As Variant
Dim i As Long
If Len(fname) > 218 Then
IsLegalFilename = False
Exit Function
Else
BadChars = Array("\", "/", "<", ">", "?", "[", "]", ":", "|", "*", """")
fname = GetFileName(fname)
For i = LBound(BadChars) To UBound(BadChars)
If InStr(1, fname, BadChars(i)) > 0 Then
IsLegalFilename = False
Exit Function
End If
Next i
End If
IsLegalFilename = True
End Function
Private Function GetFileName(ByVal FullName As String) As String
Dim i As Long
For i = Len(FullName) To 1 Step -1
If Mid(FullName, i, 1) = Application.PathSeparator Then Exit For
Next i
GetFileName = Mid(FullName, i + 1)
End Function
1) Allow users to have Paste Values only and disable all other Paste options;
2) Force users to enable macros in a workbook
I found following two VBA codes on internet that are working perfectly well and solving both of my issues but I do not know how to combine them into a single VBA code that has to go into ThisWorkbook. As these two are very common requirements for anyone that is developing forms for bunch of users and has to protect their formatting and data validation being destroyed by user inputting the data, I believe that there are lots of people that might benefit from this solution. I would appreciate a help with this issue.
1) Allow users to have Paste Values only and disable all other Paste options;
Original link where this code was posted: Catch Paste
'-------------------------------------------------------------------------
' Module : modHandlePaste
' Author : Jan Karel Pieterse
' Created : 24-9-2007
' Purpose : Module that ensures paste and paste formats is disabled
'-------------------------------------------------------------------------
Option Explicit
Option Private Module
Dim mcCatchers As Collection
Sub CatchPaste()
'-------------------------------------------------------------------------
' Procedure : CatchPaste
' Author : Jan Karel Pieterse Microsoft Office Application Development by JKP Application Development Services.
' Created : 24-9-2007
' Purpose : This routine ensures all paste operations are redirected to our own.
' This way we avoid overwriting styles and validations.
'-------------------------------------------------------------------------
StopCatchPaste
Set mcCatchers = New Collection
'Paste button
AddCatch "Dummy", 22
'Paste button (with dropdown)
EnableDisableControl 6002, False
'Paste Special button
AddCatch "Dummy", 755
'Paste As Hyperlink button
AddCatch "Dummy", 2787
'Paste Formats bottun
AddCatch "Dummy", 369
'Insert Cut cells button
AddCatch "Dummy", 3185
'Insert Copied Cells button
AddCatch "Dummy", 3187
Application.OnKey "^v", "MyPasteValues"
Application.OnKey "^{Insert}", "MyPasteValues"
Application.OnKey "+{Insert}", "MyPasteValues"
Application.OnKey "~", "MyPasteValues"
Application.OnKey "{Enter}", "MyPasteValues"
'Changing the celldragdrop mode clears the clipboard.
'This means if you switch from another workbook back to this one, you would be unable to copy
'information and paste it into the template. This is why we do not reinstate the
'celldragdropmode when switching away from a B1 template and vice versa: switch it off
'when we return to a template.
If Application.CellDragAndDrop Then
'If the user has manually changed this mode to true, the clipboard WILL be emptied due to the next line
Application.CellDragAndDrop = False
End If
End Sub
Sub StopCatchPaste()
'-------------------------------------------------------------------------
' Procedure : StopCatchPaste
' Author : Jan Karel Pieterse Microsoft Office Application Development by JKP Application Development Services.
' Created : 24-9-2007
' Purpose : Resets the paste operations to their defaults
'-------------------------------------------------------------------------
Dim lCount As Long
On Error Resume Next
Set mcCatchers = Nothing
EnableDisableControl 6002, True
Application.OnKey "^v"
Application.OnKey "^{Insert}"
Application.OnKey "+{Insert}"
Application.OnKey "~"
Application.OnKey "{Enter}"
'Changing the celldragdrop mode clears the clipboard.
'This means if you switch from another workbook back to this one, you would be unable to copy
'information and paste it into the template. This is why we do not reinstate the
'celldragdropmode when switching away from a B1 template and vice versa: switch it off
'when we return to a template.
'Next line disabled for this reason!!!
' Application.CellDragAndDrop = True
End Sub
Sub AddCatch(sCombarName As String, lID As Long)
'-------------------------------------------------------------------------
' Procedure : AddCatch
' Author : Jan Karel Pieterse Microsoft Office Application Development by JKP Application Development Services.
' Created : 24-9-2007
' Purpose : Adds a commandbarcontrol to be monitored
'-------------------------------------------------------------------------
Dim oCtl As CommandBarControl
Dim CCatcher As clsCommandBarCatcher
Dim oBar As CommandBar
Set oCtl = Nothing
On Error Resume Next
Set oBar = Application.CommandBars(sCombarName)
If oBar Is Nothing Then
Set oBar = Application.CommandBars.Add(sCombarName, , , True)
oBar.Controls.Add ID:=lID
oBar.Visible = True
End If
With oBar
Set oCtl = .FindControl(ID:=lID, recursive:=True)
If oCtl Is Nothing Then
Set oCtl = .Controls.Add(ID:=lID)
End If
End With
'Try Insert copied/cut cells separately through the cells shortcut menu
If oCtl Is Nothing And (lID = 3185 Or lID = 3187) Then
Set oCtl = Application.CommandBars("Cell").FindControl(ID:=lID, recursive:=True)
End If
Set CCatcher = New clsCommandBarCatcher
Set CCatcher.oComBarCtl = oCtl
mcCatchers.Add CCatcher
Set CCatcher = Nothing
oBar.Delete
Set oBar = Nothing
End Sub
Private Sub EnableDisableControl(lID As Long, bEnable As Boolean)
'-------------------------------------------------------------------------
' Procedure : EnableDisableControl
' Author : Jan Karel Pieterse Microsoft Office Application Development by JKP Application Development Services.
' Created : 24-9-2007
' Purpose : Enables or disables a specific control on all commandbars
'-------------------------------------------------------------------------
Dim oBar As CommandBar
Dim oCtl As CommandBarControl
On Error Resume Next
For Each oBar In CommandBars
Set oCtl = oBar.FindControl(ID:=lID, recursive:=True)
If Not oCtl Is Nothing Then
oCtl.Enabled = bEnable
End If
Next
End Sub
Public Sub MyPasteValues()
'-------------------------------------------------------------------------
' Procedure : EnableDisableControl
' Author : Jan Karel Pieterse Microsoft Office Application Development by JKP Application Development Services.
' Created : 24-9-2007
' Purpose : Propriatary paste values routine called from control event
' handler in clsCommandBarCatcher and from various OnKey macros.
'-------------------------------------------------------------------------
If Application.CutCopyMode <> False Then
If MsgBox("Normal paste operation has been disabled. You are about to Paste Values (cannot be undone), proceed?" & vbNewLine & "Tip: to be able to undo a paste, use the paste values button on the toolbar.", vbQuestion + vbOKCancel, GSAPPNAME) = vbOK Then
On Error Resume Next
Selection.PasteSpecial Paste:=xlValues
IsCellValidationOK Selection
End If
ElseIf Application.MoveAfterReturn Then
On Error Resume Next
Select Case Application.MoveAfterReturnDirection
Case xlUp
ActiveCell.Offset(-1).Select
Case xlDown
ActiveCell.Offset(1).Select
Case xlToRight
ActiveCell.Offset(, 1).Select
Case xlToLeft
ActiveCell.Offset(, -1).Select
End Select
End If
End Sub
Public Function IsCellValidationOK(oRange As Object) As Boolean
'-------------------------------------------------------------------------
' Procedure : ValidateCells
' Author : Jan Karel Pieterse Microsoft Office Application Development by JKP Application Development Services.
' Created : 21-11-2007
' Purpose : This routine checks if entries pasted into the cells in oRange
' are not violating a validation rule.
' Returns False if any cell's validation is violated
'-------------------------------------------------------------------------
Dim oCell As Range
If TypeName(oRange) <> "Range" Then Exit Function
IsCellValidationOK = True
For Each oCell In oRange
If Not oCell.Validation Is Nothing Then
If oCell.HasFormula Then
Else
If oCell.Validation.Value = False Then
IsCellValidationOK = False
Exit For
End If
End If
End If
Next
If IsCellValidationOK = False Then
MsgBox "Warning!!!" & vbNewLine & vbNewLine & _
"The paste operation has caused illegal entries to appear" & vbNewLine & _
"in one or more cells containing validation rules." & vbNewLine & vbNewLine & _
"Please check all cells you have just pasted " & vbNewLine & _
"into and correct any errors!", vbOKOnly + vbExclamation, GSAPPNAME
oRange.Select
End If
End Function
2) Force users to enable macros in a workbook
Original link where this code was posted: XL-CENTRAL.COM : VBA : Force Users to Enable Macros in a Workbook
'Force the explicit declaration of variables
Option Explicit
'Assign the name of the warning sheet to a constant
Const Warning As String = "Warning"
Private Sub Workbook_Open()
'Turn off screen updating
Application.ScreenUpdating = False
'Call the ShowAllSheets routine
Call ShowAllSheets
'Set the workbook's Saved property to True
Me.Saved = True
'Turn on screen updating
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Declare the variable
Dim Ans As Integer
'If the workbook's Saved property is False, emulate Excel's default save prompt
If Me.Saved = False Then
Do
Ans = MsgBox("Do you want to save the changes you made to '" & _
Me.Name & "'?", vbQuestion + vbYesNoCancel)
Select Case Ans
Case vbYes
Call CustomSave
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
Loop Until Me.Saved
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Cancel regular saving
Cancel = True
'Call the CustomSave routine
Call CustomSave(SaveAsUI)
End Sub
Private Sub CustomSave(Optional SaveAs As Boolean)
'Declare the variables
Dim ActiveSht As Object
Dim FileFormat As Variant
Dim FileName As String
Dim FileFilter As String
Dim FilterIndex As Integer
Dim Msg As String
Dim Ans As Integer
Dim OrigSaved As Boolean
Dim WorkbookSaved As Boolean
'Turn off screen updating
Application.ScreenUpdating = False
'Turn off events so that the BeforeSave event doesn't occur
Application.EnableEvents = False
'Assign the status of the workbook's Saved property to a variable
OrigSaved = Me.Saved
'Assign the active sheet to an object variable
Set ActiveSht = ActiveSheet
'Call the HideAllSheets routine
Call HideAllSheets
'Save workbook or prompt for SaveAs filename
If SaveAs Or Len(Me.Path) = 0 Then
If Val(Application.Version) < 12 Then
FileFilter = "Microsoft Office Excel Workbook (*.xls), *.xls"
FilterIndex = 1
Else
FileFilter = "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm, " & _
"Excel 97-2003 Workbook (*.xls), *.xls"
If Right(Me.Name, 4) = ".xls" Then
FilterIndex = 2
Else
FilterIndex = 1
End If
End If
Do
FileName = Application.GetSaveAsFilename( _
InitialFileName:=Me.Name, _
FileFilter:=FileFilter, _
FilterIndex:=FilterIndex, _
Title:="SaveAs")
If FileName = "False" Then Exit Do
If IsLegalFilename(FileName) = False Then
Msg = "The file name is invalid. Try one of the "
Msg = Msg & "following:" & vbCrLf & vbCrLf
Msg = Msg & Chr(149) & " Make sure that the file name "
Msg = Msg & "does not contain any" & vbCrLf
Msg = Msg & " of the following characters: "
Msg = Msg & "< > ? [ ] : | or *" & vbCrLf
Msg = Msg & Chr(149) & " Make sure that the file/path "
Msg = Msg & "name does not exceed" & vbCrLf
Msg = Msg & " more than 218 characters."
MsgBox Msg, vbExclamation, "Invalid File Name"
Else
If Val(Application.Version) < 12 Then
FileFormat = -4143
Else
If Right(FileName, 4) = ".xls" Then
FileFormat = 56
Else
FileFormat = 52
End If
End If
If Len(Dir(FileName)) = 0 Then
Application.DisplayAlerts = False
Me.SaveAs FileName, FileFormat
Application.DisplayAlerts = True
WorkbookSaved = True
Else
Ans = MsgBox("'" & FileName & "' already exists. " & _
"Do you want to replace it?", vbQuestion + vbYesNo, _
"Confirm Save As")
If Ans = vbYes Then
Application.DisplayAlerts = False
Me.SaveAs FileName, FileFormat
Application.DisplayAlerts = True
WorkbookSaved = True
End If
End If
End If
Loop Until Me.Saved
Else
Application.DisplayAlerts = False
Me.Save
Application.DisplayAlerts = True
WorkbookSaved = True
End If
'Call the ShowAllSheets routine
Call ShowAllSheets
'Activate the prior active sheet
ActiveSht.Activate
'Set the workbook's Saved property
If WorkbookSaved Then
Me.Saved = True
Else
Me.Saved = OrigSaved
End If
'Turn on screen updating
Application.ScreenUpdating = True
'Turn on events
Application.EnableEvents = True
End Sub
Private Sub HideAllSheets()
'Declare the variable
Dim Sh As Object
'Display the warning sheet
Sheets(Warning).Visible = xlSheetVisible
'Hide every sheet, except the warning sheet
For Each Sh In Sheets
If Sh.Name <> Warning Then
Sh.Visible = xlSheetVeryHidden
End If
Next Sh
End Sub
Private Sub ShowAllSheets()
'Declare the variable
Dim Sh As Object
'Display every sheet, except the warning sheet
For Each Sh In Sheets
If Sh.Name <> Warning Then
Sh.Visible = xlSheetVisible
End If
Next Sh
'Hide the warning sheet
Sheets(Warning).Visible = xlSheetVeryHidden
End Sub
Private Function IsLegalFilename(ByVal fname As String) As Boolean
Dim BadChars As Variant
Dim i As Long
If Len(fname) > 218 Then
IsLegalFilename = False
Exit Function
Else
BadChars = Array("\", "/", "<", ">", "?", "[", "]", ":", "|", "*", """")
fname = GetFileName(fname)
For i = LBound(BadChars) To UBound(BadChars)
If InStr(1, fname, BadChars(i)) > 0 Then
IsLegalFilename = False
Exit Function
End If
Next i
End If
IsLegalFilename = True
End Function
Private Function GetFileName(ByVal FullName As String) As String
Dim i As Long
For i = Len(FullName) To 1 Step -1
If Mid(FullName, i, 1) = Application.PathSeparator Then Exit For
Next i
GetFileName = Mid(FullName, i + 1)
End Function
