Create a VBA password

[dannyt1251]

Please help:

I would like a simple piece of VBA code that locks the user out of excel after a set amount of time (lets say 15 minutes) and requires a password to get back in.

Also, I know there is a formula to create unique numbers in cells (i.e: 1 in cell D3, 2 in cell D4 ETC.) I seem to remember the word 'autonumber' but I can't get a formula to work, and I can't find it in the insert function. Any ideas please?

 

[GlennUK]

What criteria should trigger the macro? 15 minutes of inactivity, or is it just 15 minutes after opening a particular workbook? Do you really mean locked out of Excel, or do you mean locked out of a particular workbook?

As for 'autonumber', there is no such thing in Excel, but have a look here:
http://www.mrexcel.com/archive/Formulas/8089.html

 

[dannyt1251]

15 minutes of inactivity would be ideal, if it's possible. What I'm making is a class register and in order to comply with the data protection act this password thing would be ideal if someone scatterbrained forgets to close it down.

It's for A-level coursework but I'm not very good with VBA, so lock it out of the workbook if it's simpler

 

[GlennUK]

Put a password on the workbook.

Set up a Public variable to hold the latest activity time, or even use a cell on one of the sheets for this, and have it update every time there is a Worksheet_SelectionChange or Worksheet_Activate event, updated with the time of the event.

On opening the book set the lastest activity time, do a OnTime to check the book every 2 minutes, and check the current time against the time stored, and if more than 15 minutes then save and close the book.

 

[baxio]

I'm sorry but that makes no sense to me.

I've saved the file with a password, and I understand I need to make a code in visual basic editor, but what do I click on to insert the code into? The "This workbook" directory?

And can you write the code for me, because I'm sorry but I'm no good with VBA and this makes no sense. I'm going mad here!

 

[ktab]

Try this:

Option Explicit
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
(ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0

Private hHook As Long

Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim RetVal
Dim strClassName As String, lngBuffer As Long
If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
Exit Function
End If
strClassName = String$(256, " ")
lngBuffer = 255
If lngCode = HCBT_ACTIVATE Then
RetVal = GetClassName(wParam, strClassName, lngBuffer)
If Left$(strClassName, RetVal) = "#32770" Then
SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
End If
End If
CallNextHookEx hHook, lngCode, wParam, lParam
End Function

Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _
Optional YPos, Optional HelpFile, Optional Context) As String
Dim lngModHwnd As Long, lngThreadID As Long
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
UnhookWindowsHookEx hHook
End Function
Sub PassWord()
Dim message1, title1, default1, myGetUserPW1, thePW
thePW = "1" 'place your password here
message1 = "Enter your password:"
title1 = "This is a Password Protected Application!"
default1 = ""
1 If MsgBox("Required password to continue", vbOKOnly) = vbOK Then
    myGetUserPW1 = InputBoxDK(message1, title1, default1)
    If myGetUserPW1 = thePW Then
        GoTo myend
    Else
        GoTo 1
    End If
End If
myend:
Application.OnTime Now + TimeValue("00:15:00"), "password"
End Sub

The functions and the general idea of passwordchar inputbox was given to me also but i cannot recall right now (sorry author ).

The sub password is the one that will make password request to be made each 15 minutes. If you paste code to workbook open event you've got your solution. (like

Private Sub Workbook_Open()
Application.Run "PassWord"
End Sub

 

[Cbrine]

Just a general comment on this. Excel is NOT a secure environment, and I can tell about 10-15%(if not more) of the board members here could easily bypass this "security" that you are using. So if you are looking to keep casual users out, then go for it, if you are looking for real security, look at a totally different application.

My 2 cents.

HTH
Cal

 

[ktab]

Regarding me, I surely know that, not only VBA password protection, but also password protection of application itself. (VBA a simple ctr+break would do the job). It's just for keeping "casual" users off.

 

[Cbrine]

ktab,
No worries, it was mostly for the OP. I would figure if you are at the API usage level, you would have cracked a few passwords or at least seen code that would do so. It's also pretty easy to bypass the vbe password's.

Cal

 

[HalfAce]

(InputBox password character code -along with plenty of other goodies - courtesy of Daniel Klann.)
http://www.danielklann.com/