VBA to Restrict Use of Workbook to Two Computers

B

bisel

Board Regular
Joined
Jan 4, 2010
Messages
233
Office Version
  1. 365
Platform
  1. Windows
Greetings,

I consider myself a novice at VBA and am looking for some comments and suggestions.

I am creating a workbook that I want to restrict to using on only two computers. I want to register the two computers on first use and when opening the workbook to check to see if the computer has already been registered. If the computer is eligible, then register it. If the number of computers is already = 2, then deny access to the workbook.

I have written up some simple code that checks registration and auto registers the computer if it is eligible. If the new computer is already registered, then the VBA allows access and if the new computer is not eligible for either registration or access, it closes the workbook.

Now, I know that a person with VBA skills can get in and disable this code, but for most users of the workbook, they will not have that level of skill ... at least I doubt they will.

Here is the code that I wrote and would appreciate any comments or suggestions. Right now the code is in its own module, but when final, I plan to insert the code into the Private Sub Workbook_Open module.

Code: 
Sub validatewb()

Dim scompone As String
Dim scomptwo As String
Dim shostname As String

On Error Resume Next

'Get computer name
shostname = Environ$("computername")

'get registered names
scompone = Sheet5.Range("scomp1").Value
scomptwo = Sheet5.Range("scomp2").Value

' Check if computer is already registered
If shostname = scompone Then
    GoTo oktogo
End If


If shostname = scomptwo Then
    GoTo oktogo
End If

' At this point, then hostname has not yet been registered

' Check if maximum number of computers have been registered
If Sheet5.Range("scomp_number").Value = 2 Then ' If already 2, then maximum allowed
        MsgBox "Computer not elible" 'computer is not eligable
        
        ' VBA code here to close the workbook
                
        Exit Sub
    Else
        'computer is elible, register it
        If scompone = "" Then
            Sheet5.Range("scomp1").Value = shostname
        Else
            Sheet5.Range("scomp2").Value = shostname
        End If
    
    MsgBox "New computer registered"
    
End If


oktogo:

'at this point continue with normal operation of workbook


End Sub

Thanks for any assistance.

Steve
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sort by date Sort by votes
if you use ENVIRON then you could target a specific that the system knows about

Code: 
Sub ListEnvironVariables()
    Dim strEnviron As String
    Dim i As Long
    For i = 1 To 255
        strEnviron = Environ(i)
        If LenB(strEnviron) = 0& Then Exit For
        With Worksheets("temp")
            .Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).Value = strEnviron
        End With
    Next
End Sub
 
Upvote 0
mole999 said:
if you use ENVIRON then you could target a specific that the system knows about ...
Click to expand...

Thanks for your reply. Can you be a bit more explicit though ... what exactly will be accomplished in your suggestion that relates to my original objective?
 
Upvote 0
If your testing revelas two unique values in the EVIRONS then you can test for that in a simple statement, if a machine does not match then you can force a close
 
Upvote 0
.
The following code checks the computer for three different specifics : HD Serial #, Processor Serial #, User Name.

Of those three, the first two would be the most secure to check against.


Code: 
Const LockToThisComputer = False
Public DriveSerial As String
Public Processor_ID As String
Const MAX_FILENAME_LEN = 256
Const SupervisorPassword = "987654"  'naturally you will lock the VBA project


Declare Function GetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetVolumeInformation _
    Lib "Kernel32" _
        Alias "GetVolumeInformationA" _
            (ByVal lpRootPathName As String, _
            ByVal lpVolumeNameBuffer As String, _
            ByVal nVolumeNameSize As Long, _
            lpVolumeSerialNumber As Long, _
            lpMaximumComponentLength As Long, _
            lpFileSystemFlags As Long, _
            ByVal lpFileSystemNameBuffer As String, _
            ByVal nFileSystemNameSize As Long) As Long




Sub Lockout()
Dim ThisDriveSerial As String
Dim ThisProcessor_ID As String
Dim Processor_Pass As Boolean
Dim Serial_Pass As Boolean


Processor_Pass = False
Serial_Pass = False


If LockToThisComputer Then
  'get serial
  ThisDriveSerial = CStr(GetDriveSerial("C"))
  'get drive
  ThisProcessor_ID = GetThisCpuID()
  'compare
  If ThisDriveSerial Like DriveSerial Then
    Serial_Pass = True
  End If
  If ThisProcessor_ID Like Processor_ID Then
    Processor_Pass = True
  End If


If Processor_Pass = False Or Serial_Pass = False Then
    'not allowed to run on this machine, so QUIT!
    'PERHAPS INSERT HERE:Give one last chance to give a password
    'saves endless lockout if a mistake has been made in setting up serials!


    ThisWorkbook.Saved = True
    ThisWorkbook.Close


End If




End If


End Sub




Sub Get_Serial()
    MsgBox "Serial of drive C is:-  " & GetDriveSerial("C")
    
End Sub
Sub GetCpuID()
MsgBox "Processor ID is:-  " & GetThisCpuID()
End Sub




Public Function GetDriveSerial(ByVal strDrv As String) As Long
    Dim lngRetVal As Long
    Dim strVNB As String * MAX_FILENAME_LEN
    Dim strFSNB As String * MAX_FILENAME_LEN
    Dim lngMCL As Long
    Dim lngFSF As Long
    
    Call GetVolumeInformation(strDrv & ":\", _
                                strVNB, _
                                MAX_FILENAME_LEN, _
                                lngRetVal, _
                                lngMCL, _
                                lngFSF, _
                                strFSNB, _
                                MAX_FILENAME_LEN)
    GetDriveSerial = lngRetVal
End Function


Function GetThisCpuID() As String
    Dim strComputer
    Dim WMI
    Dim wmiWin32Object
    Dim wmiWin32Objects
    Dim strText
    
    Set WMI = GetObject("WinMgmts://" & strComputer)
    Set wmiWin32Objects = WMI.InstancesOf("Win32_Processor")


    For Each wmiWin32Object In wmiWin32Objects
    
        'strText = "ProcessorID: " & wmiWin32Object.ProcessorId & vbCrLf
        'MsgBox strText
        GetThisCpuID = CStr(wmiWin32Object.ProcessorId)
        Exit Function  'we will stop at first for this use
    Next
    
End Function


 
Sub myUser()
    Dim lpBuff As String * 1313
    GetUserName lpBuff, Len(lpBuff)
    MsgBox Application.Trim(Application.Clean(lpBuff))
End Sub
 
Upvote 0
Logit said:
.
The following code checks the computer for three different specifics : HD Serial #, Processor Serial #, User Name.

Of those three, the first two would be the most secure to check against.


Code: 
Const LockToThisComputer = False
Public DriveSerial As String
Public Processor_ID As String
Const MAX_FILENAME_LEN = 256
Const SupervisorPassword = "987654"  'naturally you will lock the VBA project


Declare Function GetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetVolumeInformation _
    Lib "Kernel32" _
        Alias "GetVolumeInformationA" _
            (ByVal lpRootPathName As String, _
            ByVal lpVolumeNameBuffer As String, _
            ByVal nVolumeNameSize As Long, _
            lpVolumeSerialNumber As Long, _
            lpMaximumComponentLength As Long, _
            lpFileSystemFlags As Long, _
            ByVal lpFileSystemNameBuffer As String, _
            ByVal nFileSystemNameSize As Long) As Long




Sub Lockout()
Dim ThisDriveSerial As String
Dim ThisProcessor_ID As String
Dim Processor_Pass As Boolean
Dim Serial_Pass As Boolean


Processor_Pass = False
Serial_Pass = False


If LockToThisComputer Then
  'get serial
  ThisDriveSerial = CStr(GetDriveSerial("C"))
  'get drive
  ThisProcessor_ID = GetThisCpuID()
  'compare
  If ThisDriveSerial Like DriveSerial Then
    Serial_Pass = True
  End If
  If ThisProcessor_ID Like Processor_ID Then
    Processor_Pass = True
  End If


If Processor_Pass = False Or Serial_Pass = False Then
    'not allowed to run on this machine, so QUIT!
    'PERHAPS INSERT HERE:Give one last chance to give a password
    'saves endless lockout if a mistake has been made in setting up serials!


    ThisWorkbook.Saved = True
    ThisWorkbook.Close


End If




End If


End Sub




Sub Get_Serial()
    MsgBox "Serial of drive C is:-  " & GetDriveSerial("C")
   
End Sub
Sub GetCpuID()
MsgBox "Processor ID is:-  " & GetThisCpuID()
End Sub




Public Function GetDriveSerial(ByVal strDrv As String) As Long
    Dim lngRetVal As Long
    Dim strVNB As String * MAX_FILENAME_LEN
    Dim strFSNB As String * MAX_FILENAME_LEN
    Dim lngMCL As Long
    Dim lngFSF As Long
   
    Call GetVolumeInformation(strDrv & ":\", _
                                strVNB, _
                                MAX_FILENAME_LEN, _
                                lngRetVal, _
                                lngMCL, _
                                lngFSF, _
                                strFSNB, _
                                MAX_FILENAME_LEN)
    GetDriveSerial = lngRetVal
End Function


Function GetThisCpuID() As String
    Dim strComputer
    Dim WMI
    Dim wmiWin32Object
    Dim wmiWin32Objects
    Dim strText
   
    Set WMI = GetObject("WinMgmts://" & strComputer)
    Set wmiWin32Objects = WMI.InstancesOf("Win32_Processor")


    For Each wmiWin32Object In wmiWin32Objects
   
        'strText = "ProcessorID: " & wmiWin32Object.ProcessorId & vbCrLf
        'MsgBox strText
        GetThisCpuID = CStr(wmiWin32Object.ProcessorId)
        Exit Function  'we will stop at first for this use
    Next
   
End Function



Sub myUser()
    Dim lpBuff As String * 1313
    GetUserName lpBuff, Len(lpBuff)
    MsgBox Application.Trim(Application.Clean(lpBuff))
End Sub
Click to expand...

If we want to use the workbook in another computer the excel wont open.
is there any solution like
ProcessorID_Pass= Application.InputBox("ProcessorID")
Serial_Pass= Application.InputBox("Serial Number")

Or else please guide to how to open the excel with above workbook to open in another compute.
 
Upvote 0
The code as written is not specific to a particular computer. The code can be used on any computer.

I don't understand why Excel will not open the workbook for you.

The only thing in the code that MIGHT limit the opening is this line at the top of the macros :

Const SupervisorPassword = "987654" 'naturally you will lock the VBA project
by commenting it out like :
Const SupervisorPassword = ' "987654" 'naturally you will lock the VBA project

That would prevent the use of the password, but again, there is nothing in the code that is running that macro as written until
a user implements a call to the macro.
 
Upvote 0
Hi Logit,
I'm new to VBA if you please provide Sample workbook of the above working VBA code.
it would be grateful and keeps us motivating in learning Advanced VBA Code
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
I have 1 UserForm and want to save to different sheets in the same workbook
2
Replies
10
Views
177
Ellendigitl00
E
Logit
  • Question Question
Search In Other Workbook - Copy/Paste Offset Data To First Workbook - Repeat Process
Replies
7
Views
262
Logit
Logit
H
  • Question Question
Need to add column header values to this code
Replies
1
Views
52
Osvaldo Palmeiro
O
E
  • Question Question
Helps fix VBA code when inserting an image to another computer without causing the image to be blank
Replies
1
Views
163
DanteAmor
DanteAmor
M
  • Question Question
Modeless UserForm appears on wrong Excel workbook
Replies
5
Views
105
Jaafar Tribak
Jaafar Tribak

Forum statistics

Threads
1,223,236
Messages
6,170,906
Members
452,366
Latest member
TePunaBloke

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top