VBA Code error

mbunting

New Member
Joined
Nov 24, 2010
Messages
39
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
---------------------------------------------------------------------
 

Some videos you may like

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)

Watch MrExcel Video

Forum statistics

Threads
1,123,510
Messages
5,602,075
Members
414,500
Latest member
kevdragon1

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top