如何为 VBA 应用程序创建产品密钥以防止非法分发软件？

How can I create product keys for VBA applications so that illegal distribution of software is prevented?

提问by Developer

I am working on an Excel VBA application.

我正在处理 Excel VBA 应用程序。

My company wants to make it a product. This application should be installable only on one system. Could someone please help me with this.

我的公司想把它做成产品。此应用程序应该只能安装在一个系统上。有人可以帮我解决这个问题。

回答by Siddharth Rout

This is just a basic example on how to ensure that your product is installed on just one system.

这只是关于如何确保您的产品仅安装在一个系统上的基本示例。

Logic:

逻辑：

1. Retrieve the Hardware ID (Ex: Hard Disk Number, CPU Number etc...)
2. You may also ask the user Name and email address
3. Encrypt the above info to generate an Unique Code(This is done within the App)
4. User sends you the Unique Code(Be it via email / Online Activation / Telephone)
5. You send the user an Activation Idbased on the Unique Code

1. 检索硬件 ID（例如：硬盘编号、CPU 编号等...）
2. 您也可以询问用户名和电子邮件地址
3. 加密以上信息以生成一个Unique Code（这是在应用程序中完成的）
4. 用户向您发送Unique Code（通过电子邮件/在线激活/电话）
5. 您Activation Id根据Unique Code

CODE for retrieving HardDisk Serial Number and CPU Number

获取硬盘序列号和CPU号的CODE

Paste this code in a class module (Not my code. Copyright info mentioned in the code)

将此代码粘贴到类模块中（不是我的代码。代码中提到的版权信息）

Private Const VER_PLATFORM_WIN32S = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2

Private Const DFP_RECEIVE_DRIVE_DATA = &H7C088

Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const CREATE_NEW = 1

Private Enum HDINFO
    HD_MODEL_NUMBER
    HD_SERIAL_NUMBER
    HD_FIRMWARE_REVISION
End Enum

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

Private Type IDEREGS
    bFeaturesReg As Byte
    bSectorCountReg As Byte
    bSectorNumberReg As Byte
    bCylLowReg As Byte
    bCylHighReg As Byte
    bDriveHeadReg As Byte
    bCommandReg As Byte
    bReserved As Byte
End Type

Private Type SENDCMDINPARAMS
    cBufferSize As Long
    irDriveRegs As IDEREGS
    bDriveNumber As Byte
    bReserved(1 To 3) As Byte
    dwReserved(1 To 4) As Long
End Type

Private Type DRIVERSTATUS
    bDriveError As Byte
    bIDEStatus As Byte
    bReserved(1 To 2) As Byte
    dwReserved(1 To 2) As Long
End Type

Private Type SENDCMDOUTPARAMS
    cBufferSize As Long
    DStatus As DRIVERSTATUS
    bBuffer(1 To 512) As Byte
End Type

Private Declare Function GetVersionEx _
    Lib "kernel32" Alias "GetVersionExA" _
    (lpVersionInformation As OSVERSIONINFO) As Long

Private Declare Function CreateFile _
    Lib "kernel32" Alias "CreateFileA" _
    (ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long

Private Declare Function CloseHandle _
    Lib "kernel32" _
    (ByVal hObject As Long) As Long

Private Declare Function DeviceIoControl _
    Lib "kernel32" _
    (ByVal hDevice As Long, _
    ByVal dwIoControlCode As Long, _
    lpInBuffer As Any, _
    ByVal nInBufferSize As Long, _
    lpOutBuffer As Any, _
    ByVal nOutBufferSize As Long, _
    lpBytesReturned As Long, _
    ByVal lpOverlapped As Long) As Long

Private Declare Sub ZeroMemory _
    Lib "kernel32" Alias "RtlZeroMemory" _
    (dest As Any, _
    ByVal numBytes As Long)

Private Declare Sub CopyMemory _
    Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, _
    Source As Any, _
    ByVal Length As Long)

Private Declare Function GetLastError _
    Lib "kernel32" () As Long

Private mvarCurrentDrive As Byte
Private mvarPlatform As String

Public Property Get Copyright() As String
    Copyright = "HDSN Vrs. 1.00, (C) Antonio Giuliana, 2001-2003"
End Property

Public Function GetModelNumber() As String
    GetModelNumber = CmnGetHDData(HD_MODEL_NUMBER)
End Function

Public Function GetSerialNumber() As String
    GetSerialNumber = CmnGetHDData(HD_SERIAL_NUMBER)
End Function

Public Function GetFirmwareRevision() As String
    GetFirmwareRevision = CmnGetHDData(HD_FIRMWARE_REVISION)
End Function

Public Property Let CurrentDrive(ByVal vData As Byte)
    If vData < 0 Or vData > 3 Then
        Err.Raise 10000, , "Illegal drive number"   ' IDE drive 0..3
    End If
    mvarCurrentDrive = vData
End Property

Public Property Get CurrentDrive() As Byte
    CurrentDrive = mvarCurrentDrive
End Property

Public Property Get Platform() As String
    Platform = mvarPlatform
End Property

Private Sub Class_Initialize()
    Dim OS As OSVERSIONINFO

    OS.dwOSVersionInfoSize = Len(OS)
    Call GetVersionEx(OS)
    mvarPlatform = "Unk"
    Select Case OS.dwPlatformId
        Case Is = VER_PLATFORM_WIN32S
            mvarPlatform = "32S"
        Case Is = VER_PLATFORM_WIN32_WINDOWS
            If OS.dwMinorVersion = 0 Then
                mvarPlatform = "W95"
            Else
                mvarPlatform = "W98"
            End If
        Case Is = VER_PLATFORM_WIN32_NT
            mvarPlatform = "WNT"
    End Select
End Sub

Private Function CmnGetHDData(hdi As HDINFO) As String
    Dim bin As SENDCMDINPARAMS
    Dim bout As SENDCMDOUTPARAMS
    Dim hdh As Long
    Dim br As Long
    Dim ix As Long
    Dim hddfr As Long
    Dim hddln As Long
    Dim s As String

    Select Case hdi
        Case HD_MODEL_NUMBER
            hddfr = 55
            hddln = 40
        Case HD_SERIAL_NUMBER
            hddfr = 21
            hddln = 20
        Case HD_FIRMWARE_REVISION
            hddfr = 47
            hddln = 8
        Case Else
            Err.Raise 10001, "Illegal HD Data type"

    End Select

    Select Case mvarPlatform
        Case "WNT"
            hdh = CreateFile("\.\PhysicalDrive" & mvarCurrentDrive, _
                GENERIC_READ + GENERIC_WRITE, FILE_SHARE_READ + FILE_SHARE_WRITE, _
                0, OPEN_EXISTING, 0, 0)
        Case "W95", "W98"
            hdh = CreateFile("\.\Smartvsd", _
                0, 0, 0, CREATE_NEW, 0, 0)
        Case Else
            Err.Raise 10002, , "Illegal platform (only WNT, W98 or W95)"
    End Select
    If hdh = 0 Then
        Err.Raise 10003, , "Error on CreateFile"
    End If

    ZeroMemory bin, Len(bin)
    ZeroMemory bout, Len(bout)

    With bin
        .bDriveNumber = mvarCurrentDrive
        .cBufferSize = 512
        With .irDriveRegs
            If (mvarCurrentDrive And 1) Then
                .bDriveHeadReg = &HB0
            Else
                .bDriveHeadReg = &HA0
            End If
            .bCommandReg = &HEC
            .bSectorCountReg = 1
            .bSectorNumberReg = 1
        End With
    End With

    DeviceIoControl hdh, DFP_RECEIVE_DRIVE_DATA, _
                    bin, Len(bin), bout, Len(bout), br, 0

    s = ""
    For ix = hddfr To hddfr + hddln - 1 Step 2
        If bout.bBuffer(ix + 1) = 0 Then Exit For
        s = s & Chr(bout.bBuffer(ix + 1))
        If bout.bBuffer(ix) = 0 Then Exit For
        s = s & Chr(bout.bBuffer(ix))
    Next ix

    CloseHandle hdh

    CmnGetHDData = Trim(s)
End Function

You can then call it using

然后你可以调用它使用

'~~> Get the CPU No
CPU = GetWmiDeviceSingleValue("Win32_Processor", "ProcessorID")

'~~> Get the Hard Disk No
Dim h As HDSN

Set h = New HDSN

With h
    .CurrentDrive = 0
    HDNo = .GetSerialNumber
End With

Set h = Nothing

Once you have this info, you can then merge it with the First Name, Last Name and the email address to create a string. For example

获得此信息后，您可以将其与名字、姓氏和电子邮件地址合并以创建一个字符串。例如

strg = Trim(FirstName) & Chr(1) & Trim(LastName) & Chr(1) & _
       Trim(EmailAddress) & Chr(1) & Trim(CPU) & Chr(1) & Trim(HDNo)

Once you have the string, you can then encrypt it. Here is another basic example of encrypting it. You can choose any type of encryption that you would like

获得字符串后，您就可以对其进行加密。这是加密它的另一个基本示例。您可以选择您喜欢的任何类型的加密

For i = 1 To Len(strg)
    RandomNo = (Rnd * 100)
    tmp = tmp & Hex((Asc(Mid(strg, i, 1)) Xor RandomNo))
Next

The tmpabove holds the encrypted string.

在tmp上述保持加密的字符串。

Once you receive this string, you will have to decode it and create an Activation Idbased on that. You App should be able to accept the Activation Id. You also have an option to store this info in the registry or in a Dat File.

收到此字符串后，您必须对其进行解码并Activation Id基于该字符串创建一个。您的应用程序应该能够接受Activation Id. 您还可以选择将此信息存储在注册表或数据文件中。

A simple registration window might look like this.

一个简单的注册窗口可能如下所示。

Hope this gets you started! :)

希望这能让你开始！:)

IMP: Though you can lock your VBA project but it is definitely not hack proof. You might want to explore VSTO to create DLLs which does the above thing.

IMP：虽然你可以锁定你的 VBA 项目，但它绝对不是黑客证明。您可能想要探索 VSTO 来创建执行上述操作的 DLL。