VBA - Send variable password to email

[Skovgaard]

Hi All,

I'm working on a workbook, with confidential data, where I need to put restrictions on who can use it.
Normally I will just put on a password to open the workbook, but that won't do it here.
E.g. an employee will always be able to use the workbook, even though he is no longer at the company.

Therefore I was wondering, is there a more secure way/what is the "normal" thing to do, to secure your data from unauthorized use?

I was thinking a solution could be:
When opening the workbook, the user will be prompted a userform, where they enter their initials. Excel will then generate a password and send this to the users email-address (user and email will be stored in the sheet I think).
The user will then have to put in this password, before sheets are being unhided and the workbook can be used (maybe there should also be an administrator password).

Is this possible or should I go another way?

/Skovgaard

 

[mrshl9898]

I don't think anything will help with previous versions of the book an ex employee has/had.

This could fulfil the purpose for only letting certain users use the file sent.


*Needs to be added to "This Workbook", just update the user1, 2 etc list

Private Sub Workbook_Open()

user = Environ("Username")

If UBound(Filter(Array("user1", "user2", "user3"), user)) > -1 Then
Exit Sub
Else: Workbook.Close
End If

End Sub

 

[Skovgaard]

Thanks for your reply.

Where is this user information found, is that from the windows login?
If that's the case, I don't see much security, hence you can just create the same user on another computer.

I found below code and testet my own username. It's the same as my windows login - But maybe that's a coincidence?

Public Function UserName()
    UserName = Environ$("UserName")
End Function

/Skovgaard

 

[mrshl9898]

Fair point. Yes, it is the windows username.

 

[Skovgaard]

I thought so, that's why I was thinking in the direction of sending an email to the user, hence their working-email can be blocked in the moment they leave the company.

Do you know if it's possible to auto-generate a password in VBA and then auto-send to a predefined email-address?

/Skovgaard

 

[mrshl9898]

Well you wouldn't be generating a password, it would be a defined password that works with just that workbook. You won't be stopping ex employees accessing files previously sent to them.

You'd need to run a macro on workbook open (which they'd have to enable macros to run) ask for username, close if incorrect, send password if correct (so no different to the above solution). Then ask for the password or again close if incorrect... I guess to get past the enabling issues you could set the sheets to 'very hidden' which i'm pretty sure they'd need to enable VBA to unhide.

Depending on your data source and network security a better option maybe to look at moving the reporting online, or if they can't manipulate a data source without a network connection then have the report generate itself once open and enabled (password or username check could go there).


Would be good to hear other peoples thoughts.

 

[Skovgaard]

Hi All,

Sorry to bring this thread to the top again, I'm hoping someone have had the same challenge or maybe a solution.
Securing data must be important in all companies I'd guess.

/Skovgaard

 

[Skovgaard]

I think I managed to build up some code (with help from my good friend Google ), that will do the trick.

It seems to be working as I was hoping for, however I feel that my Excel is a little unstable with this workbook open. Some times it runs smoothly and other times it stalls for a longer period. So I'm wondering if there is something in my code causing this.

I would therefore appreciate if someone could have a look at the code, and let me know if something should be written in a different way.

Module1 (Check user and password):

Sub CheckUser()

Dim strUser As String
Dim strUserName As Variant
Dim strEmail As Variant
Const Quotes As String = """"
Dim SendOK As Integer

Application.ScreenUpdating = False
Worksheets("Users").Visible = True

strUser = Environ$("UserName") 'Windows user login
strUserName = Application.VLookup(strUser, Worksheets("Users").Range("A:C"), 2, False)
strUserEmail = Application.VLookup(strUser, Worksheets("Users").Range("A:C"), 3, False)

If IsError(strUserName) Then 'Check if user is in list
    MsgBox "User " & Quotes & strUser & Quotes & " is not authorized to open this file." _
            & vbNewLine & vbNewLine & "Please contact Administrator."
    End
Else
    SendOK = MsgBox("Hi " & strUserName _
            & vbNewLine & vbNewLine _
            & "Press OK to send password to open this file" _
            & vbNewLine & vbNewLine _
            & "Password will be sent to " & strUserEmail, vbOKCancel)
    If SendOK = vbCancel Then
        Worksheets("Users").Visible = xlSheetVeryHidden
        Application.ScreenUpdating = True
        End
    Else
        Sheets("Users").Range("E2").FormulaR1C1 = "=RANDBETWEEN(1000000,9999999)"
        Sheets("Users").Range("E2").Copy
        Sheets("Users").Range("E2").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
                    
        Call send_email
    End If
            
End If


End Sub

Sub CheckPassword()

Dim strUser As String
Dim strUserName As Variant
Const Quotes As String = """"
Dim Password As String

strUser = Environ$("UserName")
strUserName = Application.VLookup(strUser, Worksheets("Users").Range("A:C"), 2, False)

Password = InputBox("Type password received on your email")

If Password = Worksheets("Users").Cells(2, 5) Then
    MsgBox "Correct password" _
            & vbNewLine & vbNewLine _
            & "Press OK to continue"
    Worksheets("Users").Visible = xlSheetVeryHidden
    Worksheets("Sheet2").Visible = True
    Worksheets("Sheet2").Activate
Else
    MsgBox "Wrong Password"
    Worksheets("Users").Visible = xlSheetVeryHidden
    Application.ScreenUpdating = True
    ActiveWorkbook.Close SaveChanges:=False
    End
End If

Application.ScreenUpdating = True
    
End Sub

Module2 (Send password):

Sub send_email()

Dim NewMail As Object
Dim MailConfig As Object
Dim SMTP_Config As Variant
Dim strSubject As String
Dim strFrom As String
Dim strTo As String
Dim strCc As String
Dim strBcc As String
Dim strBody As String
Dim strUser As String

strUser = Environ$("UserName")
strSubject = "Password Generated"
strFrom = "???@gmail.com" 'Sender email-adress
strTo = Application.VLookup(strUser, Worksheets("Users").Range("A:C"), 3, False)
strCc = ""
strBcc = ""
strBody = "Password to open file: " & Worksheets("Users").Cells(2, 5)


Set NewMail = CreateObject("CDO.Message")
Set MailConfig = CreateObject("CDO.Configuration")

MailConfig.Load -1

Set Fields = MailConfig.Fields

    msConfigURL = "http://schemas.microsoft.com/cdo/configuration"

    With Fields
        'Enable SSL Authentication
        .Item(msConfigURL & "/smtpusessl") = True

        'Make SMTP authentication Enabled=true (1)
        .Item(msConfigURL & "/smtpauthenticate") = 1

        'Set the SMTP server and port Details
        'To get these details you can get on Settings Page of your Gmail Account
        .Item(msConfigURL & "/smtpserver") = "smtp.gmail.com"
        .Item(msConfigURL & "/smtpserverport") = 465
        .Item(msConfigURL & "/sendusing") = 2

        'Set your credentials of your Gmail Account
        .Item(msConfigURL & "/sendusername") = "???@gmail.com" 'Sender email-adress
        .Item(msConfigURL & "/sendpassword") = "???" 'Password to Gmail-account

        'Update the configuration fields
        .Update

    End With
    NewMail.Configuration = MailConfig
    NewMail.Subject = strSubject
    NewMail.From = strFrom
    NewMail.To = strTo
    NewMail.TextBody = strBody
    NewMail.CC = strCc
    NewMail.BCC = strBcc
    NewMail.Send
    MsgBox ("Password has been sent")
    
Call CheckPassword

Exit_Err:
    
    Worksheets("Users").Visible = xlSheetVeryHidden

    Set NewMail = Nothing
    Set MailConfig = Nothing
    End

Err:
    
    Worksheets("Users").Visible = xlSheetVeryHidden
    
    Select Case Err.Number

    Case -2147220973  'Could be because of Internet Connection
        MsgBox " Could be no Internet Connection !!  -- " & Err.Description

    Case -2147220975  'Incorrect credentials User ID or password
        MsgBox "Incorrect Credentials !!  -- " & Err.Description

    Case Else   'Rest other errors
        MsgBox "Error occured while sending the email !!  -- " & Err.Description
    End Select

    Resume Exit_Err

With NewMail
 Set .Configuration = MailConfig
End With


Error_Handling:
If Err.Description <> "" Then MsgBox Err.Description


Application.ScreenUpdating = True

End Sub

/Skovgaard

 

[mrshl9898]

Code looks ok to me (others might comment differently). And the overall process looks about as good as it can get from a security point (very hidden sheets, using windows credentials). Though if you're doing this process:

Check username > send password to user > get user to enter password >unlock workbook

The middle steps seems unnecessary still.

Just one last thing to mention, make sure you lock down the VBA side of things with a password too in case you haven't, to stop people seeing the sheet names and therefore just typing =Sheet2!A1 into another book and seeing all the data.

 

[Skovgaard]

Thanks for your reply!

As an extra precaution, I do a "very hidden" on WorkbookOpen, before I call CheckUser. My VBA code is password protected, so I guess the user can't hack the sheet and see the password!?
Actually when I open the workbook, I only see a white screen and then the msgbox/inputbox from the code.

I'm not sure what you mean with the middle steeps seems unnecessary. Do you mean the "send password" and "enter password"?
The reason for this is, that the company can block the users access to the email account, and as a result won't get the password.

/Skovgaard