Below is a cut and paste of a code I found in the message board archives which has a non-working hyperlink to the author's email. It seems there is a mistyped line on the code so the Error/debug option screen pops up after I press F5. Would an excel genius help me out please:
[Added code tags~VP]
Code:
Option Explicit
' To use this code you need the following environment.
' Excel Spreadsheet with three tabs with the following names:
' Notice <- You need this sheet to have information informing the user that macros
' must be enabled. Put instructions on how to enable macros.
' Status <- This sheet will always be hidden to the User. It is only
' used to store the date information for validation test purposes.
' Instructions <- This is the first page the user sees. I have buttons on it to take the user to other sheets.
' I use it to tell the user how much longer the workbook is valid for and other appropriate information
' UserForm1 <- Used to dispay a status message as the workbook is saved.
' More detail is provided on each of these requirment in the code below.
Private Sub Workbook_Open()
' Freeze the screen. Makes the code run faster and stops the screen flicker
' when it is running. I use this a lot.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Sheet As Worksheet
'make all sheets visible. You need a sheet named "Notice" as this is the sheet shown when
'macros are not enabled.
For Each Sheet In Worksheets
If Sheet.Name <> "Notice" Then
Sheet.Visible = xlSheetVisible
End If
Next Sheet
'hide the Notice and go to A1 on sheet1
Sheets("Notice").Visible = xlSheetVeryHidden
Application.Goto Sheet1.[A1], scroll:=True
'clean up
Set Sheet = Nothing
ActiveWorkbook.Saved = True
' Verifies a valid user is running the spreadsheet and date is still valid. I use a 30 day validity period
' at which point the spreadsheet self destructs.
Call User
' Hide the work sheets from the user. This is just incase to make sure all
' of the sheets I don't want shown are hidden. I only show the user 5-6 sheets, but I have over a dozen
' in my workbook. I use a lot of "Call" and just develop generic routines that I can run from
' multiple locations. This way they are hid the next time the sheet is used if by chance they were made visible
' during a previous session. I use the following structure in the subroutine:
' Sheets("xxxx").Visible = False
' Sheets("yyyy").Visible = False
Call HideMySheets
' Switches to the Instructions Tab. In this case, it activates the instructions tab and maximizes it.
' This way every user sees the tab where I put the lattest info as soon as they launch the application.
' I have buttons linked to other macros that let the user move around.
Sheets("Intstructions").Select
' This code causes screen to be reset at Cell a1
Range("a1").Select
ActiveCell.Select
With ActiveWindow
.ScrollColumn = ActiveCell.Column
.ScrollRow = ActiveCell.Row
End With
ActiveWindow.WindowState = xlMaximized
' This macro turns on calculation and screen update
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
UserForm1.Show vbModeless
' userform 1 is a message that states " The configurator environment is being cleaned up".
' I use this to let the user know something is going on. What the macro is doing is
' hiding all of the sheets except the "Notice" sheet. I do this to roce the user to turn on
' macro support the next time the file is run.
Application.Wait (Now + TimeValue("0:00:02"))
With Sheets("Notice")
'if book is already saved, make a note of it
If ActiveWorkbook.Saved = True Then .[A100] = "Saved"
'make Notice sheet visible
Dim Sheet As Worksheet
.Visible = xlSheetVisible
'hide all other sheets
For Each Sheet In Worksheets
If Sheet.Name <> "Notice" Then
Sheet.Visible = xlSheetVeryHidden
End If
Next Sheet
'if the book is already saved, delete
'the previous note and close the book
If .[A100] = "Saved" Then
.[A100].ClearContents
ActiveWorkbook.Save
End If
'clean up
Set Sheet = Nothing
End With
Unload UserForm1
End Sub
Sub User()
Dim GetName
Dim TheDomain
CheckTheSuperUsers:
' This code gets the username of the person logged into windows.
Set GetName = CreateObject("WScript.NetWork")
' This section checks the SuperUsers and grants entry if appropriate.
' Below at the CheckUsers label: is where I check all of the users
'---------------------------------------------------
'<<<<<<<<<---- These are super users ---->>>>>>>>>>
'---------------------------------------------------
' I am the main super user. When I log in,
' the validity date for the spreadsheet is automatically extended.
' the *XusernameX* checked is the username used to log into windows
' The *XReal NameX* makes it easy for me to find the particular user.
' User *XReal NameX*
If GetName.UserName = "*XusernameX*" Then
GoTo DateSet
End If
' This a second super user that has acces even if the validity date is passed.
' this user account does not reset the validity date.
' User *XReal NameX*
If GetName.UserName = "*XusernameX*" Then
GoTo LastLine
End If
' Code checks that the computer is part of the "XYZ" domain. This is to help
' ensure that it will only run on company computers. If it is not part of
' our domain, it shuts down and deletes itself.
TheDomain = Environ("UserDomain")
If TheDomain = "XYZ" Then
GoTo CheckTheSuperUsers
Else
Call KillMe
End If
'------------------------------------------------------------------------
'<<<<<<<<<---- This section checks and validates the date ---->>>>>>>>>>
'------------------------------------------------------------------------
' This routine verifies the date is still valid. If it is not, it exits the spreadsheet and deletes it.
' You need a sheet called "Status"
Dim TodaysDate
Dim CheckDate
' Selct the Status sheet prior to reading the date.
Sheets("Status").Visible = xlSheetVisible
Sheets("Status").Select
TodaysDate = Date
CheckDate = Range("A2").Value
If CheckDate >= TodaysDate Then
Sheets("Status").Visible = xlSheetVeryHidden
GoTo CheckUsers
End If
' This function jumps to the self destruct because the file is to old.
If CheckDate < TodaysDate Then
Call KillMe
End If
CheckUsers:
' This section checks the Users and grants entry if appropriate.
' Duplicate the the if block for each user you want to verify.
' NOTE: This area could possibly be cleaned up by using the CASE test.
'---------------------------------------------------
'<<<<<<<<<---- These are normal users ---->>>>>>>>>>
'---------------------------------------------------
' User *XReal NameX*
If GetName.UserName = "*XusernameX*" Then
GoTo LastLine
End If
' If there is no user match, then exit the program
Call KillMe
DateSet:
' This code is used update the validity period that the spreadsheet can be opened by a normal user. This code is auto
' run each time I log in. This way the I reset the validity period as part of my normal use and don't have to
' remember to do this.
' Uses from earlier -----> Dim TodaysDate
Dim FutureDate
Sheets("Status").Visible = xlSheetVisible
TodaysDate = Date
' Set the new start date every time I open the excel sheet
Sheets("Status").Select
Range("A1").Select
ActiveCell.FormulaR1C1 = TodaysDate
' Set the new experation date every time I open the excel sheet.
Range("A2").Select
FutureDate = TodaysDate + 30
ActiveCell.FormulaR1C1 = FutureDate
' Sets the date for the warning calculation. I do a calulation, FutureDate - Todaysdate = XX
' on the "Instructions" that calulates tha validity date and dispalays the following at the top of the page:
' This configurator is valid for XX more day(s).
Sheets("Intstructions").Select
Range("A100").Select
ActiveCell.FormulaR1C1 = FutureDate
Range("A1").Select
ActiveCell.FormulaR1C1 = ""
Sheets("Status").Visible = xlSheetVeryHidden
' The user verification routine jumps to this label and exits if an Authorized user met.
LastLine:
End Sub
Sub KillMe()
With ThisWorkbook
.Saved = True
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close False
End With
End Sub[Added code tags~VP]
