Create password for permenent access

[Av8tordude]

Is it possible to create a password for a user to have permanent, unrestricted access and not not be prompted for a password again?

 

[Av8tordude]

Ok...I tried modifying the code to incorporate it into my code, but I'm not being so sucessful. This code is to allow user to access the workbook for a trial period. After that the user has to enter a password for unrestricted use. It seems the code is working, but every time I close it and re-open the workbook, it keeps telling me the workbook is expired and prompting me for a password. My guess is the VBA Code. I guess the workbook needs to be saved without the VBA code attached to the saved file.

Can you provide assistance to solve this dilemma?

Private Sub Workbook_Open()
Dim StartTime#, CurrentTime#
Const TrialPeriod# = 1 '< 1 days trial
Const ObscurePath$ = "C:\"
Const ObscureFile$ = "LBFileLog.Log"

If Dir(ObscurePath & ObscureFile) = Empty Then
StartTime = Format(Now, "#0.#########0")
Open ObscurePath & ObscureFile For Output As #1
Print #1, StartTime
Else
Open ObscurePath & ObscureFile For Input As #1
Input #1, StartTime
CurrentTime = Format(Now, "#0.#########0")
If CurrentTime < StartTime + TrialPeriod Then
Close #1
Exit Sub
Else
Call MsgBox("This Workbook Has Expired. Please Enter Password To Continue", vbCritical, "EXPIRED!")
Dim x
x = InputBox("Enter Password to Unlock")
If x = "password" Then
Application.DisplayAlerts = False
ThisWorkbook.SaveAs ThisWorkbook.FullName, Password:=""
Application.DisplayAlerts = True

If userResponse <> pw Then
Call MsgBox("Wrong password, The Workbook Will Not be Deleted", vbCritical, "")
ThisWorkbook.Close SaveChanges:=False
Exit Sub
End If
End If
End If
End If
End Sub

 

[mikerickson]

When the correct password is entered, this creates a Custom Document Property and sets it to "permenent".

If PassWordEntered = "password" Then
    With ThisWorkbook
        .CustomDocumentProperties("Access").Delete
        .CustomDocumentProperties.Add _
            Name:="Access", _
            Value:="permenent", _
            Type:=msoPropertyTypeString, _
            LinkToContent:=False, _
            LinkSource:=""
    End With
End If

Put in a Workbook_Activate routine, this will give All Access if the workbook has the proper custom property value.

Dim testString As String
testString = vbNullString
On Error Resume Next
testString = ThisWorkbook.CustomDocumentProperties("Access").Value
On Error GoTo 0
If testString = "permenent" Then
    Call GiveAllAccess
End If

 

[Av8tordude]

When the correct password is entered, this creates a Custom Document Property and sets it to "permenent".

If PassWordEntered = "password" Then
    With ThisWorkbook
        .CustomDocumentProperties("Access").Delete
        .CustomDocumentProperties.Add _
            Name:="Access", _
            Value:="permenent", _
            Type:=msoPropertyTypeString, _
            LinkToContent:=False, _
            LinkSource:=""
    End With
End If

Put in a Workbook_Activate routine, this will give All Access if the workbook has the proper custom property value.

Dim testString As String
testString = vbNullString
On Error Resume Next
testString = ThisWorkbook.CustomDocumentProperties("Access").Value
On Error GoTo 0
If testString = "permenent" Then
    Call GiveAllAccess
End If

I receive an error with "Call GiveAllAccess" highlighted. I put the code on tope of my code, in ThisWorkBook under Workbook_Active ()

 

[mikerickson]

Call GiveAllAccess was shorthand for calling your routine to give the user access. I didn't post a complete routine, just an idea that you will need to flesh out to match the rest of your code.