VBA to Restrict Use of Workbook to Two Computers

[bisel]

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.

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

 

[mole999]

if you use ENVIRON then you could target a specific that the system knows about

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

 

[bisel]

if you use ENVIRON then you could target a specific that the system knows about ...

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?

 

[mole999]

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

 

[Logit]

.
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.

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

 

[srikanth sare]

.
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.

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

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.

 

[Logit]

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.

 

[srikanth sare]

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