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

 
原文地址:https://www.cnblogs.com/kusy/p/8900723.html