vba实现工具的序列号验证框架

对于密码破译方面笔者不太懂，之前对于各种序列号的激活也有些臆测，自己根据想法做了个序列号验证的小框架，以后做的工具也可以用之保护一下下。。。

主要思路是：用户打开小工具后，系统检测是否已激活，如果未激活，系统给出一个随机数字码（每次重新打开之后会变化），用户根据随机码向提供者索要对应激活码用于激活

关于是否激活的判断：笔者这里做法是，正常激活后会在注册表里写对应值，如果检测到这个值就不会再次提醒用户激活

1、随机码的生成，根据随机数Rnd来生成满足条件的一串数字，直接上代码

Sub SetRanId()
    Randomize
    Dim RanId As Long

SetRndId:
    RanId = Rnd * 100000000 + _
                   Rnd * 10000000 + _
                   Rnd * 1000000 + _
                   Rnd * 100000 + _
                   Rnd * 10000 + _
                   Rnd * 1000 + _
                   Rnd * 100 + _
                   Rnd * 10
    If RanId < 10000000 Or RanId > 99999999 Then GoTo SetRndId
    FrmCheckId.TextBox1.Value = RanId

End Sub

效果如下图：

2、对应激活序列号的校验

其实这里笔者做的只是依据随机码，通过一组规则生成序列号，直接上代码，可以看出校验规则其实我已经做了封装，在这个类中：MyMethod.KUSY

'序列号设置
Sub CheckTheId()
    On Error GoTo Err_CheckId
    Dim rId As Long
    Dim sId As String
    Dim MyFnc
    
    rId = CLng(FrmCheckId.TextBox1.Value)
    sId = FrmCheckId.TextBox2.Value
    Set MyFnc = CreateObject("MyMethod.KUSY")
    
    If Len(sId) >= 8 Then
        If MyFnc.CheckId(sId, rId) Then
            MsgBox "已激活！", vbInformation
            idFlg = True
            Call MyFnc.RegChk(idFlg, RegFlg)
            Unload FrmCheckId
        End If
    End If
    
    Set MyFnc = Nothing
    Exit Sub
Err_CheckId:
    MsgBox Err.Description, vbCritical
    
End Sub

3、关于封装类KUSY的方法也贴了出来

（1）检查注册表是否已有键值，如果没有，写入设定好的键值，如果有，返回True，说明工具已激活，不再进行序列号的激活处理

'注册表检查以及设置
Function RegChk(ByVal idFlg As Boolean, ByRef RegFlg As Boolean) As Boolean
    On Error GoTo Err_RegChk
    Dim s As String
    
    RegChk = False
    Set WSH = CreateObject("WSCRIPT.SHELL")
    s = WSH.RegRead(RegPK & PjName & "\" & RegX & "\" & KeyName)
    
Err_RegChk:
    If s = KeyVal Then
        RegFlg = True
        RegChk = True
    Else
        RegFlg = False
        RegChk = False
    End If
    
    If RegFlg = False And idFlg = True Then
        WSH.RegWrite RegPK & PjName & "\" & RegX & "\" & KeyName, KeyVal
        RegChk = True
    End If

End Function

（2）序列号生成规则，如下，可以看到笔者随意设置了一组规则，这个就是需要填写的激活码了

'序列号取得
Function GetMyId(ByVal rId As Long) As String
    Dim id(1 To 8) As Long
    Dim flg As String
    Dim result As String
    
    For i = 1 To 8
        id(i) = Mid(CStr(rId), i, 1)
        Select Case i
            Case 1
                id(i) = id(i) * 10 Mod 9
            Case 2
                id(i) = id(i) * 10 Mod 7
            Case 3
                id(i) = id(i) * id(i)
                If id(i) > 10 Then id(i) = (id(i) - 10) Mod 9
            Case 4
                If id(i) > id(i - 1) Then id(i) = id(i) - id(i - 1)
            Case 5
                id(i) = id(i) * 8 Mod 9
            Case 6
                id(i) = id(i) * 20 Mod 9
            Case 7
                If id(i) > 5 Then
                        id(i) = id(i) / 2
                Else
                        id(i) = id(i) + 1
                End If
            Case 8
                id(i) = Left(CStr(id(i) * 9), 1)
        End Select
    Next
    
    If id(3) + id(5) > 3 Then flg = "k"
    If id(3) + id(5) > 8 Then flg = "u"
    If id(3) + id(5) > 13 Then flg = "s"
    If id(3) + id(5) > 17 Then flg = "y"
    
    For Each s In id
        result = result & s
    Next
    
    'result = Replace(Join(id, " "), " ", "")
    GetMyId = result & flg
    
End Function

（3）校验用户输入函数，直接返回布尔值，为什么要写这个而不是直接在vba代码中判断用户输入的序列号是否等于规则生成的呢？因为如果不用下面这个函数，用户直接在vbe中debug就可以获取到规则生成的序列号了

Function CheckId(ByVal sId As String, ByVal rId As Long) As Boolean
    If sId = GetMyId(rId) Then
        CheckId = True
    Else
        CheckId = False
    End If
    
End Function

4、对于序列号生成规则的代码，可以独立出来，用于生成序列号值，把这个值给用户来激活

如下图：

（1）管理员

（2）用户

5、其他的工具以后就可以使用这个序列号验证框架了，使用方法如下

（1）打开时加载dll文件，关闭时移除

Private Sub Workbook_Open()
    On Error GoTo Err_WorkOpen
    Application.Visible = False
    
    'Dll加载
    If Dir(ThisWorkbook.Path & "\MyMethod.dll") <> "" Then
        Shell "Regsvr32 /s " & Chr(34) & ThisWorkbook.Path & "\MyMethod.dll" & Chr(34)
    Else
        MsgBox "DLL文件不存在，请确认！", vbCritical
        Exit Sub
    End If
    
    FrmCheckId.Show
    Application.Visible = True
    Exit Sub
Err_WorkOpen:
    MsgBox Err.Description, vbCritical
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Shell "Regsvr32 /s /u " & Chr(34) & ThisWorkbook.Path & "\MyMethod.dll" & Chr(34)
End Sub

（2）工具中添加UserForm

初始化时调用KUSY.RegChk，代码如下：

Private Sub UserForm_Initialize()
    On Error GoTo Err_Init
    Dim idFlg As Boolean
    Dim Myfnc
    
    HideFlg = False
    Set Myfnc = CreateObject("MyMethod.KUSY")
    
    '检查注册表
    If Myfnc.RegChk(idFlg, RegFlg) = True Then
        HideFlg = True
        GoTo EndFrm
    End If

With FrmCheckId
        .Caption = "序列号验证--V1.1"
        .BackColor = ColorConstants.vbWhite
        .BorderStyle = fmBorderStyleNone
        .Width = 200
        .Height = 120
    End With
    
    TextBox1.Enabled = False
    
    Call SetRanId
    Set Myfnc = Nothing
EndFrm:
    Exit Sub
Err_Init:
    MsgBox Err.Description, vbCritical
End Sub