Solved: Excel file only to open on designated computers

[mikeydo]

Hi Everyone

If I email a file to a user at the momentthere is nothing to stop them sharing the file with others and distributing thefile to anyone. I need a way to prevent the file being opened unless theircomputer name is designated, then if the file is shared without priorpermission the file will not open as the computer is not designated to use thefile.

Thanks Mike

[defcon_3]

What I did before is to force user to enable macro, then using this code:

Dim User As String
User = "username" 'separate with ";"

If CBool(InStr(1, User, Environ("username") & ";")) Then
'workbbok is enabled show its content
Else
MsgBox "You are trying to access restricted panel.", vbCritical, "Access Denied"
Application.Quit
End If

[mikeydo]

Hi defcon 3, thanks for your quick reply. I am not able to write any code so I have a couple of questions. "username" is this the computer name the file will open on? is the green writing in code your notes that dont get copied? separate with ";" does this mean if user name is two words? whatcode is used to force macros to enable and lastly do I paste code to a module. Thanks Mike

[Kenneth Hobs]

Unfortunately, it is easy to get around several locking methods. At a minimum, one should hide all of the sheets after closing. On open, if the username is correct, the hidden sheets will be unhidden. Environ("username") is a method that I like to use. You can also use computername.

TIP: Another method to get these environment variable value is to add a % before and after the name and press enter in the run (Win+R) window.

[mikeydo]

Thanks Kenneth, the computername sounds good as it would restrict use to that computer. But I cant write any VBA and I'm hoping someone can help. Thanks Mike

[defcon_3]

Username is actually the account name, it is good to use this rather than computer names esp when you have limited no. of pc that a large group can use.

Example you have 3 employee namely John, James and Adam. Assuming they use the same account name in logging in the computer. Let say John and James are the only allowed person to use it.


Dim User As String
User = "John;James;" 'separate with ";"
If CBool(InStr(1, User, Environ("username") & ";")) Then
'workbbok is enabled show its content
Else
MsgBox "You are trying to access restricted panel.", vbCritical, "Access Denied"
Application.Quit
End If

Use this kb (http://www.vbaexpress.com/kb/getarticle.php?kb_id=379) to force user to open macro.

edit: There you can use the template, remember to edit the username of the allowed people.

[mikeydo]

Hi defcon 3, the code you sent from kb works very well, I had a bit of trouble at first as I was trying to install with 2010 and it would have it, so I installed using 2007 and all went well. Funny thing it opens in 2010 ok. Thank you again for pointing me in kb's direction. Your code is great and I was tempted to use however I would prefer to use the computername, only because it will stop everyone using, sharing and distributing unless their computer name is in the code. Are you able to help me with the computername code?

Thanks for your help so far.

Mike :thumb

[Kenneth Hobs]

Simply use computername rather than username in Environ().

[mikeydo]

Thanks Kenneth, do i paste code into a module?

Thanks

Mike :thumb

[mikeydo]

Hi Kenneth, I pasted in a module the following code

Dim User As String
User = "MIKE-PC" 'separate with ";"
If CBool(InStr(1, User, Environ("computername") & ";")) Then
'workbbok is enabled show its content
Else
MsgBox "You are trying to access restricted panel.", vbCritical, "Access Denied"
Application.Quit
End If

It didn't work and gave a compiler error and an invalid outside function. Any ideas?

Thanks

Mike :thumb

[Kenneth Hobs]

Please post code between VBA code tags. To add the tags, click the VBA button in the extended reply toolbar.

It can be in a Module or in the ThisWorkbook object. You will need to add a call to it in the Open event code from the kb. If in a Module, remove the word Private.

Rather than Application.Quit, you might want to use Thisworkbook.Close.

There are several ways to do it.

e.g.
Private Sub Workbook_Open()
bQuit
End Sub

Private Sub bQuit()
Dim User As String
User = "MIKE-PC" 'separate with ";"
If CBool(InStr(1, User, Environ("computername") & ";")) Then
'workbbok is enabled show its content
Else
MsgBox "You are trying to access restricted panel.", vbCritical, "Access Denied"
Application.Quit
End If
End Sub

[mikeydo]

Hi Kenneth, I will post code between tags from now on I wasn't sure how to post. Thanks for your reply and I cant wait to try the code, i dont know how to add a call to it in the Open event code from the kb, could you tell me where and what to put in the call. I'll place the code in the Thisworkbook folder after kb's code.

Thanks

Mike :thumb

[Kenneth Hobs]

Private Sub Workbook_Open()
bQuit
'Unhide all worksheets
Application.ScreenUpdating = False
Call ShowAllSheets
Application.ScreenUpdating = True
End Sub

[mikeydo]

Hi Kenneth, Thanks again the code seems to work correctly say for one thing. Even though my computer name is in the code after running it gives me an Access Denied message. Ant ideas?

Thanks
Mike :thumb

[mikeydo]

Hi Kenneth heres the complete code

Option Explicit

Const WelcomePage = "Macros"
Private Sub Workbook_Open()
bQuit
'Unhide all worksheets
Application.ScreenUpdating = False
Call ShowAllSheets
Application.ScreenUpdating = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False

'Evaluate if workbook is saved and emulate default propmts
With ThisWorkbook
If Not .Saved Then
Select Case MsgBox("Do you want to save the changes you made to '" & .Name & "'?", _
vbYesNoCancel + vbExclamation)
Case Is = vbYes
'Call customized save routine
Call CustomSave
Case Is = vbNo
'Do not save
Case Is = vbCancel
'Set up procedure to cancel close
Cancel = True
End Select
End If

'If Cancel was clicked, turn events back on and cancel close,
'otherwise close the workbook without saving further changes
If Not Cancel = True Then
.Saved = True
Application.EnableEvents = True
.Close savechanges:=False
Else
Application.EnableEvents = True
End If
End With
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False

'Call customized save routine and set workbook's saved property to true
'(To cancel regular saving)
Call CustomSave(SaveAsUI)
Cancel = True

'Turn events back on an set saved property to true
Application.EnableEvents = True
ThisWorkbook.Saved = True
End Sub


Private Sub CustomSave(Optional SaveAs As Boolean)
Dim ws As Worksheet, aWs As Worksheet, newFname As String
'Turn off screen flashing
Application.ScreenUpdating = False

'Record active worksheet
Set aWs = ActiveSheet

'Hide all sheets
Call HideAllSheets

'Save workbook directly or prompt for saveas filename
If SaveAs = True Then
newFname = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.xls), *.xls")
If Not newFname = "False" Then ThisWorkbook.SaveAs newFname
Else
ThisWorkbook.Save
End If

'Restore file to where user was
Call ShowAllSheets
aWs.Activate

'Restore screen updates
Application.ScreenUpdating = True
End Sub

Private Sub HideAllSheets()
'Hide all worksheets except the macro welcome page
Dim ws As Worksheet

Worksheets(WelcomePage).Visible = xlSheetVisible

For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
Next ws

Worksheets(WelcomePage).Activate
End Sub

Private Sub ShowAllSheets()
'Show all worksheets except the macro welcome page

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
Next ws

Worksheets(WelcomePage).Visible = xlSheetVeryHidden
End Sub

Private Sub bQuit()
Dim User As String
User = "Mike-PC" 'separate with ";"
If CBool(InStr(1, User, Environ("computername") & ";")) Then
'workbbok is enabled show its content
Else
MsgBox "ACCESS DENIED.", vbCritical, "Access Denied"
ThisWorkbook.Close
End If
End Sub


Mike

[Kenneth Hobs]

You have to be careful doing this sort of thing. You might wind up locking yourself out. To that end, notice that I added the password "ken" to an InputBox() to give the user a chance to enter via a password.

As always, test on a blank workbook first. Of course you need to be sure to add a worksheet named Macros that might have some details about what is going on.

Of course you need to password protect your VBA project as well.

Option Explicit

' http://www.vbaexpress.com/kb/getarticle.php?kb_id=379
Const WelcomePage = "Macros"
Private Sub Workbook_Open()
bQuit
'Unhide all worksheets
Application.ScreenUpdating = False
Call ShowAllSheets
Application.ScreenUpdating = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False

'Evaluate if workbook is saved and emulate default propmts
With ThisWorkbook
If Not .Saved Then
Select Case MsgBox("Do you want to save the changes you made to '" & .Name & "'?", _
vbYesNoCancel + vbExclamation)
Case Is = vbYes
'Call customized save routine
Call CustomSave
Case Is = vbNo
'Do not save
Case Is = vbCancel
'Set up procedure to cancel close
Cancel = True
End Select
End If

'If Cancel was clicked, turn events back on and cancel close,
'otherwise close the workbook without saving further changes
If Not Cancel = True Then
.Saved = True
Application.EnableEvents = True
.Close savechanges:=False
Else
Application.EnableEvents = True
End If
End With
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False

'Call customized save routine and set workbook's saved property to true
'(To cancel regular saving)
Call CustomSave(SaveAsUI)
Cancel = True

'Turn events back on an set saved property to true
Application.EnableEvents = True
ThisWorkbook.Saved = True
End Sub


Private Sub CustomSave(Optional SaveAs As Boolean)
Dim ws As Worksheet, aWs As Worksheet, newFname As String
'Turn off screen flashing
Application.ScreenUpdating = False

'Record active worksheet
Set aWs = ActiveSheet

'Hide all sheets
Call HideAllSheets

'Save workbook directly or prompt for saveas filename
If SaveAs = True Then
newFname = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.xls), *.xls")
If Not newFname = "False" Then ThisWorkbook.SaveAs newFname
Else
ThisWorkbook.Save
End If

'Restore file to where user was
Call ShowAllSheets
aWs.Activate

'Restore screen updates
Application.ScreenUpdating = True
End Sub

Private Sub HideAllSheets()
'Hide all worksheets except the macro welcome page
Dim ws As Worksheet

Worksheets(WelcomePage).Visible = xlSheetVisible

For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
Next ws

Worksheets(WelcomePage).Activate
End Sub

Private Sub ShowAllSheets()
'Show all worksheets except the macro welcome page

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
Next ws

Worksheets(WelcomePage).Visible = xlSheetVeryHidden
End Sub

' http://www.vbaexpress.com/forum/showthread.php?p=271128
Private Sub bQuit()
Dim User As String, passWord As String
User = "Mike-PC" 'separate with ";"
If CBool(InStr(1, User, Environ("computername") & ";")) Then
'workbbok is enabled show its content
Else
passWord = InputBox("Password for Manual Access:", vbCritical, "Automatic Access Denied - Last Chance")
If passWord <> "ken" Then ThisWorkbook.Close
End If
End Sub

[mikeydo]

Hi Kenneth, Tried out the new code and it works great withpassword, but if I take out the password code it opens on any computer and theyall have different computer names. I am not able to use the password section ofcode as my files could then still be shared or distributed to other uses bypassing on the password. I am really grateful for your help and wondered isthere a way to just open the file with the computers name?
Thanks
Mike :thumb

[Kenneth Hobs]

Make sure that you get a True before you flip the trigger. The machinename check is case sensitive as coded.

Sub t()
Dim User As String, passWord As String
User = "Mike-PC;BEAST-PC;" 'separate with ";"
MsgBox CBool(InStr(1, User, Environ("computername") & ";"))
End Sub
Put the MsgBox back if that is what you want. PM me if you lock yourself out.

Private Sub bQuit()
Dim User As String, passWord As String
User = "Mike-PC;BEAST-PC;" 'separate with ";"
If CBool(InStr(1, User, Environ("computername") & ";")) Then
'workbbok is enabled show its content
Else
'passWord = InputBox("Password for Manual Access:", vbCritical, "Automatic Access Denied - Last Chance")
'If passWord <> "ken" Then ThisWorkbook.Close
MsgBox "Macro Ending", vbCritical, "Access Denied"
ThisWorkbook.Close
End If
End Sub

[mikeydo]

Hi everyone

I would just like to say an extra thanks to DEFCON 3 and Kenneth for their invaluable help with this thread. Top guys

Mike :thumb :thumb

[deef]

This is what I really want to protect a excell file, so I can give the file to a client. I'm a real noob at VBA :( Can someone attach a working excell file here please ?

I'm also in search to a extra protection like this:

I wish to place a version number on my webserver in a simple txt file or other file:
mywebservercom(cannotplacelinkshere)/version.txt

The txt files is only this:
Version 1.1

Now the excell file has to check if he is on the right computer and compare the version number from the hosting with the intern version number in the excell file.

Thanx in advance for you're help.

Cheers,

Deef

[deef]

A other quick question... When i rename my pc to Mike-pc or something in the list. The file would work ? Is there a way to protect more on unique code off the computer ?

[deef]

This is what I really want to protect a excell file, so I can give the file to a client. I'm a real noob at VBA :( Can someone attach a working excell file here please ?


Ok not so difficult VBA :) Did found my own how i have to do it thanx for the code here.

Need only the piece how I can check and compare the version on my own hosting, with the internal version.

Someone ? :)


I'm also in search to a extra protection like this:

I wish to place a version number on my webserver in a simple txt file or other file:
mywebservercom(cannotplacelinkshere)/version.txt

The txt files is only this:
Version 1.1

Now the excell file has to check if he is on the right computer and compare the version number from the hosting with the intern version number in the excell file.

[bamboolikefo]

Hi everyone

I would just like to say an extra thanks to DEFCON 3 and Kenneth for their invaluable help with this thread. Top guys

Mike :thumb :thumb

[SamT]

This thread is 5 years old