I am trying to create a VBA code that will both make a file Read Only after a given date that is in the VBA code but also make the entire workbook locked with a password, also in the VBA code. It looked like it was working but found out that unless the computer Excel settings were set to enable macros, it wouldn't work. Now...it sets the Excel macros but no longer makes the file read only or locks it with a password.
I don't know it what I am trying to do is not possible or if I just have wrong code or in the wrong order. The code has been copied below so if anyone has suggestions to make it work I would greatly appreciate it. Warning, it is very long....
------------------------------------------------------------------------
'Force the explicit declaration of variables
Option Explicit
'Assign the name of the warning sheet to a constant
Const Warning As String = "START"
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
If Date > DateSerial(2016, 2, 21) And Date < DateSerial(2016, 3, 23) Then
MsgBox "The Annual License for this software is about to expire. Please contact PFRCFO in order to renew your license."
End If
If Date > DateSerial(2016, 3, 22) Then
MsgBox "The Annual License for this software has expired. Please contact PFRCFO in order to renew your license."
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & "PFR Teacher Negotiations 3.15.2016.xlsm", Password:="password"
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
---------------------------------------------------------------------
I don't know it what I am trying to do is not possible or if I just have wrong code or in the wrong order. The code has been copied below so if anyone has suggestions to make it work I would greatly appreciate it. Warning, it is very long....
------------------------------------------------------------------------
'Force the explicit declaration of variables
Option Explicit
'Assign the name of the warning sheet to a constant
Const Warning As String = "START"
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
If Date > DateSerial(2016, 2, 21) And Date < DateSerial(2016, 3, 23) Then
MsgBox "The Annual License for this software is about to expire. Please contact PFRCFO in order to renew your license."
End If
If Date > DateSerial(2016, 3, 22) Then
MsgBox "The Annual License for this software has expired. Please contact PFRCFO in order to renew your license."
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & "PFR Teacher Negotiations 3.15.2016.xlsm", Password:="password"
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
---------------------------------------------------------------------
