对于密码破译方面笔者不太懂，之前对于各种序列号的激活也有些臆测，自己根据想法做了个序列号验证的小框架，以后做的工具也可以用之保护一下下。。。
主要思路是：用户打开小工具后，系统检测是否已激活，如果未激活，系统给出一个随机数字码（每次重新打开之后会变化），用户根据随机码向提供者索要对应激活码用于激活
关于是否激活的判断：笔者这里做法是，正常激活后会在注册表里写对应值，如果检测到这个值就不会再次提醒用户激活
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