How can I create product keys for VBA add-ins and store it in the system?

[anish.ms]

Dear Experts,

Is there any simple way to create product keys and store the info somewhere in the pc for a VBA add-in to restrict the usage with in the organization ?
I saw the following post - activation key generated with a combination of user details, cpu number and hard disk number. But it is not working for me and also it seems to be very complicated
excel - How can I create product keys for VBA applications so that illegal distribution of software is prevented? - Stack Overflow

Thanks for your time!

[Logit]

I didn't read the link you provided ... having said that ... you could create a small text file with a "key" - place that text file somewhere on the computer's hard drive and name the file something that doesn't reflect back to your
add-in. Example : If your add in is called "Press Button To Copy Files To Selected Folder" .... name the small text file something like "300487GDH.txt"

Then in your Add In have it check the existence of that small text file first before running. If the text file isn't there, advise your user they are not licensed for its use.


Creating a KEY in the system registry is not that difficult. This is another possibility, where your Add In will check the registry first for the required key.

[anish.ms]

Thanks for your response Logit!
It would be very helpful if you could share some sample codes.
Thanks for your time!

[Logit]

I don't have any codes to share. If you GOOGLE the titles you will receive tons of answers.

For the TEXT file, search for "Creating A Text File". Then something like "How to copy a text file to a specific Directory". There really doesn't need to be anything in the text file (unless you really want there to be). Your project only
needs to check for the existence and if it does exist, the user is good to go. If the text file does not exist, advise the user they are not licensed.

For the Registry Keys ... search for "Creating a Registry Key". Also search for "Reading A Registry Key". The 'reading' will be the verification your program needs before running the add in.

[anish.ms]

Thanks Logit!
I will check it out.

[arnelgp]

you should be able to do it in the workbook's Open event.

paste this in a Module:

'http://www.vbaexpress.com/kb/getarticle.php?kb_id=677
Function getMyCustomDocProperty() As String
     '   ============================================
     '   Save a value in CustomDocumentProperties
     '   ============================================
     '   Constant string for the property we are adding
    Const szVersion As String = "_HD"
     
     
     '   ========================================================================
     '   If the name doesn't exist, we create it and set the initial value to 1
    On Error Resume Next
    Dim szDocVal As String
    Dim cstmDocProp As DocumentProperty
    Set cstmDocProp = ThisWorkbook.CustomDocumentProperties(szVersion)
     
    If Err.Number > 0 Then
        szDocVal = GetPhysicalSerial() & ""
        ThisWorkbook.CustomDocumentProperties.Add _
        Name:=szVersion, _
        LinkToContent:=False, _
        Type:=msoPropertyTypeString, _
        Value:=szDocVal
         '   ========================================================================
         
    Else
         
         '   ========================================================================
         '       if our name exists, we need to increment the value in it by 1
         '       to do this, we parse the name's RefersTo value:
        szDocVal = ThisWorkbook.CustomDocumentProperties(szVersion).Value
         
         
         '       Reset the name to refer to our new value
        'ThisWorkbook.CustomDocumentProperties(szVersion).Value = CLng(szDocVal) + 1
         '   ========================================================================
         
    End If
     
     '   Explicitly clear memory
    Set cstmDocProp = Nothing
    getMyCustomDocProperty = szDocVal
End Function


Function GetPhysicalSerial() As Variant


    Dim obj As Object
    Dim wmi As Object
    Dim SNList() As String, i As Long, count As Long
    
    Set wmi = GetObject("WinMgmts:")
    
    For Each obj In wmi.InstancesOf("Win32_PhysicalMedia")
        If obj.SerialNumber <> "" Then count = count + 1
    Next
    
    'ReDim SNList(1 To Count, 1 To 1)
    ReDim SNList(1 To count)
    
    i = 1
    For Each obj In wmi.InstancesOf("Win32_PhysicalMedia")
        'SNList(i, 1) = obj.SerialNumber
        SNList(i) = Trim(obj.SerialNumber & "")
        Debug.Print Trim(obj.SerialNumber & "")
        i = i + 1
        If i > count Then Exit For
    Next
    
    GetPhysicalSerial = SNList(1)
End Function

add code to Workbook's Open event:

Private Sub Workbook_Open()


    Dim hd As String
    hd = GetPhysicalSerial() & ""
    If hd <> getMyCustomDocProperty() Then
        Application.Quit
    End If
End Sub

save your workbook as .xlsm

to test close and re-open the workbook.
you Enable the macro if you are presented with a message.

close, the workbook again and copy and open it in
different computer.

[anish.ms]

Hi arnelgp, Thanks for your time!
I'm getting run-time error '-2147217400(80041008)': Automation error on line

Set wmi = GetObject("WinMgmts:")

[arnelgp]

can you google why you have that error and what is your os?

[anish.ms]

Thanks arnelgp!
I will try to check it out. My OS is win 10Pro 64bit

[anish.ms]

Hi,
I have created a simple one which saves the key in excel add-in folder , request your suggestions for improvements
Thanks Logit for your inputs above!

Option Explicit
Dim Key        As String


Private Sub UserForm_Initialize()
    CreateActivationKey
    CheckActivation
End Sub


Sub CreateActivationKey()
    Dim Strg   As String
    Dim i      As Long


    Me.TB_CompName.Text = Environ("ComputerName")
    Me.TB_UsrName.Text = Environ("UserName")
    
    Strg = Trim(Me.TB_CompName.Text) & Trim(Me.TB_UsrName.Text)
    
    For i = 1 To Len(Strg)
        Key = Key & Hex((Asc(Mid(Strg, i, 1)) Xor 100))
    Next i
    ActiveSheet.Range("A1") = Key
End Sub


Sub CheckActivation()
    Dim ActivationFileName As String, ActivationFileExists As String
    ActivationFileName = Application.UserLibraryPath & Key & ".txt"
    ActivationFileExists = Dir(ActivationFileName)
    
    If ActivationFileExists = "" Then
        MsgBox "This Add-in is not activated"
    Else
        MsgBox "This Add-in is already activated"
    End If
End Sub


Private Sub Btn_Activate_Click()
    Dim ActivationCode As String
    Dim FSO    As Object
    Dim ActivationFile As Object


    ActivationCode = Me.TB_ActivationCode.Text
    If Len(ActivationCode) = 0 Then
        MsgBox "Please enter the activation code.", vbInformation
    ElseIf ActivationCode = Key Then
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set ActivationFile = FSO.CreateTextFile(Application.UserLibraryPath & Key & ".txt", True, True)
        With ActivationFile
            .Write "Registered Computer Name : " & Me.TB_CompName.Text & vbNewLine
            .Write "Registered User Name : " & Me.TB_UsrName.Text & vbNewLine
            .Write "Activation Code : " & Key & vbNewLine
            .Close
        End With
        MsgBox "Successfully Activated.", vbInformation
        Me.Hide
        Unload Me
    Else
        MsgBox "Invalid Activation Code.", vbInformation
    End If
End Sub

[Paul_Hossler]

I don't understand how you're planning to use this

I'm guessing / assuming that there's a ABCD1234.XLAM that you want to protect and that when it starts it will check to see if it's properly activated by checking 'something'

How does the activation code get loaded onto the PC in order to be checked?

[anish.ms]

Hi Paul,
I was just thinking, how can an addin be restricted from using in other pcs.
Yes, your guessing is correct. CreateActivationKey and CheckActivation procedures from my above code can be called on loading the add-in and the activation form also can go to the add-in for activation.
Request your advice

Thanks for your time!

Replied from mobile. Hence please ignore typo errors if any

[Paul_Hossler]

Hi Paul,
I was just thinking, how can an addin be restricted from using in other pcs.
Yes, your guessing is correct. CreateActivationKey and CheckActivation procedures from my above code can be called on loading the add-in and the activation form also can go to the add-in for activation.
Request your advice

Thanks for your time!

I don't see how having your add-in both generate the activation key and check it will do what you want

Any number of users can generate a key and check it



Having your add-in check to see if it's 'activated' before running is easy to do but easy to bypass by anyone who knows a little VBA

One cumbersome way might be to

1. Let user load add-in

2. If NOT activated

2a. Ask for Activation Code, OR Tell user that you generated some kind of PC hardware code (like in post #1)
2b. Send YOU the above code
2c. You generate a hash of the user's code
2d. Mail back
2e. User tries to run add-in again, and this time enters the hash from 2c
2f. Hash code stored in registry

3. If activated

3a. Generate PC hardware code (like in post #1)
3b. Hash it
3c. Compare to stored registry value (2f)
3d. If they match them let add-in load

[Logit]

Last part of my comment in #4 ....

[Paul_Hossler]

Last part of my comment in #4 ....

How does the registry key get there?

If it's added by the add-in, then everyone whoever installs the add-in will have a valid activation code. That doesn't meet the objective in post #1

to restrict the usage with in the organization

[anish.ms]

Thanks for your feedback and advice Paul!
I agree, it is easy to bypass by anyone who knows a little VBA including protecting the VBA project
I didn't search much for the option to store the key in registry. Because I think, the registry location depends on the OS and found this txt file version is an easy one.
I will check out the option of PC hardware code and saving the key in registry. Thanks for your time!

[Logit]

Paul :

Very similar to what you said in your previous post. There would have to be a separate Registry Key for each installation.

Reminds me of previous times when software was sent via 'floppy' disk. Each disk had a unique installation/registration code.
If the purchaser shared the software with others then of course the registration code wasn't worth much. That would be the
same thing here when the user receives the hashed registration code.

All in all its just an additional step to slow down the devious minded. Honest folks will be kept honest with the registration key.
And then there are those who like to tinker with the VBA code. That cannot be protected no matter what you do. If the user
knows enough ... the code will get broken.

[Paul_Hossler]

Reminds me of previous times when software was sent via 'floppy' disk. Each disk had a unique installation/registration code.
If the purchaser shared the software with others then of course the registration code wasn't worth much. That would be the
same thing here when the user receives the hashed registration code.

Sure, but that means each copy of the add-in would need the OP to generate and insert a unique key (probably a GUID is best)

1. Ten people need the add-in

2. OP makes 10 copies of add-in

3. OP makes GUID in each of 10 and distributes

4. User 1 gets their copy, and installs it and the GUID in the XLAM is added to the registry (SaveSetting)

5. User 1 opens Excel to use add-in, add-in checks it's embedded GUID against registry (GetSetting)

5. Add in says "I'm good" and runs


But, ...

User 1 says, "Hey User 11. You'll like this"

GoTo 4

Without some central registration authority, I think it won't work

[Logit]

Yup ... problems, problems, problems.

Perhaps matching the key to the user's HD serial number would be better.

[anish.ms]

Hi,
I have revised the codes based on the hard disk volume id. I have also got sample codes to read and write the registry keys. However, not sure how to make it work and request some help in making it work.

Option Explicit
Public Key        As String, Strg   As String

Sub CreateActivationKey()    
Dim i      As Long
    Strg = DiskVolumeId(Environ("SystemDrive"))
    For i = 1 To Len(Strg)
        Key = Key & Hex(Asc(Mid(Strg, i, 1)))
    Next i
End Sub


Function DiskVolumeId(Drive As String) As String
    Dim sTemp  As String
    Dim iPos   As Long
    iPos = InStr(1, Drive, ":")
    Drive = IIf(iPos > 0, Left(Drive, iPos), Drive & ":")
    sTemp = Hex(CreateObject("Scripting.FileSystemObject") _
            .Drives.Item(CStr(Drive)).SerialNumber)
    DiskVolumeId = Left(sTemp, 4) & "-" & Right(sTemp, 4)
End Function

Function RegKeyRead(i_RegKey As String) As String    
Dim myWS   As Object

    On Error Resume Next
    Set myWS = CreateObject("WScript.Shell")
    RegKeyRead = myWS.RegRead(i_RegKey)
End Function


Sub RegKeySave(i_RegKey As String, _
    i_Value As String, _
    Optional i_Type As String = "REG_DWORD")
    Dim myWS   As Object


    Set myWS = CreateObject("WScript.Shell")
    myWS.RegWrite i_RegKey, i_Value, i_Type
    
End Sub


Function RegKeyExists(i_RegKey As String) As Boolean
    Dim myWS   As Object


    On Error GoTo ErrorHandler
    Set myWS = CreateObject("WScript.Shell")
    myWS.RegRead i_RegKey
    RegKeyExists = True
    Exit Function
    
ErrorHandler:
    RegKeyExists = False
End Function