Password protect workbook when opened. On failed attempt close, send email and delete workbook.

[camerong]

Hi guys,

Not sure where to start with this one, any help is greatly appreciated.

I am after a code that would run as soon as the workbook is opened. I would like it to first check the "Device name" and compare it to a list of names in the code which are allowed to open the workbook. If the "Device name" is on the list then it opens fine without any password prompt. If the "Device name" is not on the list then I would like it to prompt the user for a password (set in the code). If the user inputs the correct password, then the workbook opens fully. If the user inputs the incorrect password, then the Workbook shuts down, is deleted (would be great if it was permanently deleted, not just put in recycling bin) and an email is sent to a specific email address (stipulated in the code).

I am after this to try and protect company intellectual property.

 

[camerong]

Thanks so much for your help @sijpie

I'll give it a go when I get the chance on an empty workbook first

 

[camerong]

Just tried and it works, thanks @sijpie !!!

Much appreciated, this is fantastic

One more thing, is it possible to include an email being sent to an email address specified in the code when the file is deleted from too many incorrect entries?

 

[camerong]

Hi @sijpie,

Is it also possible to have it check the device name (was mentioned in the original post) and if the device name matches a list of device names in the code, it wont prompt you for a password (instead just unlock the workbook)? This way employees do not need to keep entering the password, it will only come up if its used away from a company device. My device name is DRAFTPC13, if we could allow for that as well as DRAFTPC14 and DRAFTPC15 that'd be awesome.

Thanks

 

[sijpie]

1. Which email system do you use?
2. I need to find out how to get the device name. I will do some research and post some code to run to check

 

[Candyman8019]

Environ$("computername")

will give you the computer name.

 

[sijpie]

Thanks Candyman

 

[camerong]

Hi @sijpie,

Regarding the email system, is there a way to have it run through a few email apps until it finds them on the system? Once it finds one, generate an email and send. Then search for any others, if it finds another, generate an email and send. Continue searching until it cant find any others.

I'm thinking these apps below (if possible):

1. Apple mail
2. Gmail
3. Outlook
4. Yahoo mail
5. Microsoft mail

I think you're all over it, but can the code please have a portion where we can set the email recipient, CC'd and the email body text.

Thanks Sijpie

 

[sijpie]

Cameron, I'm just realising a big problem. What you want to do is send an email from someone's computer possibly without the person's approval.
That is not ethical.

It can be achieved if the person has outlook, and possibly applemail. For the other email systems it won't work, as there is no way in which VBA can get the email address and password for the sender.

So I will skip this emailing request.

 

[sijpie]

This is the code for the ThisWorkbook module, where now the trusted PC names are checked.
If the PC names you posted are not dummy names, then you better change them!!

Option Explicit
Const csAllowPC As String = "DRAFTPC13;DRAFTPC14;DRAFTPC15" '<<<< add any trusted PC names separated with ;

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
'This runs after the file has been saved. Display the hidden sheets again
    FullyOpenWb True
    'tell excel the file has been saved (as we just changed it)
    Me.Saved = True
End Sub



Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'This runs just before the file gets saved. Hide all the sheets

    FullyHideSheets True
End Sub

Private Sub Workbook_Open()
    Dim sTPC As String
    Dim vSp As Variant
    Dim i As Integer
    
    sTPC = Environ$("computername")
    vSp = Split(sTPC, ";")
    For i = 0 To UBound(vSp)
        If vSp(i) Like sTPC Then GoTo Trusted
    Next i
    ufGetpw.Show    '<<<<< I have named the Userform ufGetpw. _
                    If you don't rename your userform, then it _
                    will be Userform1 or similar. Change that here
    
Trusted:
    
End Sub

 

[camerong]

Thanks @sijpie,

I'll give it a go soon, yes they were dummy names.